lisp/gnus/nnwarchive.el

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