Mercurial > emacs

comparison lisp/gnus/nnwarchive.el @ 89971:cce1c0ee76ee

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-36 Merge from emacs--cvs-trunk--0, emacs--gnus--5.10, gnus--rel--5.10 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523 Merge from emacs--gnus--5.10, gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-524 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-534 Update from CVS * miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0 tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1 Import from CVS branch gnus-5_10-branch * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2 Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18 Update from CVS * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19 Remove autoconf-generated files from archive * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20 Update from CVS
author Miles Bader <miles@gnu.org>
date Thu, 09 Sep 2004 09:36:36 +0000
parents 561b856c5b1f 55fd4f77387a
children f9a65d7ebd29
comparison
equal deleted inserted replaced
89970:a849e5779b8c 89971:cce1c0ee76ee
1 ;;; nnwarchive.el --- interfacing with web archives 1 ;;; nnwarchive.el --- interfacing with web archives
2 ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. 2 ;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc.
3 3
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> 4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
5 ;; Keywords: news egroups mail-archive 5 ;; Keywords: news egroups mail-archive
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
22 ;; Boston, MA 02111-1307, USA. 22 ;; Boston, MA 02111-1307, USA.
23 23
24 ;;; Commentary: 24 ;;; Commentary:
25 25
26 ;; Note: You need to have `url' (w3 0.46) or greater version 26 ;; Note: You need to have `url' (w3 0.46) or greater version
27 ;; installed for this backend to work. 27 ;; installed for some functions of this backend to work.
28 28
29 ;; Todo: 29 ;; Todo:
30 ;; 1. To support more web archives. 30 ;; 1. To support more web archives.
31 ;; 2. Generalize webmail to other MHonArc archive. 31 ;; 2. Generalize webmail to other MHonArc archive.
32 32
39 (require 'gnus-util) 39 (require 'gnus-util)
40 (require 'gnus) 40 (require 'gnus)
41 (require 'gnus-bcklg) 41 (require 'gnus-bcklg)
42 (require 'nnmail) 42 (require 'nnmail)
43 (require 'mm-util) 43 (require 'mm-util)
44 (require 'mail-source) 44 (require 'mm-url)
45 (eval-when-compile
46 (ignore-errors
47 (require 'w3)
48 (require 'url)
49 (require 'w3-forms)
50 (require 'nnweb)))
51 ;; Report failure to find w3 at load time if appropriate.
52 (eval '(progn
53 (require 'w3)
54 (require 'url)
55 (require 'w3-forms)
56 (require 'nnweb)))
57 45
58 (nnoo-declare nnwarchive) 46 (nnoo-declare nnwarchive)
59 47
60 (defvar nnwarchive-type-definition 48 (defvar nnwarchive-type-definition
61 '((egroups 49 '((egroups
295 (read-string 283 (read-string
296 (format "Login at %s: " server) 284 (format "Login at %s: " server)
297 user-mail-address))) 285 user-mail-address)))
298 (setq nnwarchive-passwd 286 (setq nnwarchive-passwd
299 (or nnwarchive-passwd 287 (or nnwarchive-passwd
300 (mail-source-read-passwd 288 (read-passwd
301 (format "Password for %s at %s: " 289 (format "Password for %s at %s: "
302 nnwarchive-login server))))) 290 nnwarchive-login server)))))
303 (unless nnwarchive-groups 291 (unless nnwarchive-groups
304 (nnwarchive-read-groups)) 292 (nnwarchive-read-groups))
305 (save-excursion 293 (save-excursion
358 (save-excursion 346 (save-excursion
359 (nnheader-set-temp-buffer 347 (nnheader-set-temp-buffer
360 (format " *nnwarchive %s %s*" nnwarchive-type server))))) 348 (format " *nnwarchive %s %s*" nnwarchive-type server)))))
361 (nnwarchive-set-default nnwarchive-type)) 349 (nnwarchive-set-default nnwarchive-type))
362 350
363 (defun nnwarchive-encode-www-form-urlencoded (pairs)
364 "Return PAIRS encoded for forms."
365 (mapconcat
366 (function
367 (lambda (data)
368 (concat (w3-form-encode-xwfu (car data)) "="
369 (w3-form-encode-xwfu (cdr data)))))
370 pairs "&"))
371
372 (defun nnwarchive-fetch-form (url pairs)
373 (let ((url-request-data (nnwarchive-encode-www-form-urlencoded pairs))
374 (url-request-method "POST")
375 (url-request-extra-headers
376 '(("Content-type" . "application/x-www-form-urlencoded"))))
377 (nnweb-insert url))
378 t)
379
380 (defun nnwarchive-eval (expr) 351 (defun nnwarchive-eval (expr)
381 (cond 352 (cond
382 ((consp expr) 353 ((consp expr)
383 (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr)))) 354 (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr))))
384 ((symbolp expr) 355 ((symbolp expr)
386 (t 357 (t
387 expr))) 358 expr)))
388 359
389 (defun nnwarchive-url (xurl) 360 (defun nnwarchive-url (xurl)
390 (mm-with-unibyte-current-buffer 361 (mm-with-unibyte-current-buffer
391 (let ((url-confirmation-func 'identity) 362 (let ((url-confirmation-func 'identity) ;; Some hacks.
392 (url-cookie-multiple-line nil)) 363 (url-cookie-multiple-line nil))
393 (cond 364 (cond
394 ((eq (car xurl) 'post) 365 ((eq (car xurl) 'post)
395 (pop xurl) 366 (pop xurl)
396 (nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl)))) 367 (mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
397 (t 368 (t
398 (nnweb-insert (apply 'format (nnwarchive-eval xurl)))))))) 369 (mm-url-insert (apply 'format (nnwarchive-eval xurl))))))))
399 370
400 (defun nnwarchive-generate-active () 371 (defun nnwarchive-generate-active ()
401 (save-excursion 372 (save-excursion
402 (set-buffer nntp-server-buffer) 373 (set-buffer nntp-server-buffer)
403 (erase-buffer) 374 (erase-buffer)
468 (setq date (identity (match-string 1)))) 439 (setq date (identity (match-string 1))))
469 (push (cons 440 (push (cons
470 article 441 article
471 (make-full-mail-header 442 (make-full-mail-header
472 article 443 article
473 (nnweb-decode-entities-string subject) 444 (mm-url-decode-entities-string subject)
474 (nnweb-decode-entities-string from) 445 (mm-url-decode-entities-string from)
475 date 446 date
476 (concat "<" group "%" 447 (concat "<" group "%"
477 (number-to-string article) 448 (number-to-string article)
478 "@egroup.com>") 449 "@egroup.com>")
479 "" 450 ""
488 (if (search-backward "</pre>" nil t) 459 (if (search-backward "</pre>" nil t)
489 (delete-region (point) (point-max))) 460 (delete-region (point) (point-max)))
490 (goto-char (point-min)) 461 (goto-char (point-min))
491 (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t) 462 (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
492 (replace-match "\\1")) 463 (replace-match "\\1"))
493 (nnweb-decode-entities) 464 (mm-url-decode-entities)
494 (buffer-string)) 465 (buffer-string))
495 466
496 (defun nnwarchive-egroups-xover-files (group articles) 467 (defun nnwarchive-egroups-xover-files (group articles)
497 (let (aux auxs) 468 (let (aux auxs)
498 (setq auxs (nnwarchive-paged (sort articles '<))) 469 (setq auxs (nnwarchive-paged (sort articles '<)))
548 nil t) 519 nil t)
549 (setq article (1+ (string-to-number (match-string 1))) 520 (setq article (1+ (string-to-number (match-string 1)))
550 subject (match-string 2)) 521 subject (match-string 2))
551 (forward-line 1) 522 (forward-line 1)
552 (unless (assq article nnwarchive-headers) 523 (unless (assq article nnwarchive-headers)
553 (if (looking-at "<UL><LI><EM>From</EM>:\\([^&]+\\)<\\([^&]+\\)>") 524 (if (looking-at "<UL><LI><EM>From</EM>: *\\([^<]*[^< ]\\) *&lt;\\([^&]+\\)&gt;")
554 (progn 525 (progn
555 (setq from (match-string 1) 526 (setq from (match-string 1)
556 date (identity (match-string 2)))) 527 date (identity (match-string 2))))
557 (setq from "" date "")) 528 (setq from "" date ""))
558 (push (cons 529 (push (cons
559 article 530 article
560 (make-full-mail-header 531 (make-full-mail-header
561 article 532 article
562 (nnweb-decode-entities-string subject) 533 (mm-url-decode-entities-string subject)
563 (nnweb-decode-entities-string from) 534 (mm-url-decode-entities-string from)
564 date 535 date
565 (format "<%05d%%%s>\n" (1- article) group) 536 (format "<%05d%%%s>\n" (1- article) group)
566 "" 537 ""
567 0 0 "")) nnwarchive-headers)))) 538 0 0 "")) nnwarchive-headers))))
568 nnwarchive-headers) 539 nnwarchive-headers)
621 (save-restriction 592 (save-restriction
622 (goto-char (point-min)) 593 (goto-char (point-min))
623 (when (search-forward "X-Head-End" nil t) 594 (when (search-forward "X-Head-End" nil t)
624 (beginning-of-line) 595 (beginning-of-line)
625 (narrow-to-region (point-min) (point)) 596 (narrow-to-region (point-min) (point))
626 (nnweb-decode-entities) 597 (mm-url-decode-entities)
627 (goto-char (point-min)) 598 (goto-char (point-min))
628 (while (search-forward "<!--X-" nil t) 599 (while (search-forward "<!--X-" nil t)
629 (replace-match "")) 600 (replace-match ""))
630 (goto-char (point-min)) 601 (goto-char (point-min))
631 (while (search-forward " -->" nil t) 602 (while (search-forward " -->" nil t)
643 (forward-line) 614 (forward-line)
644 (delete-region (point-min) (point)) 615 (delete-region (point-min) (point))
645 (search-forward "</ul>" nil t) 616 (search-forward "</ul>" nil t)
646 (end-of-line) 617 (end-of-line)
647 (narrow-to-region (point-min) (point)) 618 (narrow-to-region (point-min) (point))
648 (nnweb-remove-markup) 619 (mm-url-remove-markup)
649 (nnweb-decode-entities) 620 (mm-url-decode-entities)
650 (goto-char (point-min)) 621 (goto-char (point-min))
651 (delete-blank-lines) 622 (delete-blank-lines)
652 (when from 623 (when from
653 (message-remove-header "from") 624 (message-remove-header "from")
654 (goto-char (point-max)) 625 (goto-char (point-max))
685 (setq p (point)) 656 (setq p (point))
686 (when (search-forward "</PRE>" nil t) 657 (when (search-forward "</PRE>" nil t)
687 (delete-region (match-beginning 0) (match-end 0)) 658 (delete-region (match-beginning 0) (match-end 0))
688 (save-restriction 659 (save-restriction
689 (narrow-to-region p (point)) 660 (narrow-to-region p (point))
690 (nnweb-remove-markup) 661 (mm-url-remove-markup)
691 (nnweb-decode-entities) 662 (mm-url-decode-entities)
692 (goto-char (point-max))))) 663 (goto-char (point-max)))))
693 ((looking-at "<P><A HREF=\"\\([^\"]+\\)") 664 ((looking-at "<P><A HREF=\"\\([^\"]+\\)")
694 (setq url (match-string 1)) 665 (setq url (match-string 1))
695 (delete-region (match-beginning 0) 666 (delete-region (match-beginning 0)
696 (progn (forward-line) (point))) 667 (progn (forward-line) (point)))
697 ;; I hate to download the url encode it, then immediately 668 ;; I hate to download the url encode it, then immediately
698 ;; decode it. 669 ;; decode it.
699 ;; FixMe: Find a better solution to attach the URL. 670 (insert "<#external"
700 ;; Maybe do some hack in external part of mml-generate-mim-1. 671 " type="
701 (insert "<#part>" 672 (or (and url
702 "\n--\nExternal: \n" 673 (string-match "\\.[^\\.]+$" url)
703 (format "<URL:http://www.mail-archive.com/%s/%s>" 674 (mailcap-extension-to-mime
675 (match-string 0 url)))
676 "application/octet-stream")
677 (format " url=\"http://www.mail-archive.com/%s/%s\""
704 group url) 678 group url)
705 "\n--\n" 679 ">\n"
706 "<#/part>") 680 "<#/external>")
707 (setq mime t)) 681 (setq mime t))
708 (t 682 (t
709 (setq p (point)) 683 (setq p (point))
710 (insert "<#part type=\"text/html\" disposition=inline>") 684 (insert "<#part type=\"text/html\" disposition=inline>")
711 (goto-char 685 (goto-char