cgit.sxemacs.org Git - gnus/blob - lisp/nnwarchive.el

   1 ;;; nnwarchive.el --- interfacing with web archives
   2 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published
  11 ;; by the Free Software Foundation; either version 2, or (at your
  12 ;; option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; Note: You need to have `url' and `w3' 0.46 or greater version
  27 ;; installed for this backend to work.
  28
  29 ;; A lot of codes stolen from mail-source, nnslashdot, nnweb.
  30
  31 ;; Todo:
  32 ;; 1. To support more web archives.
  33 ;; 2. Support nnwarchive-xover-is-evil.
  34 ;; 3. Generalize webmail to other MHonArc archive.
  35
  36 ;;; Code:
  37
  38 (eval-when-compile (require 'cl))
  39
  40 (require 'nnoo)
  41 (require 'message)
  42 (require 'gnus-util)
  43 (require 'gnus)
  44 (require 'nnmail)
  45 (require 'mm-util)
  46 (require 'mail-source)
  47 (eval-when-compile
  48   (ignore-errors
  49     (require 'w3)
  50     (require 'url)
  51     (require 'w3-forms)
  52     (require 'nnweb)))
  53 ;; Report failure to find w3 at load time if appropriate.
  54 (eval '(progn
  55          (require 'w3)
  56          (require 'url)
  57          (require 'w3-forms)
  58          (require 'nnweb)))
  59
  60 (nnoo-declare nnwarchive)
  61
  62 (defvar nnwarchive-type-definition
  63   '((egroups
  64      (address . "www.egroups.com")
  65      (open-url
  66       "http://www.egroups.com/register?method=loginAction&email=%s&password=%s"
  67       nnwarchive-login nnwarchive-passwd)
  68      (list-url
  69       "http://www.egroups.com/UserGroupsPage?")
  70      (list-dissect . nnwarchive-egroups-list)
  71      (list-groups . nnwarchive-egroups-list-groups)
  72      (xover-url
  73       "http://www.egroups.com/group/%s/?fetchForward=1&start=%d" group aux)
  74      (xover-last-url
  75       "http://www.egroups.com/group/%s/?fetchForward=1" group)
  76      (xover-page-size . 13)
  77      (xover-dissect . nnwarchive-egroups-xover)
  78      (article-url
  79       "http://www.egroups.com/group/%s/%d.html?raw=1" group article)
  80      (article-dissect . nnwarchive-egroups-article)
  81      (authentication . t)
  82      (xover-files . nnwarchive-egroups-xover-files))
  83     (mail-archive
  84      (address . "www.mail-archive.com")
  85      (list-url
  86       "http://www.mail-archive.com/lists.html")
  87      (list-dissect . nnwarchive-mail-archive-list)
  88      (list-groups . nnwarchive-mail-archive-list-groups)
  89      (xover-url
  90       "http://www.mail-archive.com/%s/mail%d.html" group aux)
  91      (xover-last-url
  92       "http://www.mail-archive.com/%s/maillist.html" group)
  93      (xover-dissect . nnwarchive-mail-archive-xover)
  94      (article-url
  95       "http://www.mail-archive.com/%s/msg%05d.html" group article1)
  96      (article-dissect . nnwarchive-mail-archive-article)
  97      (xover-files . nnwarchive-mail-archive-xover-files)
  98      (article-offset . 1))))
  99
 100 (defvar nnwarchive-default-type 'egroups)
 101
 102 (defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/")
 103   "Where nnwarchive will save its files.")
 104
 105 (defvoo nnwarchive-type nil
 106     "The type of nnwarchive.")
 107
 108 (defvoo nnwarchive-address ""
 109   "The address of nnwarchive.")
 110
 111 (defvoo nnwarchive-login nil
 112   "Your login name for the group.")
 113
 114 (defvoo nnwarchive-passwd nil
 115   "Your password for the group.")
 116
 117 (defvoo nnwarchive-groups nil)
 118
 119 (defvoo nnwarchive-headers-cache nil)
 120
 121 (defvoo nnwarchive-opened nil)
 122
 123 (defvoo nnwarchive-authentication nil)
 124
 125 (defvoo nnwarchive-xover-is-evil nil) ;; not implemented
 126
 127 (defconst nnwarchive-version "nnwarchive 1.0")
 128
 129 ;;; Internal variables
 130
 131 (defvoo nnwarchive-open-url nil)
 132 (defvoo nnwarchive-open-dissect nil)
 133
 134 (defvoo nnwarchive-list-url nil)
 135 (defvoo nnwarchive-list-dissect nil)
 136 (defvoo nnwarchive-list-groups nil)
 137
 138 (defvoo nnwarchive-xover-files nil)
 139 (defvoo nnwarchive-xover-url nil)
 140 (defvoo nnwarchive-xover-last-url nil)
 141 (defvoo nnwarchive-xover-dissect nil)
 142 (defvoo nnwarchive-xover-page-size nil)
 143
 144 (defvoo nnwarchive-article-url nil)
 145 (defvoo nnwarchive-article-dissect nil)
 146 (defvoo nnwarchive-xover-files nil)
 147 (defvoo nnwarchive-article-offset 0)
 148
 149 (defvoo nnwarchive-buffer nil)
 150
 151 (defvar nnwarchive-headers nil)
 152
 153
 154 ;;; Interface functions
 155
 156 (nnoo-define-basics nnwarchive)
 157
 158 (defun nnwarchive-set-default (type)
 159   (let ((defs (cdr (assq type nnwarchive-type-definition)))
 160         def)
 161     (dolist (def defs)
 162       (set (intern (concat "nnwarchive-" (symbol-name (car def))))
 163            (cdr def)))))
 164
 165 (deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old)
 166   (nnwarchive-possibly-change-server group server)
 167   (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
 168   (save-excursion
 169     (set-buffer nnwarchive-buffer)
 170     (erase-buffer)
 171     (funcall nnwarchive-xover-files group articles))
 172   (save-excursion
 173     (set-buffer nntp-server-buffer)
 174     (erase-buffer)
 175     (let (header)
 176       (dolist (art articles)
 177         (if (setq header (assq art nnwarchive-headers))
 178             (nnheader-insert-nov (cdr header))))))
 179   (let ((elem (assoc group nnwarchive-headers-cache)))
 180     (if elem
 181         (setcdr elem nnwarchive-headers)
 182       (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))
 183   'nov)
 184
 185 (deffoo nnwarchive-retrieve-groups (groups &optional server)
 186   "Retrieve group info on GROUPS."
 187   (nnwarchive-possibly-change-server nil server)
 188   (if nnwarchive-list-groups
 189       (funcall nnwarchive-list-groups groups))
 190   (nnwarchive-write-groups)
 191   (nnwarchive-generate-active)
 192   'active)
 193
 194 (deffoo nnwarchive-request-group (group &optional server dont-check)
 195   (nnwarchive-possibly-change-server nil server)
 196   (if nnwarchive-list-groups
 197       (funcall nnwarchive-list-groups (list group)))
 198   (nnwarchive-write-groups)
 199   (let ((elem (assoc group nnwarchive-groups)))
 200     (cond
 201      ((not elem)
 202       (nnheader-report 'nnwarchive "Group does not exist"))
 203      (t
 204       (nnheader-report 'nnwarchive "Opened group %s" group)
 205       (nnheader-insert
 206        "211 %d %d %d %s\n" (or (cadr elem) 0) 1 (or (cadr elem) 0)
 207        (prin1-to-string group))
 208       t))))
 209
 210 (deffoo nnwarchive-close-group (group &optional server)
 211   (nnwarchive-possibly-change-server group server)
 212   (when (gnus-buffer-live-p nnwarchive-buffer)
 213     (save-excursion
 214       (set-buffer nnwarchive-buffer)
 215       (kill-buffer nnwarchive-buffer)))
 216   t)
 217
 218 (deffoo nnwarchive-request-article (article &optional group server buffer)
 219   (nnwarchive-possibly-change-server group server)
 220   (let (contents)
 221     (save-excursion
 222       (set-buffer nnwarchive-buffer)
 223       (goto-char (point-min))
 224       (let ((article1 (- article nnwarchive-article-offset)))
 225         (nnwarchive-url nnwarchive-article-url))
 226       (setq contents (funcall nnwarchive-article-dissect group article)))
 227     (when contents
 228       (save-excursion
 229         (set-buffer (or buffer nntp-server-buffer))
 230         (erase-buffer)
 231         (insert contents)
 232         (nnheader-report 'nnwarchive "Fetched article %s" article)
 233         (cons group article)))))
 234
 235 (deffoo nnwarchive-close-server (&optional server)
 236   (when (and (nnwarchive-server-opened server)
 237              (gnus-buffer-live-p nnwarchive-buffer))
 238     (save-excursion
 239       (set-buffer nnwarchive-buffer)
 240       (kill-buffer nnwarchive-buffer)))
 241   (nnoo-close-server 'nnwarchive server))
 242
 243 (deffoo nnwarchive-request-list (&optional server)
 244   (nnwarchive-possibly-change-server nil server)
 245   (save-excursion
 246     (set-buffer nnwarchive-buffer)
 247     (erase-buffer)
 248     (if nnwarchive-list-url
 249         (nnwarchive-url nnwarchive-list-url))
 250     (if nnwarchive-list-dissect
 251         (funcall nnwarchive-list-dissect))
 252     (nnwarchive-write-groups)
 253     (nnwarchive-generate-active))
 254   'active)
 255
 256 (deffoo nnwarchive-request-newgroups (date &optional server)
 257   (nnwarchive-possibly-change-server nil server)
 258   (nnwarchive-write-groups)
 259   (nnwarchive-generate-active)
 260   'active)
 261
 262 (deffoo nnwarchive-asynchronous-p ()
 263   nil)
 264
 265 (deffoo nnwarchive-server-opened (&optional server)
 266   nnwarchive-opened)
 267
 268 (deffoo nnwarchive-open-server (server &optional defs connectionless)
 269   (nnwarchive-init server)
 270   (unless (nnwarchive-server-opened server)
 271     (when nnwarchive-authentication
 272       (setq nnwarchive-login
 273             (or nnwarchive-login
 274                 (read-string
 275                  (format "Login at %s: " server)
 276                  user-mail-address)))
 277       (setq nnwarchive-passwd
 278             (or nnwarchive-passwd
 279                 (mail-source-read-passwd
 280                  (format "Password for %s at %s: "
 281                          nnwarchive-login server)))))
 282     (unless nnwarchive-groups
 283       (nnwarchive-read-groups))
 284     (save-excursion
 285       (set-buffer nnwarchive-buffer)
 286       (erase-buffer)
 287       (if nnwarchive-open-url
 288           (nnwarchive-url nnwarchive-open-url))
 289       (if nnwarchive-open-dissect
 290           (funcall nnwarchive-open-dissect))
 291       (setq nnwarchive-opened t)))
 292   t)
 293
 294 (nnoo-define-skeleton nnwarchive)
 295
 296 ;;; Internal functions
 297
 298 (defun nnwarchive-possibly-change-server (&optional group server)
 299   (nnwarchive-init server)
 300   (when (and server
 301              (not (nnwarchive-server-opened server)))
 302     (nnwarchive-open-server server)))
 303
 304 (defun nnwarchive-read-groups ()
 305   (let ((file (expand-file-name (concat "groups-" nnwarchive-address)
 306                                 nnwarchive-directory)))
 307     (when (file-exists-p file)
 308       (with-temp-buffer
 309         (insert-file-contents file)
 310         (goto-char (point-min))
 311         (setq nnwarchive-groups (read (current-buffer)))))))
 312
 313 (defun nnwarchive-write-groups ()
 314   (with-temp-file (expand-file-name (concat "groups-" nnwarchive-address)
 315                                     nnwarchive-directory)
 316     (prin1 nnwarchive-groups (current-buffer))))
 317
 318 (defun nnwarchive-init (server)
 319   "Initialize buffers and such."
 320   (let ((type (intern server)) (defs nnwarchive-type-definition) def)
 321     (cond
 322      ((equal server "")
 323       (setq type nnwarchive-default-type))
 324      ((assq type nnwarchive-type-definition) t)
 325      (t
 326       (setq type nil)
 327       (while (setq def (pop defs))
 328         (when (equal (cdr (assq 'address (cdr def))) server)
 329           (setq defs nil)
 330           (setq type (car def))))
 331       (unless type
 332         (error "Undefined server %s" server))))
 333     (setq nnwarchive-type type))
 334   (unless (file-exists-p nnwarchive-directory)
 335     (gnus-make-directory nnwarchive-directory))
 336   (unless (gnus-buffer-live-p nnwarchive-buffer)
 337     (setq nnwarchive-buffer
 338           (save-excursion
 339             (nnheader-set-temp-buffer
 340              (format " *nnwarchive %s %s*" nnwarchive-type server)))))
 341   (nnwarchive-set-default nnwarchive-type))
 342
 343 (defun nnwarchive-encode-www-form-urlencoded (pairs)
 344   "Return PAIRS encoded for forms."
 345   (mapconcat
 346    (function
 347     (lambda (data)
 348       (concat (w3-form-encode-xwfu (car data)) "="
 349               (w3-form-encode-xwfu (cdr data)))))
 350    pairs "&"))
 351
 352 (defun nnwarchive-fetch-form (url pairs)
 353   (let ((url-request-data (nnwarchive-encode-www-form-urlencoded pairs))
 354         (url-request-method "POST")
 355         (url-request-extra-headers
 356          '(("Content-type" . "application/x-www-form-urlencoded"))))
 357     (nnweb-insert url))
 358   t)
 359
 360 (defun nnwarchive-eval (expr)
 361   (cond
 362    ((consp expr)
 363     (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr))))
 364    ((symbolp expr)
 365     (eval expr))
 366    (t
 367     expr)))
 368
 369 (defun nnwarchive-url (xurl)
 370   (let ((url-confirmation-func 'identity))
 371     (cond
 372      ((eq (car xurl) 'post)
 373       (pop xurl)
 374       (nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
 375      (t
 376       (nnweb-insert (apply 'format (nnwarchive-eval xurl)))))))
 377
 378 (defun nnwarchive-generate-active ()
 379   (save-excursion
 380     (set-buffer nntp-server-buffer)
 381     (erase-buffer)
 382     (dolist (elem nnwarchive-groups)
 383       (insert (prin1-to-string (car elem))
 384               " " (number-to-string (or (cadr elem) 0)) " 1 y\n"))))
 385
 386 (defun nnwarchive-paged (articles)
 387   (let (art narts next)
 388     (while (setq art (pop articles))
 389       (when (and (>= art (or next 0))
 390                  (not (assq art nnwarchive-headers)))
 391         (push art narts)
 392         (setq next (+ art nnwarchive-xover-page-size))))
 393     narts))
 394
 395 ;; egroups
 396
 397 (defun nnwarchive-egroups-list-groups (groups)
 398   (save-excursion
 399     (let (articles)
 400       (set-buffer nnwarchive-buffer)
 401       (dolist (group groups)
 402         (erase-buffer)
 403         (nnwarchive-url nnwarchive-xover-last-url)
 404         (goto-char (point-min))
 405         (when (re-search-forward "of \\([0-9]+\\)</title>" nil t)
 406           (setq articles (string-to-number (match-string 1))))
 407         (let ((elem (assoc group nnwarchive-groups)))
 408           (if elem
 409               (setcar (cdr elem) articles)
 410             (push (list group articles "") nnwarchive-groups)))
 411         (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
 412         (nnwarchive-egroups-xover group)
 413         (let ((elem (assoc group nnwarchive-headers-cache)))
 414           (if elem
 415               (setcdr elem nnwarchive-headers)
 416             (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))))))
 417
 418 (defun nnwarchive-egroups-list ()
 419   (let ((case-fold-search t)
 420         group description elem articles)
 421     (goto-char (point-min))
 422     (while
 423         (re-search-forward
 424          "/group/\\([^/]+\\)/info\\.html[^>]+>[^>]+>[\040\t]*-[\040\t]*\\([^<]+\\)<"
 425          nil t)
 426       (setq group (match-string 1)
 427             description (match-string 2))
 428       (forward-line 1)
 429       (when (re-search-forward ">\\([0-9]+\\)<" nil t)
 430         (setq articles (string-to-number (match-string 1))))
 431       (if (setq elem (assoc group nnwarchive-groups))
 432           (setcar (cdr elem) articles)
 433         (push (list group articles description) nnwarchive-groups))))
 434   t)
 435
 436 (defun nnwarchive-egroups-xover (group)
 437   (let (article subject from date)
 438     (goto-char (point-min))
 439     (while (re-search-forward
 440             "<a href=\"/group/\\([^/]+\\)/\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
 441             nil t)
 442       (setq group  (match-string 1)
 443             article (string-to-number (match-string 2))
 444             subject (match-string 3))
 445       (forward-line 1)
 446       (unless (assq article nnwarchive-headers)
 447         (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
 448             (setq from (match-string 1)))
 449         (forward-line 1)
 450         (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
 451             (setq date (identity (match-string 1))))
 452         (push (cons
 453                article
 454                (make-full-mail-header
 455                 article
 456                 (nnweb-decode-entities-string subject)
 457                 (nnweb-decode-entities-string from)
 458                 date
 459                 (concat "<" group "%"
 460                         (number-to-string article)
 461                         "@egroup.com>")
 462                 ""
 463                 0 0 "")) nnwarchive-headers))))
 464   nnwarchive-headers)
 465
 466 (defun nnwarchive-egroups-article (group articles)
 467   (goto-char (point-min))
 468   (if (search-forward "<pre>" nil t)
 469       (delete-region (point-min) (point)))
 470   (goto-char (point-max))
 471   (if (search-backward "</pre>" nil t)
 472       (delete-region (point) (point-max)))
 473   (goto-char (point-min))
 474   (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
 475     (replace-match "<\\1>"))
 476   (nnweb-decode-entities)
 477   (buffer-string))
 478
 479 (defun nnwarchive-egroups-xover-files (group articles)
 480   (let (aux auxs)
 481     (setq auxs (nnwarchive-paged (sort articles '<)))
 482     (while (setq aux (pop auxs))
 483       (goto-char (point-max))
 484       (nnwarchive-url nnwarchive-xover-url))
 485     (if nnwarchive-xover-dissect
 486         (nnwarchive-egroups-xover group))))
 487
 488 ;; mail-archive
 489
 490 (defun nnwarchive-mail-archive-list-groups (groups)
 491   (save-excursion
 492     (let (articles)
 493       (set-buffer nnwarchive-buffer)
 494       (dolist (group groups)
 495         (erase-buffer)
 496         (nnwarchive-url nnwarchive-xover-last-url)
 497         (goto-char (point-min))
 498         (when (re-search-forward "msg\\([0-9]+\\)\\.html" nil t)
 499           (setq articles (1+ (string-to-number (match-string 1)))))
 500         (let ((elem (assoc group nnwarchive-groups)))
 501           (if elem
 502               (setcar (cdr elem) articles)
 503             (push (list group articles "") nnwarchive-groups)))
 504         (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
 505         (nnwarchive-mail-archive-xover group)
 506         (let ((elem (assoc group nnwarchive-headers-cache)))
 507           (if elem
 508               (setcdr elem nnwarchive-headers)
 509             (push (cons group nnwarchive-headers)
 510                   nnwarchive-headers-cache)))))))
 511
 512 (defun nnwarchive-mail-archive-list ()
 513   (let ((case-fold-search t)
 514         group description elem articles)
 515     (goto-char (point-min))
 516     (while (re-search-forward "<a href=\"\\([^/]+\\)/\">\\([^>]+\\)<" nil t)
 517       (setq group (match-string 1)
 518             description (match-string 2))
 519       (forward-line 1)
 520       (setq articles 0)
 521       (if (setq elem (assoc group nnwarchive-groups))
 522           (setcar (cdr elem) articles)
 523         (push (list group articles description) nnwarchive-groups))))
 524   t)
 525
 526 (defun nnwarchive-mail-archive-xover (group)
 527   (let (article subject from date)
 528     (goto-char (point-min))
 529     (while (re-search-forward
 530             "<A[^>]*HREF=\"msg\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
 531             nil t)
 532       (setq article (1+ (string-to-number (match-string 1)))
 533             subject (match-string 2))
 534       (forward-line 1)
 535       (unless (assq article nnwarchive-headers)
 536         (if (looking-at "<UL><LI><EM>From</EM>:\\([^&]+\\)<\\([^&]+\\)>")
 537             (progn
 538               (setq from (match-string 1)
 539                     date (identity (match-string 2))))
 540           (setq from "" date ""))
 541         (push (cons
 542                article
 543                (make-full-mail-header
 544                 article
 545                 (nnweb-decode-entities-string subject)
 546                 (nnweb-decode-entities-string from)
 547                 date
 548                 (format "<%05d%%%s>\n" (1- article) group)
 549                 ""
 550                 0 0 "")) nnwarchive-headers))))
 551   nnwarchive-headers)
 552
 553 (defun nnwarchive-mail-archive-xover-files (group articles)
 554   (unless nnwarchive-headers
 555     (erase-buffer)
 556     (nnwarchive-url nnwarchive-xover-last-url)
 557     (goto-char (point-min))
 558     (nnwarchive-mail-archive-xover group))
 559   (let ((minart (apply 'min articles))
 560         (min (apply 'min (mapcar 'car nnwarchive-headers)))
 561         (aux 2))
 562     (while (> min minart)
 563       (erase-buffer)
 564       (nnwarchive-url nnwarchive-xover-url)
 565       (nnwarchive-mail-archive-xover group)
 566       (setq min (apply 'min (mapcar 'car nnwarchive-headers))))))
 567
 568 (defvar nnwarchive-caesar-translation-table nil
 569   "Modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/.")
 570
 571 (defun nnwarchive-make-caesar-translation-table ()
 572   "Create modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/."
 573   (let ((i -1)
 574         (table (make-string 256 0))
 575         (a (mm-char-int ?a))
 576         (A (mm-char-int ?A)))
 577     (while (< (incf i) 256)
 578       (aset table i i))
 579     (concat
 580      (substring table 0 (1- A))
 581      (substring table (+ A 13) (+ A 27))
 582      (substring table (1- A) (+ A 13))
 583      (substring table (+ A 27) a)
 584      (substring table (+ a 13) (+ a 26))
 585      (substring table a (+ a 13))
 586      (substring table (+ a 26) 255))))
 587
 588 (defun nnwarchive-from-r13 (from-r13)
 589   (when from-r13
 590     (with-temp-buffer
 591       (insert from-r13)
 592       (let ((message-caesar-translation-table
 593              (or nnwarchive-caesar-translation-table
 594                  (setq nnwarchive-caesar-translation-table
 595                        (nnwarchive-make-caesar-translation-table)))))
 596         (message-caesar-region (point-min) (point-max))
 597         (buffer-string)))))
 598
 599 (defun nnwarchive-mail-archive-article (group article)
 600   (let (p refs url mime e
 601           from subject date id
 602           done
 603           (case-fold-serch t))
 604     (save-restriction
 605       (goto-char (point-min))
 606       (when (search-forward "X-Head-End" nil t)
 607         (beginning-of-line)
 608         (narrow-to-region (point-min) (point))
 609         (nnweb-decode-entities)
 610         (goto-char (point-min))
 611         (while (search-forward "<!--X-" nil t)
 612           (replace-match ""))
 613         (goto-char (point-min))
 614         (while (search-forward " -->" nil t)
 615           (replace-match ""))
 616         (setq from
 617               (or (mail-fetch-field "from")
 618                   (nnwarchive-from-r13
 619                    (mail-fetch-field "from-r13"))))
 620         (setq date (mail-fetch-field "date"))
 621         (setq id (mail-fetch-field "message-id"))
 622         (setq subject (mail-fetch-field "subject"))
 623         (goto-char (point-max))
 624         (widen))
 625       (when (search-forward "<ul>" nil t)
 626         (forward-line)
 627         (delete-region (point-min) (point))
 628         (search-forward "</ul>" nil t)
 629         (end-of-line)
 630         (narrow-to-region (point-min) (point))
 631         (nnweb-remove-markup)
 632         (nnweb-decode-entities)
 633         (goto-char (point-min))
 634         (delete-blank-lines)
 635         (when from
 636           (message-remove-header "from")
 637           (goto-char (point-max))
 638           (insert "From: " from "\n"))
 639         (when subject
 640           (message-remove-header "subject")
 641           (goto-char (point-max))
 642           (insert "Subject: " subject "\n"))
 643         (when id
 644           (goto-char (point-max))
 645           (insert "X-Message-ID: <" id ">\n"))
 646         (when date
 647           (message-remove-header "date")
 648           (goto-char (point-max))
 649           (insert "Date: " date "\n"))
 650         (goto-char (point-max))
 651         (widen)
 652         (insert "\n"))
 653       (setq p (point))
 654       (when (search-forward "X-Body-of-Message" nil t)
 655         (forward-line)
 656         (delete-region p (point))
 657         (search-forward "X-Body-of-Message-End" nil t)
 658         (beginning-of-line)
 659         (save-restriction
 660           (narrow-to-region p (point))
 661           (goto-char (point-min))
 662           (if (> (skip-chars-forward "\040\n\r\t") 0)
 663               (delete-region (point-min) (point)))
 664           (while (not (eobp))
 665             (cond
 666              ((looking-at "<PRE>\r?\n?")
 667               (delete-region (match-beginning 0) (match-end 0))
 668               (setq p (point))
 669               (when (search-forward "</PRE>" nil t)
 670                 (delete-region (match-beginning 0) (match-end 0))
 671                 (save-restriction
 672                   (narrow-to-region p (point))
 673                   (nnweb-remove-markup)
 674                   (nnweb-decode-entities)
 675                   (goto-char (point-max)))))
 676              ((looking-at "<P><A HREF=\"\\([^\"]+\\)")
 677               (setq url (match-string 1))
 678               (delete-region (match-beginning 0)
 679                              (progn (forward-line) (point)))
 680               ;; I hate to download the url encode it, then immediately
 681               ;; decode it.
 682               ;; FixMe: Find a better solution to attach the URL.
 683               ;; Maybe do some hack in external part of mml-generate-mim-1.
 684               (insert "<#part>"
 685                       "\n--\nExternal: \n"
 686                       (format "<URL:http://www.mail-archive.com/%s/%s>"
 687                               group url)
 688                       "\n--\n"
 689                       "<#/part>")
 690               (setq mime t))
 691              (t
 692               (setq p (point))
 693               (insert "<#part type=\"text/html\" disposition=inline>")
 694               (goto-char
 695                (if (re-search-forward
 696                     "[\040\n\r\t]*<PRE>\\|[\040\n\r\t]*<P><A HREF=\""
 697                     nil t)
 698                    (match-beginning 0)
 699                  (point-max)))
 700               (insert "<#/part>")
 701               (setq mime t)))
 702             (setq p (point))
 703             (if (> (skip-chars-forward "\040\n\r\t") 0)
 704                 (delete-region p (point))))
 705           (goto-char (point-max))))
 706       (setq p (point))
 707       (when (search-forward "X-References-End" nil t)
 708         (setq e (point))
 709         (beginning-of-line)
 710         (search-backward "X-References" p t)
 711         (while (re-search-forward "msg\\([0-9]+\\)\\.html" e t)
 712           (push (concat "<" (match-string 1) "%" group ">") refs)))
 713       (delete-region p (point-max))
 714       (goto-char (point-min))
 715       (insert (format "Message-ID: <%05d%%%s>\n" (1- article) group))
 716       (when refs
 717         (insert "References:")
 718         (while refs
 719           (insert " " (pop refs)))
 720         (insert "\n"))
 721       (when mime
 722         (unless (looking-at "$")
 723           (search-forward "\n\n" nil t)
 724           (forward-line -1))
 725         (narrow-to-region (point) (point-max))
 726         (insert "MIME-Version: 1.0\n"
 727                 (prog1
 728                     (mml-generate-mime)
 729                   (delete-region (point-min) (point-max))))
 730         (widen)))
 731     (buffer-string)))
 732
 733 (provide 'nnwarchive)
 734
 735 ;;; nnwarchive.el ends here