1;;; nnwarchive.el --- interfacing with web archives 2 3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 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 2, 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>: *\\([^<]*[^< ]\\) *<\\([^&]+\\)>") 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 730