Mercurial > emacs
comparison lisp/gnus/nnwarchive.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | 695cf19ef79e |
children | 18a818a2ee7c cce1c0ee76ee |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
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>: *\\([^<]*[^< ]\\) *<\\([^&]+\\)>") |
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 |