/[emacs]/emacs/lisp/gnus/nnwarchive.el
ViewVC logotype

Diff of /emacs/lisp/gnus/nnwarchive.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.2.2 by miles, Tue Oct 14 23:34:51 2003 UTC revision 1.2.2.3 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; nnwarchive.el --- interfacing with web archives  ;;; nnwarchive.el --- interfacing with web archives
2  ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.  ;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc.
3    
4  ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>  ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
5  ;; Keywords: news egroups mail-archive  ;; Keywords: news egroups mail-archive
# Line 24  Line 24 
24  ;;; Commentary:  ;;; Commentary:
25    
26  ;; Note: You need to have `url' (w3 0.46) or greater version  ;; Note: You need to have `url' (w3 0.46) or greater version
27  ;; installed for this backend to work.  ;; installed for some functions of this backend to work.
28    
29  ;; Todo:  ;; Todo:
30  ;; 1. To support more web archives.  ;; 1. To support more web archives.
# Line 41  Line 41 
41  (require 'gnus-bcklg)  (require 'gnus-bcklg)
42  (require 'nnmail)  (require 'nnmail)
43  (require 'mm-util)  (require 'mm-util)
44  (require 'mail-source)  (require 'mm-url)
 (eval-when-compile  
   (ignore-errors  
     (require 'w3)  
     (require 'url)  
     (require 'w3-forms)  
     (require 'nnweb)))  
 ;; Report failure to find w3 at load time if appropriate.  
 (eval '(progn  
          (require 'w3)  
          (require 'url)  
          (require 'w3-forms)  
          (require 'nnweb)))  
45    
46  (nnoo-declare nnwarchive)  (nnoo-declare nnwarchive)
47    
# Line 297  Line 285 
285                   user-mail-address)))                   user-mail-address)))
286      (setq nnwarchive-passwd      (setq nnwarchive-passwd
287            (or nnwarchive-passwd            (or nnwarchive-passwd
288                (mail-source-read-passwd                (read-passwd
289                 (format "Password for %s at %s: "                 (format "Password for %s at %s: "
290                         nnwarchive-login server)))))                         nnwarchive-login server)))))
291    (unless nnwarchive-groups    (unless nnwarchive-groups
# Line 360  Line 348 
348               (format " *nnwarchive %s %s*" nnwarchive-type server)))))               (format " *nnwarchive %s %s*" nnwarchive-type server)))))
349    (nnwarchive-set-default nnwarchive-type))    (nnwarchive-set-default nnwarchive-type))
350    
 (defun nnwarchive-encode-www-form-urlencoded (pairs)  
   "Return PAIRS encoded for forms."  
   (mapconcat  
    (function  
     (lambda (data)  
       (concat (w3-form-encode-xwfu (car data)) "="  
               (w3-form-encode-xwfu (cdr data)))))  
    pairs "&"))  
   
 (defun nnwarchive-fetch-form (url pairs)  
   (let ((url-request-data (nnwarchive-encode-www-form-urlencoded pairs))  
         (url-request-method "POST")  
         (url-request-extra-headers  
          '(("Content-type" . "application/x-www-form-urlencoded"))))  
     (nnweb-insert url))  
   t)  
   
351  (defun nnwarchive-eval (expr)  (defun nnwarchive-eval (expr)
352    (cond    (cond
353     ((consp expr)     ((consp expr)
# Line 388  Line 359 
359    
360  (defun nnwarchive-url (xurl)  (defun nnwarchive-url (xurl)
361    (mm-with-unibyte-current-buffer    (mm-with-unibyte-current-buffer
362      (let ((url-confirmation-func 'identity)      (let ((url-confirmation-func 'identity) ;; Some hacks.
363            (url-cookie-multiple-line nil))            (url-cookie-multiple-line nil))
364        (cond        (cond
365         ((eq (car xurl) 'post)         ((eq (car xurl) 'post)
366          (pop xurl)          (pop xurl)
367          (nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))          (mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
368         (t         (t
369          (nnweb-insert (apply 'format (nnwarchive-eval xurl))))))))          (mm-url-insert (apply 'format (nnwarchive-eval xurl))))))))
370    
371  (defun nnwarchive-generate-active ()  (defun nnwarchive-generate-active ()
372    (save-excursion    (save-excursion
# Line 470  Line 441 
441                 article                 article
442                 (make-full-mail-header                 (make-full-mail-header
443                  article                  article
444                  (nnweb-decode-entities-string subject)                  (mm-url-decode-entities-string subject)
445                  (nnweb-decode-entities-string from)                  (mm-url-decode-entities-string from)
446                  date                  date
447                  (concat "<" group "%"                  (concat "<" group "%"
448                          (number-to-string article)                          (number-to-string article)
# Line 490  Line 461 
461    (goto-char (point-min))    (goto-char (point-min))
462    (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)    (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
463      (replace-match "\\1"))      (replace-match "\\1"))
464    (nnweb-decode-entities)    (mm-url-decode-entities)
465    (buffer-string))    (buffer-string))
466    
467  (defun nnwarchive-egroups-xover-files (group articles)  (defun nnwarchive-egroups-xover-files (group articles)
# Line 550  Line 521 
521              subject (match-string 2))              subject (match-string 2))
522        (forward-line 1)        (forward-line 1)
523        (unless (assq article nnwarchive-headers)        (unless (assq article nnwarchive-headers)
524          (if (looking-at "<UL><LI><EM>From</EM>:\\([^&]+\\)<\\([^&]+\\)>")          (if (looking-at "<UL><LI><EM>From</EM>: *\\([^<]*[^< ]\\) *&lt;\\([^&]+\\)&gt;")
525              (progn              (progn
526                (setq from (match-string 1)                (setq from (match-string 1)
527                      date (identity (match-string 2))))                      date (identity (match-string 2))))
# Line 559  Line 530 
530                 article                 article
531                 (make-full-mail-header                 (make-full-mail-header
532                  article                  article
533                  (nnweb-decode-entities-string subject)                  (mm-url-decode-entities-string subject)
534                  (nnweb-decode-entities-string from)                  (mm-url-decode-entities-string from)
535                  date                  date
536                  (format "<%05d%%%s>\n" (1- article) group)                  (format "<%05d%%%s>\n" (1- article) group)
537                  ""                  ""
# Line 623  Line 594 
594        (when (search-forward "X-Head-End" nil t)        (when (search-forward "X-Head-End" nil t)
595          (beginning-of-line)          (beginning-of-line)
596          (narrow-to-region (point-min) (point))          (narrow-to-region (point-min) (point))
597          (nnweb-decode-entities)          (mm-url-decode-entities)
598          (goto-char (point-min))          (goto-char (point-min))
599          (while (search-forward "<!--X-" nil t)          (while (search-forward "<!--X-" nil t)
600            (replace-match ""))            (replace-match ""))
# Line 645  Line 616 
616          (search-forward "</ul>" nil t)          (search-forward "</ul>" nil t)
617          (end-of-line)          (end-of-line)
618          (narrow-to-region (point-min) (point))          (narrow-to-region (point-min) (point))
619          (nnweb-remove-markup)          (mm-url-remove-markup)
620          (nnweb-decode-entities)          (mm-url-decode-entities)
621          (goto-char (point-min))          (goto-char (point-min))
622          (delete-blank-lines)          (delete-blank-lines)
623          (when from          (when from
# Line 687  Line 658 
658                  (delete-region (match-beginning 0) (match-end 0))                  (delete-region (match-beginning 0) (match-end 0))
659                  (save-restriction                  (save-restriction
660                    (narrow-to-region p (point))                    (narrow-to-region p (point))
661                    (nnweb-remove-markup)                    (mm-url-remove-markup)
662                    (nnweb-decode-entities)                    (mm-url-decode-entities)
663                    (goto-char (point-max)))))                    (goto-char (point-max)))))
664               ((looking-at "<P><A HREF=\"\\([^\"]+\\)")               ((looking-at "<P><A HREF=\"\\([^\"]+\\)")
665                (setq url (match-string 1))                (setq url (match-string 1))
# Line 696  Line 667 
667                               (progn (forward-line) (point)))                               (progn (forward-line) (point)))
668                ;; I hate to download the url encode it, then immediately                ;; I hate to download the url encode it, then immediately
669                ;; decode it.                ;; decode it.
670                ;; FixMe: Find a better solution to attach the URL.                (insert "<#external"
671                ;; Maybe do some hack in external part of mml-generate-mim-1.                        " type="
672                (insert "<#part>"                        (or (and url
673                        "\n--\nExternal: \n"                                 (string-match "\\.[^\\.]+$" url)
674                        (format "<URL:http://www.mail-archive.com/%s/%s>"                                 (mailcap-extension-to-mime
675                                    (match-string 0 url)))
676                              "application/octet-stream")
677                          (format " url=\"http://www.mail-archive.com/%s/%s\""
678                                group url)                                group url)
679                        "\n--\n"                        ">\n"
680                        "<#/part>")                        "<#/external>")
681                (setq mime t))                (setq mime t))
682               (t               (t
683                (setq p (point))                (setq p (point))

Legend:
Removed from v.1.2.2.2  
changed lines
  Added in v.1.2.2.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26