git.chise.org Git - elisp/gnus.git-/blob - lisp/nnwarchive.el

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