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-decode-entities ()
 379   (goto-char (point-min))
 380   (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t)
 381     (replace-match (char-to-string
 382                     (if (eq (aref (match-string 1) 0) ?\#)
 383                         (string-to-number (substring (match-string 1) 1))
 384                       (or (cdr (assq (intern (match-string 1))
 385                                      w3-html-entities))
 386                           ?#)))
 387                    t t)))
 388
 389 (defun nnwarchive-decode-entities-string (str)
 390   (with-temp-buffer
 391     (insert str)
 392     (nnwarchive-decode-entities)
 393     (buffer-substring (point-min) (point-max))))
 394
 395 (defun nnwarchive-remove-markup ()
 396   (goto-char (point-min))
 397   (while (search-forward "<!--" nil t)
 398     (delete-region (match-beginning 0)
 399                    (or (search-forward "-->" nil t)
 400                        (point-max))))
 401   (goto-char (point-min))
 402   (while (re-search-forward "<[^>]+>" nil t)
 403     (replace-match "" t t)))
 404
 405 (defun nnwarchive-date-to-date (sdate)
 406   (let ((elem (split-string sdate)))
 407     (concat (substring (nth 0 elem) 0 3) " "
 408             (substring (nth 1 elem) 0 3) " "
 409             (substring (nth 2 elem) 0 2) " "
 410             (substring (nth 3 elem) 1 6) " "
 411             (format-time-string "%Y") " "
 412             (nth 4 elem))))
 413
 414 (defun nnwarchive-generate-active ()
 415   (save-excursion
 416     (set-buffer nntp-server-buffer)
 417     (erase-buffer)
 418     (dolist (elem nnwarchive-groups)
 419       (insert (prin1-to-string (car elem))
 420               " " (number-to-string (or (cadr elem) 0)) " 1 y\n"))))
 421
 422 (defun nnwarchive-paged (articles)
 423   (let (art narts next)
 424     (while (setq art (pop articles))
 425       (when (and (>= art (or next 0))
 426                  (not (assq art nnwarchive-headers)))
 427         (push art narts)
 428         (setq next (+ art nnwarchive-xover-page-size))))
 429     narts))
 430
 431 ;; egroups
 432
 433 (defun nnwarchive-egroups-list-groups (groups)
 434   (save-excursion
 435     (let (articles)
 436       (set-buffer nnwarchive-buffer)
 437       (dolist (group groups)
 438         (erase-buffer)
 439         (nnwarchive-url nnwarchive-xover-last-url)
 440         (goto-char (point-min))
 441         (when (re-search-forward "of \\([0-9]+\\)</title>" nil t)
 442           (setq articles (string-to-number (match-string 1))))
 443         (let ((elem (assoc group nnwarchive-groups)))
 444           (if elem
 445               (setcar (cdr elem) articles)
 446             (push (list group articles "") nnwarchive-groups)))
 447         (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
 448         (nnwarchive-egroups-xover group)
 449         (let ((elem (assoc group nnwarchive-headers-cache)))
 450           (if elem
 451               (setcdr elem nnwarchive-headers)
 452             (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))))))
 453
 454 (defun nnwarchive-egroups-list ()
 455   (let ((case-fold-search t)
 456         group description elem articles)
 457     (goto-char (point-min))
 458     (while
 459         (re-search-forward
 460          "/group/\\([^/]+\\)/info\\.html[^>]+>[^>]+>[\040\t]*-[\040\t]*\\([^<]+\\)<"
 461          nil t)
 462       (setq group (match-string 1)
 463             description (match-string 2))
 464       (forward-line 1)
 465       (when (re-search-forward ">\\([0-9]+\\)<" nil t)
 466         (setq articles (string-to-number (match-string 1))))
 467       (if (setq elem (assoc group nnwarchive-groups))
 468           (setcar (cdr elem) articles)
 469         (push (list group articles description) nnwarchive-groups))))
 470   t)
 471
 472 (defun nnwarchive-egroups-xover (group)
 473   (let (article subject from date)
 474     (goto-char (point-min))
 475     (while (re-search-forward
 476             "<a href=\"/group/\\([^/]+\\)/\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
 477             nil t)
 478       (setq group  (match-string 1)
 479             article (string-to-number (match-string 2))
 480             subject (match-string 3))
 481       (forward-line 1)
 482       (unless (assq article nnwarchive-headers)
 483         (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
 484             (setq from (match-string 1)))
 485         (forward-line 1)
 486         (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
 487             (setq date (identity (match-string 1))))
 488         (push (cons
 489                article
 490                (make-full-mail-header
 491                 article
 492                 (nnwarchive-decode-entities-string subject)
 493                 (nnwarchive-decode-entities-string from)
 494                 date
 495                 (concat "<" group "%"
 496                         (number-to-string article)
 497                         "@egroup.com>")
 498                 ""
 499                 0 0 "")) nnwarchive-headers))))
 500   nnwarchive-headers)
 501
 502 (defun nnwarchive-egroups-article (group articles)
 503   (goto-char (point-min))
 504   (if (search-forward "<pre>" nil t)
 505       (delete-region (point-min) (point)))
 506   (goto-char (point-max))
 507   (if (search-backward "</pre>" nil t)
 508       (delete-region (point) (point-max)))
 509   (goto-char (point-min))
 510   (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
 511     (replace-match "<\\1>"))
 512   (nnwarchive-decode-entities)
 513   (buffer-string))
 514
 515 (defun nnwarchive-egroups-xover-files (group articles)
 516   (let (aux auxs)
 517     (setq auxs (nnwarchive-paged (sort articles '<)))
 518     (while (setq aux (pop auxs))
 519       (goto-char (point-max))
 520       (nnwarchive-url nnwarchive-xover-url))
 521     (if nnwarchive-xover-dissect
 522         (nnwarchive-egroups-xover group))))
 523
 524 ;; mail-archive
 525
 526 (defun nnwarchive-mail-archive-list-groups (groups)
 527   (save-excursion
 528     (let (articles)
 529       (set-buffer nnwarchive-buffer)
 530       (dolist (group groups)
 531         (erase-buffer)
 532         (nnwarchive-url nnwarchive-xover-last-url)
 533         (goto-char (point-min))
 534         (when (re-search-forward "msg\\([0-9]+\\)\\.html" nil t)
 535           (setq articles (1+ (string-to-number (match-string 1)))))
 536         (let ((elem (assoc group nnwarchive-groups)))
 537           (if elem
 538               (setcar (cdr elem) articles)
 539             (push (list group articles "") nnwarchive-groups)))
 540         (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
 541         (nnwarchive-mail-archive-xover group)
 542         (let ((elem (assoc group nnwarchive-headers-cache)))
 543           (if elem
 544               (setcdr elem nnwarchive-headers)
 545             (push (cons group nnwarchive-headers)
 546                   nnwarchive-headers-cache)))))))
 547
 548 (defun nnwarchive-mail-archive-list ()
 549   (let ((case-fold-search t)
 550         group description elem articles)
 551     (goto-char (point-min))
 552     (while (re-search-forward "<a href=\"\\([^/]+\\)/\">\\([^>]+\\)<" nil t)
 553       (setq group (match-string 1)
 554             description (match-string 2))
 555       (forward-line 1)
 556       (setq articles 0)
 557       (if (setq elem (assoc group nnwarchive-groups))
 558           (setcar (cdr elem) articles)
 559         (push (list group articles description) nnwarchive-groups))))
 560   t)
 561
 562 (defun nnwarchive-mail-archive-xover (group)
 563   (let (article subject from date)
 564     (goto-char (point-min))
 565     (while (re-search-forward
 566             "<A[^>]*HREF=\"msg\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
 567             nil t)
 568       (setq article (1+ (string-to-number (match-string 1)))
 569             subject (match-string 2))
 570       (forward-line 1)
 571       (unless (assq article nnwarchive-headers)
 572         (if (looking-at "<UL><LI><EM>From</EM>:\\([^&]+\\)<\\([^&]+\\)>")
 573             (progn
 574               (setq from (match-string 1)
 575                     date (identity (match-string 2))))
 576           (setq from "" date ""))
 577         (push (cons
 578                article
 579                (make-full-mail-header
 580                 article
 581                 (nnwarchive-decode-entities-string subject)
 582                 (nnwarchive-decode-entities-string from)
 583                 date
 584                 (format "<%05d%%%s>\n" (1- article) group)
 585                 ""
 586                 0 0 "")) nnwarchive-headers))))
 587   nnwarchive-headers)
 588
 589 (defun nnwarchive-mail-archive-xover-files (group articles)
 590   (unless nnwarchive-headers
 591     (erase-buffer)
 592     (nnwarchive-url nnwarchive-xover-last-url)
 593     (goto-char (point-min))
 594     (nnwarchive-mail-archive-xover group))
 595   (let ((minart (apply 'min articles))
 596         (min (apply 'min (mapcar 'car nnwarchive-headers)))
 597         (aux 2))
 598     (while (> min minart)
 599       (erase-buffer)
 600       (nnwarchive-url nnwarchive-xover-url)
 601       (nnwarchive-mail-archive-xover group)
 602       (setq min (apply 'min (mapcar 'car nnwarchive-headers))))))
 603
 604 (defvar nnwarchive-caesar-translation-table nil
 605   "Modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/.")
 606
 607 (defun nnwarchive-make-caesar-translation-table ()
 608   "Create modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/."
 609   (let ((i -1)
 610         (table (make-string 256 0))
 611         (a (mm-char-int ?a))
 612         (A (mm-char-int ?A)))
 613     (while (< (incf i) 256)
 614       (aset table i i))
 615     (concat
 616      (substring table 0 (1- A))
 617      (substring table (+ A 13) (+ A 27))
 618      (substring table (1- A) (+ A 13))
 619      (substring table (+ A 27) a)
 620      (substring table (+ a 13) (+ a 26))
 621      (substring table a (+ a 13))
 622      (substring table (+ a 26) 255))))
 623
 624 (defun nnwarchive-from-r13 (from-r13)
 625   (when from-r13
 626     (with-temp-buffer
 627       (insert from-r13)
 628       (let ((message-caesar-translation-table
 629              (or nnwarchive-caesar-translation-table
 630                  (setq nnwarchive-caesar-translation-table
 631                        (nnwarchive-make-caesar-translation-table)))))
 632         (message-caesar-region (point-min) (point-max))
 633         (buffer-string)))))
 634
 635 (defun nnwarchive-mail-archive-article (group article)
 636   (let (p refs url mime e
 637           from subject date id
 638           done
 639           (case-fold-serch t))
 640     (save-restriction
 641       (goto-char (point-min))
 642       (when (search-forward "X-Head-End" nil t)
 643         (beginning-of-line)
 644         (narrow-to-region (point-min) (point))
 645         (nnwarchive-decode-entities)
 646         (goto-char (point-min))
 647         (while (search-forward "<!--X-" nil t)
 648           (replace-match ""))
 649         (goto-char (point-min))
 650         (while (search-forward " -->" nil t)
 651           (replace-match ""))
 652         (setq from
 653               (or (mail-fetch-field "from")
 654                   (nnwarchive-from-r13
 655                    (mail-fetch-field "from-r13"))))
 656         (setq date (mail-fetch-field "date"))
 657         (setq id (mail-fetch-field "message-id"))
 658         (setq subject (mail-fetch-field "subject"))
 659         (goto-char (point-max))
 660         (widen))
 661       (when (search-forward "<ul>" nil t)
 662         (forward-line)
 663         (delete-region (point-min) (point))
 664         (search-forward "</ul>" nil t)
 665         (end-of-line)
 666         (narrow-to-region (point-min) (point))
 667         (nnwarchive-remove-markup)
 668         (nnwarchive-decode-entities)
 669         (goto-char (point-min))
 670         (delete-blank-lines)
 671         (when from
 672           (message-remove-header "from")
 673           (goto-char (point-max))
 674           (insert "From: " from "\n"))
 675         (when subject
 676           (message-remove-header "subject")
 677           (goto-char (point-max))
 678           (insert "Subject: " subject "\n"))
 679         (when id
 680           (goto-char (point-max))
 681           (insert "X-Message-ID: <" id ">\n"))
 682         (when date
 683           (message-remove-header "date")
 684           (goto-char (point-max))
 685           (insert "Date: " date "\n"))
 686         (goto-char (point-max))
 687         (widen)
 688         (insert "\n"))
 689       (setq p (point))
 690       (when (search-forward "X-Body-of-Message" nil t)
 691         (forward-line)
 692         (delete-region p (point))
 693         (search-forward "X-Body-of-Message-End" nil t)
 694         (beginning-of-line)
 695         (save-restriction
 696           (narrow-to-region p (point))
 697           (goto-char (point-min))
 698           (if (> (skip-chars-forward "\040\n\r\t") 0)
 699               (delete-region (point-min) (point)))
 700           (while (not (eobp))
 701             (cond
 702              ((looking-at "<PRE>\r?\n?")
 703               (delete-region (match-beginning 0) (match-end 0))
 704               (setq p (point))
 705               (when (search-forward "</PRE>" nil t)
 706                 (delete-region (match-beginning 0) (match-end 0))
 707                 (save-restriction
 708                   (narrow-to-region p (point))
 709                   (nnwarchive-remove-markup)
 710                   (nnwarchive-decode-entities)
 711                   (goto-char (point-max)))))
 712              ((looking-at "<P><A HREF=\"\\([^\"]+\\)")
 713               (setq url (match-string 1))
 714               (delete-region (match-beginning 0)
 715                              (progn (forward-line) (point)))
 716               ;; I hate to download the url encode it, then immediately
 717               ;; decode it.
 718               ;; FixMe: Find a better solution to attach the URL.
 719               ;; Maybe do some hack in external part of mml-generate-mim-1.
 720               (insert "<#part>"
 721                       "\n--\nExternal: \n"
 722                       (format "<URL:http://www.mail-archive.com/%s/%s>"
 723                               group url)
 724                       "\n--\n"
 725                       "<#/part>")
 726               (setq mime t))
 727              (t
 728               (setq p (point))
 729               (insert "<#part type=\"text/html\" disposition=inline>")
 730               (goto-char
 731                (if (re-search-forward
 732                     "[\040\n\r\t]*<PRE>\\|[\040\n\r\t]*<P><A HREF=\""
 733                     nil t)
 734                    (match-beginning 0)
 735                  (point-max)))
 736               (insert "<#/part>")
 737               (setq mime t)))
 738             (setq p (point))
 739             (if (> (skip-chars-forward "\040\n\r\t") 0)
 740                 (delete-region p (point))))
 741           (goto-char (point-max))))
 742       (setq p (point))
 743       (when (search-forward "X-References-End" nil t)
 744         (setq e (point))
 745         (beginning-of-line)
 746         (search-backward "X-References" p t)
 747         (while (re-search-forward "msg\\([0-9]+\\)\\.html" e t)
 748           (push (concat "<" (match-string 1) "%" group ">") refs)))
 749       (delete-region p (point-max))
 750       (goto-char (point-min))
 751       (insert (format "Message-ID: <%05d%%%s>\n" (1- article) group))
 752       (when refs
 753         (insert "References:")
 754         (while refs
 755           (insert " " (pop refs)))
 756         (insert "\n"))
 757       (when mime
 758         (unless (looking-at "$")
 759           (search-forward "\n\n" nil t)
 760           (forward-line -1))
 761         (narrow-to-region (point) (point-max))
 762         (insert "MIME-Version: 1.0\n"
 763                 (prog1
 764                     (mml-generate-mime)
 765                   (delete-region (point-min) (point-max))))
 766         (widen)))
 767     (buffer-string)))
 768
 769 (provide 'nnwarchive)
 770
 771 ;;; nnwarchive.el ends here