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