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

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