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