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