From 03c8813d6ee029f5edcaa8a3af4cd739f596651a Mon Sep 17 00:00:00 2001 From: ShengHuo ZHU Date: Wed, 10 Nov 1999 19:05:58 +0000 Subject: [PATCH] Add nnwarchive backend. Document comes later. --- lisp/ChangeLog | 6 + lisp/gnus-group.el | 37 ++++ lisp/gnus.el | 1 + lisp/nnwarchive.el | 483 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 527 insertions(+) create mode 100644 lisp/nnwarchive.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b7b76c0a0..e08b21897 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +1999-11-10 13:48:10 Shenghuo ZHU + + * nnwarchive.el: New file. + * gnus-group.el (gnus-group-make-warchive-group): New function. + * gnus.el (gnus-valid-select-methods): Add `nnwarchive'. + 1999-11-10 12:13:30 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-retrieve-headers): Work for multi-page diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index bd52e1ba8..25a3f62ae 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -2100,6 +2100,43 @@ If SOLID (the prefix), create a solid group." (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) +(defvar nnwarchive-type-definition) +(defvar gnus-group-warchive-type-history nil) +(defvar gnus-group-warchive-login-history nil) +(defvar gnus-group-warchive-address-history "") + +(defun gnus-group-make-warchive-group () + "Create a nnwarchive group." + (interactive) + (require 'nnwarchive) + (let* ((group (gnus-read-group "Group name: ")) + (default-type (or (car gnus-group-warchive-type-history) + (symbol-name (caar nnwarchive-type-definition)))) + (type + (gnus-string-or + (completing-read + (format "Warchive type (default %s): " default-type) + (mapcar (lambda (elem) (list (symbol-name (car elem)))) + nnwarchive-type-definition) + nil t nil 'gnus-group-warchive-type-history) + default-type)) + (address (read-string + (format "Warchive address: " ) + nil 'gnus-group-warchive-address-history)) + (default-login (or (car gnus-group-warchive-login-history) + user-mail-address)) + (login + (gnus-string-or + (read-string + (format "Warchive login (default %s): " user-mail-address) + default-login 'gnus-group-warchive-login-history) + user-mail-address)) + (method + `(nnwarchive ,address + (nnwarchive-type ,(intern type)) + (nnwarchive-login ,login)))) + (gnus-group-make-group group method))) + (defun gnus-group-make-archive-group (&optional all) "Create the (ding) Gnus archive group of the most recent articles. Given a prefix, create a full group." diff --git a/lisp/gnus.el b/lisp/gnus.el index 22676771d..55c8d79eb 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -1235,6 +1235,7 @@ slower." ("nnweb" none) ("nnslashdot" none) ("nnultimate" none) + ("nnwarchive" none) ("nnlistserv" none) ("nnagent" post-mail) ("nnimap" post-mail address prompt-address physical-address)) diff --git a/lisp/nnwarchive.el b/lisp/nnwarchive.el new file mode 100644 index 000000000..6d647f6bf --- /dev/null +++ b/lisp/nnwarchive.el @@ -0,0 +1,483 @@ +;;; nnwarchive.el --- interfacing with web archives +;; Copyright (C) 1999 Free Software Foundation, Inc. + +;; Author: Shenghuo Zhu +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation; either version 2, or (at your +;; option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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' and `w3' installed for this backend to +;; work. + +;; A lot of codes stolen from mail-source, nnslashdot, nnweb. + +;; Todo: To support more web archives. + +;; Known bugs: in w3 0.44, there are two copies of url-maybe-relative. +;; If it is loaded from w3.el, (load-library "url"). w3 0.45 should +;; work. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'nnoo) +(require 'message) +(require 'gnus-util) +(require 'gnus) +(require 'nnmail) +(require 'mm-util) +(require 'mail-source) +(eval-when-compile + (ignore-errors + (require 'w3) + (require 'url) + (require 'w3-forms))) +;; Report failure to find w3 at load time if appropriate. +(eval '(progn + (require 'w3) + (require 'url) + (require 'w3-forms))) + +(nnoo-declare nnwarchive) + +(eval-and-compile + (defvar nnwarchive-type-definition + '((egroups + (open-url + "http://www.egroups.com/register?method=loginAction&email=%s&password=%s" + login passwd) + (open-dissect . nnwarchive-egroups-open) + (list-url + "http://www.egroups.com/UserGroupsPage?") + (list-dissect . nnwarchive-egroups-list) + (xover-url + "http://www.egroups.com/group/%s/?fetchForward=1&start=%d" group start) + (xover-last-url + "http://www.egroups.com/group/%s/?fetchForward=1" group) + (xover-page-size . 13) + (xover-dissect . nnwarchive-egroups-xover) + (article-url + "http://www.egroups.com/group/%s/%d.html?raw=1" group article) + (article-dissect . nnwarchive-egroups-article))))) + +(eval-and-compile + (defvar nnwarchive-short-names + '(login passwd))) + +(defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/") + "Where nnwarchive will save its files.") + +(eval-and-compile + (defvoo nnwarchive-type 'egroups + "The type of nnwarchive.")) + +(defvoo nnwarchive-address "egroups.com" + "The address of nnwarchive.") + +(defvoo nnwarchive-login nil + "Your login name for the group.") + +(defvoo nnwarchive-passwd nil + "Your password for the group.") + +(defvoo nnwarchive-groups nil) + +(defvoo nnwarchive-headers-cache nil) + +(defvoo nnwarchive-opened nil) + +(defconst nnwarchive-version "nnwarchive 1.0") + +;;; Internal variables + +(defvar nnwarchive-open-url nil) +(defvar nnwarchive-open-dissect nil) + +(defvar nnwarchive-list-url nil) +(defvar nnwarchive-list-dissect nil) + +(defvar nnwarchive-xover-url nil) +(defvar nnwarchive-xover-last-url nil) +(defvar nnwarchive-xover-dissect nil) +(defvar nnwarchive-xover-page-size nil) + +(defvar nnwarchive-article-url nil) +(defvar nnwarchive-article-dissect nil) + +(defvar nnwarchive-buffer nil) + +(defvar nnwarchive-headers nil) + +;;; Interface functions + +(nnoo-define-basics nnwarchive) + +(eval-and-compile + (defun nnwarchive-bind-1 () + (let ((defaults (cdr (assq nnwarchive-type nnwarchive-type-definition))) + (short-names nnwarchive-short-names) + default bind) + (while (setq default (pop defaults)) + (push (list (intern (concat "nnwarchive-" (symbol-name (car default)))) + (list 'quote (cdr default))) bind)) + (while (setq default (pop short-names)) + (push (list default + (intern (concat "nnwarchive-" + (symbol-name default)))) + bind)) + bind))) + +(defmacro nnwarchive-bind (&rest body) + "Return a `let' form that binds all variables in TYPE. +Read `mail-source-bind' for details." + `(let ,(nnwarchive-bind-1) + ,@body)) + +(put 'nnwarchive-bind 'lisp-indent-function 0) +(put 'nnwarchive-bind 'edebug-form-spec '(form body)) + +(deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old) + (nnwarchive-possibly-change-server group server) + (nnwarchive-bind + (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) + (save-excursion + (set-buffer nnwarchive-buffer) + (erase-buffer) + (let (point start starts) + (setq starts (nnwarchive-paged (sort articles '<))) + (while (setq start (pop starts)) + (goto-char (point-max)) + (nnwarchive-url nnwarchive-xover-url)) + (if nnwarchive-xover-dissect + (funcall nnwarchive-xover-dissect)))) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (header) + (dolist (art articles) + (if (setq header (assq art nnwarchive-headers)) + (nnheader-insert-nov (cdr header)))))) + (let ((elem (assoc group nnwarchive-headers-cache))) + (if elem + (setcdr elem nnwarchive-headers) + (push (cons group nnwarchive-headers) nnwarchive-headers-cache))) + 'nov)) + +(deffoo nnwarchive-request-group (group &optional server dont-check) + (nnwarchive-possibly-change-server nil server) + (let ((elem (assoc group nnwarchive-groups))) + (cond + ((not elem) + (nnheader-report 'nnwarchive "Group does not exist")) + (t + (nnheader-report 'nnwarchive "Opened group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) + (prin1-to-string group)))))) + +(deffoo nnwarchive-close-group (group &optional server) + (nnwarchive-possibly-change-server group server) + (when (gnus-buffer-live-p nnwarchive-buffer) + (save-excursion + (set-buffer nnwarchive-buffer) + (kill-buffer nnwarchive-buffer))) + t) + +(deffoo nnwarchive-request-article (article &optional group server buffer) + (nnwarchive-possibly-change-server group server) + (nnwarchive-bind + (let (contents) + (save-excursion + (set-buffer nnwarchive-buffer) + (goto-char (point-min)) + (nnwarchive-url nnwarchive-article-url) + (setq contents (funcall nnwarchive-article-dissect))) + (when contents + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (erase-buffer) + (insert contents) + (nnheader-report 'nnwarchive "Fetched article %s" article) + (cons group article)))))) + +(deffoo nnwarchive-close-server (&optional server) + (when (and (nnwarchive-server-opened server) + (gnus-buffer-live-p nnwarchive-buffer)) + (save-excursion + (set-buffer nnwarchive-buffer) + (kill-buffer nnwarchive-buffer))) + (nnoo-close-server 'nnwarchive server)) + +(deffoo nnwarchive-request-list (&optional server) + (nnwarchive-possibly-change-server nil server) + (nnwarchive-bind + (save-excursion + (set-buffer nnwarchive-buffer) + (erase-buffer) + (if nnwarchive-list-url + (nnwarchive-url nnwarchive-list-url)) + (if nnwarchive-list-dissect + (funcall nnwarchive-list-dissect)) + (nnwarchive-write-groups) + (nnwarchive-generate-active))) + t) + +(deffoo nnwarchive-request-newgroups (date &optional server) + (nnwarchive-possibly-change-server nil server) + (nnwarchive-bind + (nnwarchive-generate-active)) + t) + +(deffoo nnwarchive-asynchronous-p () + nil) + +(deffoo nnwarchive-server-opened (&optional server) + nnwarchive-opened) + +(deffoo nnwarchive-open-server (server &optional defs connectionless) + (nnwarchive-init server) + (setq nnwarchive-login + (or nnwarchive-login + (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)))) + (nnwarchive-bind + (save-excursion + (set-buffer nnwarchive-buffer) + (erase-buffer) + (if nnwarchive-open-url + (nnwarchive-url nnwarchive-open-url)) + (if nnwarchive-open-dissect + (funcall nnwarchive-open-dissect) + (setq nnwarchive-opened t)))) + t) + +(nnoo-define-skeleton nnwarchive) + +;;; Internal functions + +(defun nnwarchive-possibly-change-server (&optional group server) + (nnwarchive-init server) + (when (and server + (not (nnwarchive-server-opened server))) + (nnwarchive-open-server server))) + +(defun nnwarchive-read-groups () + (let ((file (expand-file-name (concat "groups-" nnwarchive-address) + nnwarchive-directory))) + (when (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (setq nnwarchive-groups (read (current-buffer))))))) + +(defun nnwarchive-write-groups () + (with-temp-file (expand-file-name (concat "groups-" nnwarchive-address) + nnwarchive-directory) + (prin1 nnwarchive-groups (current-buffer)))) + +(defun nnwarchive-init (server) + "Initialize buffers and such." + (unless (file-exists-p nnwarchive-directory) + (gnus-make-directory nnwarchive-directory)) + (unless (gnus-buffer-live-p nnwarchive-buffer) + (setq nnwarchive-buffer + (save-excursion + (nnheader-set-temp-buffer + (format " *nnwarchive %s %s*" nnwarchive-type server)))))) + +(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")))) + (url-insert-file-contents url) + (setq buffer-file-name t)) + t) + +(defun nnwarchive-eval (expr) + (cond + ((consp expr) + (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr)))) + ((symbolp expr) + (eval expr)) + (t + expr))) + +(defun nnwarchive-url (xurl) + (let ((url-confirmation-func 'identity)) + (cond + ((eq (car xurl) 'post) + (pop xurl) + (nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl)))) + (t + (url-insert-file-contents (apply 'format (nnwarchive-eval xurl))) + (setq buffer-file-name nil))))) + +(defun nnwarchive-decode-entities () + (goto-char (point-min)) + (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t) + (replace-match (char-to-string + (if (eq (aref (match-string 1) 0) ?\#) + (string-to-number (substring (match-string 1) 1)) + (or (cdr (assq (intern (match-string 1)) + w3-html-entities)) + ?#))) + t t))) + +(defun nnwarchive-decode-entities-string (str) + (with-temp-buffer + (insert str) + (nnwarchive-decode-entities) + (buffer-substring (point-min) (point-max)))) + +(defun nnwarchive-remove-markup () + (goto-char (point-min)) + (while (search-forward "" nil t) + (point-max)))) + (goto-char (point-min)) + (while (re-search-forward "<[^>]+>" nil t) + (replace-match "" t t))) + +(defun nnwarchive-date-to-date (sdate) + (let ((elem (split-string sdate))) + (concat (substring (nth 0 elem) 0 3) " " + (substring (nth 1 elem) 0 3) " " + (substring (nth 2 elem) 0 2) " " + (substring (nth 3 elem) 1 6) " " + (format-time-string "%Y") " " + (nth 4 elem)))) + +(defun nnwarchive-generate-active () + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (dolist (elem nnwarchive-groups) + (insert (prin1-to-string (car elem)) + " " (number-to-string (cadr elem)) " 1 y\n")))) + +(defun nnwarchive-paged (articles) + (let (art narts next) + (while (setq art (pop articles)) + (when (and (>= art (or next 0)) + (not (assq art nnwarchive-headers))) + (push art narts) + (setq next (+ art nnwarchive-xover-page-size)))) + narts)) + +;; egroups + +(defun nnwarchive-egroups-open () + (setq nnwarchive-opened t)) + +(defun nnwarchive-egroups-list () + (let ((case-fold-search t) + group description elem articles) + (goto-char (point-min)) + (while + (re-search-forward + "/group/\\([^/]+\\)/info\\.html[^>]+>[^>]+>[\040\t]*-[\040\t]*\\([^<]+\\)<" + nil t) + (setq group (match-string 1) + description (match-string 2)) + (forward-line 1) + (when (re-search-forward ">\\([0-9]+\\)<" nil t) + (setq articles (string-to-number (match-string 1)))) + (if (setq elem (assoc group nnwarchive-groups)) + (setcar (cdr elem) articles) + (push (list group articles description) nnwarchive-groups))) + (dolist (elem nnwarchive-groups) + (setq group (car elem)) + (erase-buffer) + (nnwarchive-url nnwarchive-xover-last-url) + (goto-char (point-min)) + (when (re-search-forward "of \\([0-9]+\\)" nil t) + (setq articles (string-to-number (match-string 1)))) + (setcar (cdr elem) articles) + (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) + (nnwarchive-egroups-xover) + (let ((elem (assoc group nnwarchive-headers-cache))) + (if elem + (setcdr elem nnwarchive-headers) + (push (cons group nnwarchive-headers) nnwarchive-headers-cache))))) + t) + +(defun nnwarchive-egroups-xover() + (let (article subject from date group) + (goto-char (point-min)) + (while (re-search-forward + "]+>\\([^<]+\\)<" + nil t) + (setq group (match-string 1) + article (string-to-number (match-string 2)) + subject (match-string 3)) + (forward-line 1) + (unless (assq article nnwarchive-headers) + (if (looking-at "]+>]+>\\([^<]+\\)") + (setq from (match-string 1))) + (forward-line 1) + (if (looking-at "]+>]+>\\([^<]+\\)") + (setq date (identity (match-string 1)))) + (push (cons + article + (make-full-mail-header + article + (nnwarchive-decode-entities-string subject) + (nnwarchive-decode-entities-string from) + date + (concat "<" group "%" + (number-to-string article) + "@egroup.com>") + "" + 0 nil nil nil)) nnwarchive-headers)))) + nnwarchive-headers) + +(defun nnwarchive-egroups-article () + (goto-char (point-min)) + (if (search-forward "
" nil t)
+      (delete-region (point-min) (point)))
+  (goto-char (point-max))
+  (if (search-backward "
" nil t) + (delete-region (point) (point-max))) + (goto-char (point-min)) + (while (re-search-forward "]+>\\([^<]+\\)" nil t) + (replace-match "<\\1>")) + (nnwarchive-decode-entities) + (buffer-substring (point-min) (point-max))) + +(provide 'nnwarchive) + +;;; nnwarchive.el ends here -- 2.34.1