comparison lisp/gnus/nnwarchive.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

;;; nnwarchive.el --- interfacing with web archives
;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.

;; Author: Shenghuo Zhu <[e-mail]>
;; Keywords: news egroups mail-archive

;; This file is part of GNU Emacs.

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Note: You need to have `url' (w3 0.46) or greater version
;; installed for this backend to work.

;; Todo:
;; 1. To support more web archives.
;; 2. Generalize webmail to other MHonArc archive.

(require 'gnus-util)
(require 'gnus)
(require 'gnus-bcklg)
(require 'nnmail)
(require 'mm-util)
(require 'mail-source)
(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)))

(nnoo-declare nnwarchive)

(defvar nnwarchive-type-definition
  '((egroups

	      (read-string
		 (format "Login at %s: " server)
		 user-mail-address)))
    (setq nnwarchive-passwd
	  (or nnwarchive-passwd
	      (mail-source-read-passwd
	       (format "Password for %s at %s: "
		       nnwarchive-login server)))))
  (unless nnwarchive-groups
    (nnwarchive-read-groups))
  (save-excursion

	  (save-excursion
	    (nnheader-set-temp-buffer
	     (format " *nnwarchive %s %s*" nnwarchive-type server)))))
  (nnwarchive-set-default nnwarchive-type))

(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)

(defun nnwarchive-eval (expr)
  (cond
   ((consp expr)
    (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr))))
   ((symbolp expr)

   (t
    expr)))

(defun nnwarchive-url (xurl)
  (mm-with-unibyte-current-buffer
    (let ((url-confirmation-func 'identity)
	  (url-cookie-multiple-line nil))
      (cond
       ((eq (car xurl) 'post)
	(pop xurl)
	(nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
       (t
	(nnweb-insert (apply 'format (nnwarchive-eval xurl))))))))

(defun nnwarchive-generate-active ()
  (save-excursion
    (set-buffer nntp-server-buffer)
    (erase-buffer)

	    (setq date (identity (match-string 1))))
	(push (cons
	       article
	       (make-full-mail-header
		article
		(nnweb-decode-entities-string subject)
		(nnweb-decode-entities-string from)
		date
		(concat "<" group "%"
			(number-to-string article)
			"@egroup.com>")
		""

  (if (search-backward "</pre>" nil t)
      (delete-region (point) (point-max)))
  (goto-char (point-min))
  (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
    (replace-match "\\1"))
  (nnweb-decode-entities)
  (buffer-string))

(defun nnwarchive-egroups-xover-files (group articles)
  (let (aux auxs)
    (setq auxs (nnwarchive-paged (sort articles '<)))

	    nil t)
      (setq article (1+ (string-to-number (match-string 1)))
	    subject (match-string 2))
      (forward-line 1)
      (unless (assq article nnwarchive-headers)
	(if (looking-at "<UL><LI><EM>From</EM>:\\([^&]+\\)<\\([^&]+\\)>")
	    (progn
	      (setq from (match-string 1)
		    date (identity (match-string 2))))
	  (setq from "" date ""))
	(push (cons
	       article
	       (make-full-mail-header
		article
		(nnweb-decode-entities-string subject)
		(nnweb-decode-entities-string from)
		date
		(format "<%05d%%%s>\n" (1- article) group)
		""
		0 0 "")) nnwarchive-headers))))
  nnwarchive-headers)

    (save-restriction
      (goto-char (point-min))
      (when (search-forward "X-Head-End" nil t)
	(beginning-of-line)
	(narrow-to-region (point-min) (point))
	(nnweb-decode-entities)
	(goto-char (point-min))
	(while (search-forward "<!--X-" nil t)
	  (replace-match ""))
	(goto-char (point-min))
	(while (search-forward " -->" nil t)

	(forward-line)
	(delete-region (point-min) (point))
	(search-forward "</ul>" nil t)
	(end-of-line)
	(narrow-to-region (point-min) (point))
	(nnweb-remove-markup)
	(nnweb-decode-entities)
	(goto-char (point-min))
	(delete-blank-lines)
	(when from
	  (message-remove-header "from")
	  (goto-char (point-max))

	      (setq p (point))
	      (when (search-forward "</PRE>" nil t)
		(delete-region (match-beginning 0) (match-end 0))
		(save-restriction
		  (narrow-to-region p (point))
		  (nnweb-remove-markup)
		  (nnweb-decode-entities)
		  (goto-char (point-max)))))
	     ((looking-at "<P><A HREF=\"\\([^\"]+\\)")
	      (setq url (match-string 1))
	      (delete-region (match-beginning 0)
			     (progn (forward-line) (point)))
	      ;; I hate to download the url encode it, then immediately
	      ;; decode it.
	      ;; FixMe: Find a better solution to attach the URL.
	      ;; Maybe do some hack in external part of mml-generate-mim-1.
	      (insert "<#part>"
		      "\n--\nExternal: \n"
		      (format "<URL:http://www.mail-archive.com/%s/%s>"
			      group url)
		      "\n--\n"
		      "<#/part>")
	      (setq mime t))
	     (t
	      (setq p (point))
	      (insert "<#part type=\"text/html\" disposition=inline>")
	      (goto-char

	(widen)))
    (buffer-string)))

(provide 'nnwarchive)

;;; nnwarchive.el ends here

88155:d7ddb3e565de

;;; nnwarchive.el --- interfacing with web archives

;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
;;   2005 Free Software Foundation, Inc.

;; Author: Shenghuo Zhu <[e-mail]>
;; Keywords: news egroups mail-archive

;; This file is part of GNU Emacs.

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Note: You need to have `url' (w3 0.46) or greater version
;; installed for some functions of this backend to work.

;; Todo:
;; 1. To support more web archives.
;; 2. Generalize webmail to other MHonArc archive.

(require 'gnus-util)
(require 'gnus)
(require 'gnus-bcklg)
(require 'nnmail)
(require 'mm-util)
(require 'mm-url)

(nnoo-declare nnwarchive)

(defvar nnwarchive-type-definition
  '((egroups

	      (read-string
		 (format "Login at %s: " server)
		 user-mail-address)))
    (setq nnwarchive-passwd
	  (or nnwarchive-passwd
	      (read-passwd
	       (format "Password for %s at %s: "
		       nnwarchive-login server)))))
  (unless nnwarchive-groups
    (nnwarchive-read-groups))
  (save-excursion

	  (save-excursion
	    (nnheader-set-temp-buffer
	     (format " *nnwarchive %s %s*" nnwarchive-type server)))))
  (nnwarchive-set-default nnwarchive-type))

(defun nnwarchive-eval (expr)
  (cond
   ((consp expr)
    (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr))))
   ((symbolp expr)

   (t
    expr)))

(defun nnwarchive-url (xurl)
  (mm-with-unibyte-current-buffer
    (let ((url-confirmation-func 'identity) ;; Some hacks.
	  (url-cookie-multiple-line nil))
      (cond
       ((eq (car xurl) 'post)
	(pop xurl)
	(mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
       (t
	(mm-url-insert (apply 'format (nnwarchive-eval xurl))))))))

(defun nnwarchive-generate-active ()
  (save-excursion
    (set-buffer nntp-server-buffer)
    (erase-buffer)

	    (setq date (identity (match-string 1))))
	(push (cons
	       article
	       (make-full-mail-header
		article
		(mm-url-decode-entities-string subject)
		(mm-url-decode-entities-string from)
		date
		(concat "<" group "%"
			(number-to-string article)
			"@egroup.com>")
		""

  (if (search-backward "</pre>" nil t)
      (delete-region (point) (point-max)))
  (goto-char (point-min))
  (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
    (replace-match "\\1"))
  (mm-url-decode-entities)
  (buffer-string))

(defun nnwarchive-egroups-xover-files (group articles)
  (let (aux auxs)
    (setq auxs (nnwarchive-paged (sort articles '<)))

	    nil t)
      (setq article (1+ (string-to-number (match-string 1)))
	    subject (match-string 2))
      (forward-line 1)
      (unless (assq article nnwarchive-headers)
	(if (looking-at "<UL><LI><EM>From</EM>: *\\([^<]*[^< ]\\) *&lt;\\([^&]+\\)&gt;")
	    (progn
	      (setq from (match-string 1)
		    date (identity (match-string 2))))
	  (setq from "" date ""))
	(push (cons
	       article
	       (make-full-mail-header
		article
		(mm-url-decode-entities-string subject)
		(mm-url-decode-entities-string from)
		date
		(format "<%05d%%%s>\n" (1- article) group)
		""
		0 0 "")) nnwarchive-headers))))
  nnwarchive-headers)

    (save-restriction
      (goto-char (point-min))
      (when (search-forward "X-Head-End" nil t)
	(beginning-of-line)
	(narrow-to-region (point-min) (point))
	(mm-url-decode-entities)
	(goto-char (point-min))
	(while (search-forward "<!--X-" nil t)
	  (replace-match ""))
	(goto-char (point-min))
	(while (search-forward " -->" nil t)

	(forward-line)
	(delete-region (point-min) (point))
	(search-forward "</ul>" nil t)
	(end-of-line)
	(narrow-to-region (point-min) (point))
	(mm-url-remove-markup)
	(mm-url-decode-entities)
	(goto-char (point-min))
	(delete-blank-lines)
	(when from
	  (message-remove-header "from")
	  (goto-char (point-max))

	      (setq p (point))
	      (when (search-forward "</PRE>" nil t)
		(delete-region (match-beginning 0) (match-end 0))
		(save-restriction
		  (narrow-to-region p (point))
		  (mm-url-remove-markup)
		  (mm-url-decode-entities)
		  (goto-char (point-max)))))
	     ((looking-at "<P><A HREF=\"\\([^\"]+\\)")
	      (setq url (match-string 1))
	      (delete-region (match-beginning 0)
			     (progn (forward-line) (point)))
	      ;; I hate to download the url encode it, then immediately
	      ;; decode it.
	      (insert "<#external"
		      " type="
		      (or (and url
			       (string-match "\\.[^\\.]+$" url)
			       (mailcap-extension-to-mime
				(match-string 0 url)))
			  "application/octet-stream")
		      (format " url=\"http://www.mail-archive.com/%s/%s\""
			      group url)
		      ">\n"
		      "<#/external>")
	      (setq mime t))
	     (t
	      (setq p (point))
	      (insert "<#part type=\"text/html\" disposition=inline>")
	      (goto-char

	(widen)))
    (buffer-string)))

(provide 'nnwarchive)

;;; arch-tag: 1ab7a15c-777a-40e0-95c0-0c41b3963578
;;; nnwarchive.el ends here