Mercurial > emacs
comparison lisp/gnus/nndoc.el @ 31716:9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Tue, 19 Sep 2000 13:37:09 +0000 |
parents | 15fc6acbae7a |
children | 0ca2ddcb4da5 |
comparison
equal
deleted
inserted
replaced
31715:7c896543d225 | 31716:9968f55ad26e |
---|---|
1 ;;; nndoc.el --- single file access for Gnus | 1 ;;; nndoc.el --- single file access for Gnus |
2 ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. | 2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 |
3 ;; Free Software Foundation, Inc. | |
3 | 4 |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> | 6 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
6 ;; Keywords: news | 7 ;; Keywords: news |
7 | 8 |
29 (require 'nnheader) | 30 (require 'nnheader) |
30 (require 'message) | 31 (require 'message) |
31 (require 'nnmail) | 32 (require 'nnmail) |
32 (require 'nnoo) | 33 (require 'nnoo) |
33 (require 'gnus-util) | 34 (require 'gnus-util) |
35 (require 'mm-util) | |
34 (eval-when-compile (require 'cl)) | 36 (eval-when-compile (require 'cl)) |
35 | 37 |
36 (nnoo-declare nndoc) | 38 (nnoo-declare nndoc) |
37 | 39 |
38 (defvoo nndoc-article-type 'guess | 40 (defvoo nndoc-article-type 'guess |
39 "*Type of the file. | 41 "*Type of the file. |
40 One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', | 42 One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', |
41 `rfc934', `rfc822-forward', `mime-digest', `mime-parts', `standard-digest', | 43 `rfc934', `rfc822-forward', `mime-parts', `standard-digest', |
42 `slack-digest', `clari-briefs' or `guess'.") | 44 `slack-digest', `clari-briefs', `nsmail' or `guess'.") |
43 | 45 |
44 (defvoo nndoc-post-type 'mail | 46 (defvoo nndoc-post-type 'mail |
45 "*Whether the nndoc group is `mail' or `post'.") | 47 "*Whether the nndoc group is `mail' or `post'.") |
46 | 48 |
47 (defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr | 49 (defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr |
48 "Hook run after opening a document. | 50 "Hook run after opening a document. |
49 The default function removes all trailing carriage returns | 51 The default function removes all trailing carriage returns |
50 from the document.") | 52 from the document.") |
51 | 53 |
52 (defvar nndoc-type-alist | 54 (defvar nndoc-type-alist |
53 `((mmdf | 55 `((mmdf |
54 (article-begin . "^\^A\^A\^A\^A\n") | 56 (article-begin . "^\^A\^A\^A\^A\n") |
55 (body-end . "^\^A\^A\^A\^A\n")) | 57 (body-end . "^\^A\^A\^A\^A\n")) |
58 (nsmail | |
59 (article-begin . "^From - ")) | |
56 (news | 60 (news |
57 (article-begin . "^Path:")) | 61 (article-begin . "^Path:")) |
58 (rnews | 62 (rnews |
59 (article-begin . "^#! *rnews +\\([0-9]+\\) *\n") | 63 (article-begin . "^#! *rnews +\\([0-9]+\\) *\n") |
60 (body-end-function . nndoc-rnews-body-end)) | 64 (body-end-function . nndoc-rnews-body-end)) |
65 (article-begin . "\^_\^L *\n") | 69 (article-begin . "\^_\^L *\n") |
66 (body-end . "\^_") | 70 (body-end . "\^_") |
67 (body-begin-function . nndoc-babyl-body-begin) | 71 (body-begin-function . nndoc-babyl-body-begin) |
68 (head-begin-function . nndoc-babyl-head-begin)) | 72 (head-begin-function . nndoc-babyl-head-begin)) |
69 (forward | 73 (forward |
70 (article-begin . "^-+ Start of forwarded message -+\n+") | 74 (article-begin . "^-+ \\(Start of \\)?forwarded message.*\n+") |
71 (body-end . "^-+ End of forwarded message -+$") | 75 (body-end . "^-+ End \\(of \\)?forwarded message.*$") |
72 (prepare-body-function . nndoc-unquote-dashes)) | 76 (prepare-body-function . nndoc-unquote-dashes)) |
73 (rfc934 | 77 (rfc934 |
74 (article-begin . "^--.*\n+") | 78 (article-begin . "^--.*\n+") |
75 (body-end . "^--.*$") | 79 (body-end . "^--.*$") |
76 (prepare-body-function . nndoc-unquote-dashes)) | 80 (prepare-body-function . nndoc-unquote-dashes)) |
81 (head-end . "^\t") | 85 (head-end . "^\t") |
82 (generate-head-function . nndoc-generate-clari-briefs-head) | 86 (generate-head-function . nndoc-generate-clari-briefs-head) |
83 (article-transform-function . nndoc-transform-clari-briefs)) | 87 (article-transform-function . nndoc-transform-clari-briefs)) |
84 (mime-digest | 88 (mime-digest |
85 (article-begin . "") | 89 (article-begin . "") |
90 (head-begin . "^ ?\n") | |
86 (head-end . "^ ?$") | 91 (head-end . "^ ?$") |
87 (body-end . "") | 92 (body-end . "") |
88 (file-end . "") | 93 (file-end . "") |
89 (subtype digest guess)) | 94 (subtype digest guess)) |
90 (mime-parts | 95 (mime-parts |
118 (article-transform-function . nndoc-transform-lanl-gov-announce) | 123 (article-transform-function . nndoc-transform-lanl-gov-announce) |
119 (subtype preprints guess)) | 124 (subtype preprints guess)) |
120 (rfc822-forward | 125 (rfc822-forward |
121 (article-begin . "^\n") | 126 (article-begin . "^\n") |
122 (body-end-function . nndoc-rfc822-forward-body-end-function)) | 127 (body-end-function . nndoc-rfc822-forward-body-end-function)) |
128 (outlook | |
129 (article-begin-function . nndoc-outlook-article-begin) | |
130 (body-end . "\0")) | |
123 (guess | 131 (guess |
124 (guess . t) | 132 (guess . t) |
125 (subtype nil)) | 133 (subtype nil)) |
126 (digest | 134 (digest |
127 (guess . t) | 135 (guess . t) |
141 (defvoo nndoc-body-end-function nil) | 149 (defvoo nndoc-body-end-function nil) |
142 (defvoo nndoc-body-begin-function nil) | 150 (defvoo nndoc-body-begin-function nil) |
143 (defvoo nndoc-head-begin-function nil) | 151 (defvoo nndoc-head-begin-function nil) |
144 (defvoo nndoc-body-end nil) | 152 (defvoo nndoc-body-end nil) |
145 ;; nndoc-dissection-alist is a list of sublists. Each sublist holds the | 153 ;; nndoc-dissection-alist is a list of sublists. Each sublist holds the |
146 ;; following items. ARTICLE is an ordinal starting at 1. HEAD-BEGIN, | 154 ;; following items. ARTICLE acts as the association key and is an ordinal |
147 ;; HEAD-END, BODY-BEGIN and BODY-END are positions in the `nndoc' buffer. | 155 ;; starting at 1. HEAD-BEGIN [0], HEAD-END [1], BODY-BEGIN [2] and BODY-END |
148 ;; LINE-COUNT is a count of lines in the body. SUBJECT, MESSAGE-ID and | 156 ;; [3] are positions in the `nndoc' buffer. LINE-COUNT [4] is a count of |
149 ;; REFERENCES, only present for MIME dissections, are field values. | 157 ;; lines in the body. For MIME dissections only, ARTICLE-INSERT [5] and |
158 ;; SUMMARY-INSERT [6] give headers to insert for full article or summary line | |
159 ;; generation, respectively. Other headers usually follow directly from the | |
160 ;; buffer. Value `nil' means no insert. | |
150 (defvoo nndoc-dissection-alist nil) | 161 (defvoo nndoc-dissection-alist nil) |
151 (defvoo nndoc-prepare-body-function nil) | 162 (defvoo nndoc-prepare-body-function nil) |
152 (defvoo nndoc-generate-head-function nil) | 163 (defvoo nndoc-generate-head-function nil) |
153 (defvoo nndoc-article-transform-function nil) | 164 (defvoo nndoc-article-transform-function nil) |
154 (defvoo nndoc-article-begin-function nil) | 165 (defvoo nndoc-article-begin-function nil) |
156 (defvoo nndoc-status-string "") | 167 (defvoo nndoc-status-string "") |
157 (defvoo nndoc-group-alist nil) | 168 (defvoo nndoc-group-alist nil) |
158 (defvoo nndoc-current-buffer nil | 169 (defvoo nndoc-current-buffer nil |
159 "Current nndoc news buffer.") | 170 "Current nndoc news buffer.") |
160 (defvoo nndoc-address nil) | 171 (defvoo nndoc-address nil) |
161 (defvoo nndoc-mime-header nil) | |
162 (defvoo nndoc-mime-subject nil) | |
163 | 172 |
164 (defconst nndoc-version "nndoc 1.0" | 173 (defconst nndoc-version "nndoc 1.0" |
165 "nndoc version.") | 174 "nndoc version.") |
166 | 175 |
167 | 176 |
185 (if nndoc-generate-head-function | 194 (if nndoc-generate-head-function |
186 (funcall nndoc-generate-head-function article) | 195 (funcall nndoc-generate-head-function article) |
187 (insert-buffer-substring | 196 (insert-buffer-substring |
188 nndoc-current-buffer (car entry) (nth 1 entry))) | 197 nndoc-current-buffer (car entry) (nth 1 entry))) |
189 (goto-char (point-max)) | 198 (goto-char (point-max)) |
190 (unless (= (char-after (1- (point))) ?\n) | 199 (unless (eq (char-after (1- (point))) ?\n) |
191 (insert "\n")) | 200 (insert "\n")) |
192 (insert (format "Lines: %d\n" (nth 4 entry))) | 201 (insert (format "Lines: %d\n" (nth 4 entry))) |
193 (insert ".\n"))) | 202 (insert ".\n"))) |
194 | 203 |
195 (nnheader-fold-continuation-lines) | 204 (nnheader-fold-continuation-lines) |
287 (concat " *nndoc " group "*")))) | 296 (concat " *nndoc " group "*")))) |
288 nndoc-group-alist) | 297 nndoc-group-alist) |
289 (setq nndoc-dissection-alist nil) | 298 (setq nndoc-dissection-alist nil) |
290 (save-excursion | 299 (save-excursion |
291 (set-buffer nndoc-current-buffer) | 300 (set-buffer nndoc-current-buffer) |
292 (buffer-disable-undo (current-buffer)) | |
293 (erase-buffer) | 301 (erase-buffer) |
294 (if (stringp nndoc-address) | 302 (if (stringp nndoc-address) |
295 (nnheader-insert-file-contents nndoc-address) | 303 (nnheader-insert-file-contents nndoc-address) |
296 (insert-buffer-substring nndoc-address)) | 304 (insert-buffer-substring nndoc-address)) |
297 (run-hooks 'nndoc-open-document-hook)))) | 305 (run-hooks 'nndoc-open-document-hook)))) |
341 results result entry) | 349 results result entry) |
342 (while (and (not result) | 350 (while (and (not result) |
343 (setq entry (pop alist))) | 351 (setq entry (pop alist))) |
344 (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess))) | 352 (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess))) |
345 (goto-char (point-min)) | 353 (goto-char (point-min)) |
354 ;; Remove blank lines. | |
355 (while (eq (following-char) ?\n) | |
356 (delete-char 1)) | |
346 (when (numberp (setq result (funcall (intern | 357 (when (numberp (setq result (funcall (intern |
347 (format "nndoc-%s-type-p" | 358 (format "nndoc-%s-type-p" |
348 (car entry)))))) | 359 (car entry)))))) |
349 (push (cons result entry) results) | 360 (push (cons result entry) results) |
350 (setq result nil)))) | 361 (setq result nil)))) |
423 (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") | 434 (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") |
424 (forward-line 1)) | 435 (forward-line 1)) |
425 t)) | 436 t)) |
426 | 437 |
427 (defun nndoc-forward-type-p () | 438 (defun nndoc-forward-type-p () |
428 (when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t) | 439 (when (and (re-search-forward "^-+ \\(Start of \\)?forwarded message.*\n+" |
440 nil t) | |
429 (not (re-search-forward "^Subject:.*digest" nil t)) | 441 (not (re-search-forward "^Subject:.*digest" nil t)) |
430 (not (re-search-backward "^From:" nil t 2)) | 442 (not (re-search-backward "^From:" nil t 2)) |
431 (not (re-search-forward "^From:" nil t 2))) | 443 (not (re-search-forward "^From:" nil t 2))) |
432 t)) | 444 t)) |
433 | 445 |
450 (defun nndoc-mime-parts-type-p () | 462 (defun nndoc-mime-parts-type-p () |
451 (let ((case-fold-search t) | 463 (let ((case-fold-search t) |
452 (limit (search-forward "\n\n" nil t))) | 464 (limit (search-forward "\n\n" nil t))) |
453 (goto-char (point-min)) | 465 (goto-char (point-min)) |
454 (when (and limit | 466 (when (and limit |
455 (re-search-forward | 467 (re-search-forward |
456 (concat "\ | 468 (concat "\ |
457 ^Content-Type:[ \t]*multipart/[a-z]+;\\(.*;\\)*" | 469 ^Content-Type:[ \t]*multipart/[a-z]+ *; *\\(\\(\n[ \t]\\)?.*;\\)*" |
458 "[ \t\n]*[ \t]boundary=\"?[^\"\n]*[^\" \t\n]") | 470 "\\(\n[ \t]\\)?[ \t]*boundary=\"?[^\"\n]*[^\" \t\n]") |
459 limit t)) | 471 limit t)) |
460 t))) | 472 t))) |
461 | 473 |
462 (defun nndoc-transform-mime-parts (article) | 474 (defun nndoc-transform-mime-parts (article) |
463 (unless (= article 1) | 475 (let* ((entry (cdr (assq article nndoc-dissection-alist))) |
464 ;; Ensure some MIME-Version. | 476 (headers (nth 5 entry))) |
465 (goto-char (point-min)) | 477 (when headers |
466 (search-forward "\n\n") | |
467 (let ((case-fold-search nil) | |
468 (limit (point))) | |
469 (goto-char (point-min)) | 478 (goto-char (point-min)) |
470 (or (save-excursion (re-search-forward "^MIME-Version:" limit t)) | 479 (insert headers)))) |
471 (insert "Mime-Version: 1.0\n"))) | 480 |
472 ;; Generate default header before entity fields. | 481 (defun nndoc-generate-mime-parts-head (article) |
473 (goto-char (point-min)) | 482 (let* ((entry (cdr (assq article nndoc-dissection-alist))) |
474 (nndoc-generate-mime-parts-head article t))) | 483 (headers (nth 6 entry))) |
475 | 484 (save-restriction |
476 (defun nndoc-generate-mime-parts-head (article &optional body-present) | 485 (narrow-to-region (point) (point)) |
477 (let ((entry (cdr (assq (if body-present 1 article) nndoc-dissection-alist)))) | 486 (insert-buffer-substring |
478 (let ((subject (if body-present | 487 nndoc-current-buffer (car entry) (nth 1 entry)) |
479 nndoc-mime-subject | 488 (goto-char (point-max))) |
480 (concat "<" (nth 5 entry) ">"))) | 489 (when headers |
481 (message-id (nth 6 entry)) | 490 (insert headers)))) |
482 (references (nth 7 entry))) | |
483 (insert nndoc-mime-header) | |
484 (and subject (insert "Subject: " subject "\n")) | |
485 (and message-id (insert "Message-ID: " message-id "\n")) | |
486 (and references (insert "References: " references "\n"))))) | |
487 | 491 |
488 (defun nndoc-clari-briefs-type-p () | 492 (defun nndoc-clari-briefs-type-p () |
489 (when (let ((case-fold-search nil)) | 493 (when (let ((case-fold-search nil)) |
490 (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) | 494 (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) |
491 t)) | 495 t)) |
514 "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t)) | 518 "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t)) |
515 (setq from (match-string 1))))) | 519 (setq from (match-string 1))))) |
516 (insert "From: " "clari@clari.net (" (or from "unknown") ")" | 520 (insert "From: " "clari@clari.net (" (or from "unknown") ")" |
517 "\nSubject: " (or subject "(no subject)") "\n"))) | 521 "\nSubject: " (or subject "(no subject)") "\n"))) |
518 | 522 |
523 | |
519 (defun nndoc-mime-digest-type-p () | 524 (defun nndoc-mime-digest-type-p () |
520 (let ((case-fold-search t) | 525 (let ((case-fold-search t) |
521 boundary-id b-delimiter entry) | 526 boundary-id b-delimiter entry) |
522 (when (and | 527 (when (and |
523 (re-search-forward | 528 (re-search-forward |
524 (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" | 529 (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" |
525 "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)") | 530 "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)") |
526 nil t) | 531 nil t) |
527 (match-beginning 1)) | 532 (match-beginning 1)) |
528 (setq boundary-id (match-string 1) | 533 (setq boundary-id (match-string 1) |
529 b-delimiter (concat "\n--" boundary-id "[\n \t]+")) | 534 b-delimiter (concat "\n--" boundary-id "[ \t]*$")) |
530 (setq entry (assq 'mime-digest nndoc-type-alist)) | 535 (setq entry (assq 'mime-digest nndoc-type-alist)) |
531 (setcdr entry | 536 (setcdr entry |
532 (list | 537 (list |
538 (cons 'head-begin "^ ?\n") | |
533 (cons 'head-end "^ ?$") | 539 (cons 'head-end "^ ?$") |
534 (cons 'body-begin "^ ?\n") | 540 (cons 'body-begin "^ ?\n") |
535 (cons 'article-begin b-delimiter) | 541 (cons 'article-begin b-delimiter) |
536 (cons 'body-end-function 'nndoc-digest-body-end) | 542 (cons 'body-end-function 'nndoc-digest-body-end) |
537 (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$")))) | 543 (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$")))) |
556 t)) | 562 t)) |
557 | 563 |
558 (defun nndoc-transform-lanl-gov-announce (article) | 564 (defun nndoc-transform-lanl-gov-announce (article) |
559 (goto-char (point-max)) | 565 (goto-char (point-max)) |
560 (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t) | 566 (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t) |
561 (replace-match "\n\nGet it at \\1 (\\2)" t nil)) | 567 (replace-match "\n\nGet it at \\1 (\\2)" t nil))) |
562 ;; (when (re-search-backward "^\\\\\\\\$" nil t) | |
563 ;; (replace-match "" t t)) | |
564 ) | |
565 | 568 |
566 (defun nndoc-generate-lanl-gov-head (article) | 569 (defun nndoc-generate-lanl-gov-head (article) |
567 (let ((entry (cdr (assq article nndoc-dissection-alist))) | 570 (let ((entry (cdr (assq article nndoc-dissection-alist))) |
568 (e-mail "no address given") | 571 (e-mail "no address given") |
569 subject from) | 572 subject from) |
577 (when (re-search-forward "^From: \\([^ ]+\\)" nil t) | 580 (when (re-search-forward "^From: \\([^ ]+\\)" nil t) |
578 (setq e-mail (match-string 1))) | 581 (setq e-mail (match-string 1))) |
579 (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)" | 582 (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)" |
580 nil t) | 583 nil t) |
581 (setq subject (concat (match-string 1) subject)) | 584 (setq subject (concat (match-string 1) subject)) |
582 (setq from (concat (match-string 2) " <" e-mail ">")))) | 585 (setq from (concat (match-string 2) " <" e-mail ">")))))) |
583 )) | |
584 (while (and from (string-match "(\[^)\]*)" from)) | 586 (while (and from (string-match "(\[^)\]*)" from)) |
585 (setq from (replace-match "" t t from))) | 587 (setq from (replace-match "" t t from))) |
586 (insert "From: " (or from "unknown") | 588 (insert "From: " (or from "unknown") |
587 "\nSubject: " (or subject "(no subject)") "\n"))) | 589 "\nSubject: " (or subject "(no subject)") "\n"))) |
588 | 590 |
591 (defun nndoc-nsmail-type-p () | |
592 (when (looking-at "From - ") | |
593 t)) | |
594 | |
595 (defun nndoc-outlook-article-begin () | |
596 (prog1 (re-search-forward "From:\\|Received:" nil t) | |
597 (goto-char (match-beginning 0)))) | |
598 | |
599 (defun nndoc-outlook-type-p () | |
600 ;; FIXME: Is JMF the magic of outlook mailbox? -- ShengHuo. | |
601 (looking-at "JMF")) | |
602 | |
589 (deffoo nndoc-request-accept-article (group &optional server last) | 603 (deffoo nndoc-request-accept-article (group &optional server last) |
590 nil) | 604 nil) |
591 | |
592 | 605 |
593 | 606 |
594 ;;; | 607 ;;; |
595 ;;; Functions for dissecting the documents | 608 ;;; Functions for dissecting the documents |
596 ;;; | 609 ;;; |
607 head-begin head-end body-begin body-end) | 620 head-begin head-end body-begin body-end) |
608 (setq nndoc-dissection-alist nil) | 621 (setq nndoc-dissection-alist nil) |
609 (save-excursion | 622 (save-excursion |
610 (set-buffer nndoc-current-buffer) | 623 (set-buffer nndoc-current-buffer) |
611 (goto-char (point-min)) | 624 (goto-char (point-min)) |
625 ;; Remove blank lines. | |
626 (while (eq (following-char) ?\n) | |
627 (delete-char 1)) | |
612 ;; Find the beginning of the file. | 628 ;; Find the beginning of the file. |
613 (when nndoc-file-begin | 629 (when nndoc-file-begin |
614 (nndoc-search nndoc-file-begin)) | 630 (nndoc-search nndoc-file-begin)) |
615 ;; Go through the file. | 631 ;; Go through the file. |
616 (while (if (and first nndoc-first-article) | 632 (while (if (and first nndoc-first-article) |
667 the header of this entity, and one article per sub-entity." | 683 the header of this entity, and one article per sub-entity." |
668 (setq nndoc-dissection-alist nil | 684 (setq nndoc-dissection-alist nil |
669 nndoc-mime-split-ordinal 0) | 685 nndoc-mime-split-ordinal 0) |
670 (save-excursion | 686 (save-excursion |
671 (set-buffer nndoc-current-buffer) | 687 (set-buffer nndoc-current-buffer) |
672 (message-narrow-to-head) | 688 (nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil))) |
673 (let ((case-fold-search t) | 689 |
674 (message-id (message-fetch-field "Message-ID")) | 690 (defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert |
675 (references (message-fetch-field "References"))) | 691 position parent) |
676 (setq nndoc-mime-header (buffer-substring (point-min) (point-max)) | 692 "Dissect an entity, within a composite MIME message. |
677 nndoc-mime-subject (message-fetch-field "Subject")) | 693 The complete message or MIME entity extends from HEAD-BEGIN to BODY-END. |
678 (while (string-match "\ | 694 ARTICLE-INSERT should be added at beginning for generating a full article. |
679 ^\\(Subject\\|Message-ID\\|References\\|Lines\\|\ | |
680 MIME-Version\\|Content-Type\\|Content-Transfer-Encoding\\|\ | |
681 \\):.*\n\\([ \t].*\n\\)*" | |
682 nndoc-mime-header) | |
683 (setq nndoc-mime-header (replace-match "" t t nndoc-mime-header))) | |
684 (widen) | |
685 (nndoc-dissect-mime-parts-sub (point-min) (point-max) | |
686 nil message-id references)))) | |
687 | |
688 (defun nndoc-dissect-mime-parts-sub (begin end position message-id references) | |
689 "Dissect an entity within a composite MIME message. | |
690 The article, which corresponds to a MIME entity, extends from BEGIN to END. | |
691 The string POSITION holds a dotted decimal representation of the article | 695 The string POSITION holds a dotted decimal representation of the article |
692 position in the hierarchical structure, it is nil for the outer entity. | 696 position in the hierarchical structure, it is nil for the outer entity. |
693 The generated article should use MESSAGE-ID and REFERENCES field values." | 697 PARENT is the message-ID of the parent summary line, or nil for none." |
694 ;; Note: `case-fold-search' is already `t' from the calling function. | 698 (let ((case-fold-search t) |
695 (let ((head-begin begin) | 699 (message-id (nnmail-message-id)) |
696 (body-end end) | 700 head-end body-begin summary-insert message-rfc822 multipart-any |
697 head-end body-begin type subtype composite comment) | 701 subject content-type type subtype boundary-regexp) |
698 (save-excursion | 702 ;; Gracefully handle a missing body. |
699 ;; Gracefully handle a missing body. | 703 (goto-char head-begin) |
700 (goto-char head-begin) | 704 (if (search-forward "\n\n" body-end t) |
701 (if (search-forward "\n\n" body-end t) | 705 (setq head-end (1- (point)) |
702 (setq head-end (1- (point)) | 706 body-begin (point)) |
703 body-begin (point)) | 707 (setq head-end body-end |
704 (setq head-end end | 708 body-begin body-end)) |
705 body-begin end)) | 709 (narrow-to-region head-begin head-end) |
706 ;; Save MIME attributes. | 710 ;; Save MIME attributes. |
707 (goto-char head-begin) | 711 (goto-char head-begin) |
708 (if (re-search-forward "\ | 712 (setq content-type (message-fetch-field "Content-Type")) |
709 ^Content-Type: *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" | 713 (when content-type |
710 head-end t) | 714 (when (string-match |
711 (setq type (downcase (match-string 1)) | 715 "^ *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" content-type) |
712 subtype (downcase (match-string 2))) | 716 (setq type (downcase (match-string 1 content-type)) |
713 (setq type "text" | 717 subtype (downcase (match-string 2 content-type)) |
714 subtype "plain")) | 718 message-rfc822 (and (string= type "message") |
715 (setq composite (string= type "multipart") | 719 (string= subtype "rfc822")) |
716 comment (concat position | 720 multipart-any (string= type "multipart"))) |
717 (when (and position composite) ".") | 721 (when (string-match ";[ \t\n]*name=\\([^ \t\n;]+\\)" content-type) |
718 (when composite "*") | 722 (setq subject (match-string 1 content-type))) |
719 (when (or position composite) " ") | 723 (when (string-match "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)" content-type) |
720 (cond ((string= subtype "plain") type) | 724 (setq boundary-regexp (concat "^--" |
721 ((string= subtype "basic") type) | 725 (regexp-quote |
722 (t subtype)))) | 726 (match-string 1 content-type)) |
723 ;; Generate dissection information for this entity. | 727 "\\(--\\)?[ \t]*\n")))) |
724 (push (list (incf nndoc-mime-split-ordinal) | 728 (unless subject |
725 head-begin head-end body-begin body-end | 729 (when (or multipart-any (not article-insert)) |
726 (count-lines body-begin body-end) | 730 (setq subject (message-fetch-field "Subject")))) |
727 comment message-id references) | 731 (unless type |
728 nndoc-dissection-alist) | 732 (setq type "text" |
729 ;; Recurse for all sub-entities, if any. | 733 subtype "plain")) |
730 (goto-char head-begin) | 734 ;; Prepare the article and summary inserts. |
731 (when (re-search-forward | 735 (unless article-insert |
732 (concat "\ | 736 (setq article-insert (buffer-substring (point-min) (point-max)) |
733 ^Content-Type: *multipart/\\([a-z]+\\);\\(.*;\\)*" | 737 head-end head-begin)) |
734 "[ \t\n]*[ \t]boundary=\"?\\([^\"\n]*[^\" \t\n]\\)") | 738 (setq summary-insert article-insert) |
735 head-end t) | 739 ;; - summary Subject. |
736 (let ((boundary (concat "\n--" (match-string 3) "\\(--\\)?[ \t]*\n")) | 740 (setq summary-insert |
737 (part-counter 0) | 741 (let ((line (concat "Subject: <" position |
738 begin end eof-flag) | 742 (and position multipart-any ".") |
739 (goto-char head-end) | 743 (and multipart-any "*") |
740 (setq eof-flag (not (re-search-forward boundary body-end t))) | 744 (and (or position multipart-any) " ") |
745 (cond ((string= subtype "plain") type) | |
746 ((string= subtype "basic") type) | |
747 (t subtype)) | |
748 ">" | |
749 (and subject " ") | |
750 subject | |
751 "\n"))) | |
752 (if (string-match "Subject:.*\n\\([ \t].*\n\\)*" summary-insert) | |
753 (replace-match line t t summary-insert) | |
754 (concat summary-insert line)))) | |
755 ;; - summary Message-ID. | |
756 (setq summary-insert | |
757 (let ((line (concat "Message-ID: " message-id "\n"))) | |
758 (if (string-match "Message-ID:.*\n\\([ \t].*\n\\)*" summary-insert) | |
759 (replace-match line t t summary-insert) | |
760 (concat summary-insert line)))) | |
761 ;; - summary References. | |
762 (when parent | |
763 (setq summary-insert | |
764 (let ((line (concat "References: " parent "\n"))) | |
765 (if (string-match "References:.*\n\\([ \t].*\n\\)*" | |
766 summary-insert) | |
767 (replace-match line t t summary-insert) | |
768 (concat summary-insert line))))) | |
769 ;; Generate dissection information for this entity. | |
770 (push (list (incf nndoc-mime-split-ordinal) | |
771 head-begin head-end body-begin body-end | |
772 (count-lines body-begin body-end) | |
773 article-insert summary-insert) | |
774 nndoc-dissection-alist) | |
775 ;; Recurse for all sub-entities, if any. | |
776 (widen) | |
777 (cond | |
778 (message-rfc822 | |
779 (save-excursion | |
780 (nndoc-dissect-mime-parts-sub body-begin body-end nil | |
781 position message-id))) | |
782 ((and multipart-any boundary-regexp) | |
783 (let ((part-counter 0) | |
784 part-begin part-end eof-flag) | |
785 (while (string-match "\ | |
786 ^\\(Lines\\|Content-\\(Type\\|Transfer-Encoding\\|Disposition\\)\\):.*\n\\([ \t].*\n\\)*" | |
787 article-insert) | |
788 (setq article-insert (replace-match "" t t article-insert))) | |
789 (let ((case-fold-search nil)) | |
790 (goto-char body-begin) | |
791 (setq eof-flag (not (re-search-forward boundary-regexp body-end t))) | |
741 (while (not eof-flag) | 792 (while (not eof-flag) |
742 (setq begin (point)) | 793 (setq part-begin (point)) |
743 (cond ((re-search-forward boundary body-end t) | 794 (cond ((re-search-forward boundary-regexp body-end t) |
744 (or (not (match-string 1)) | 795 (or (not (match-string 1)) |
745 (string= (match-string 1) "") | 796 (string= (match-string 1) "") |
746 (setq eof-flag t)) | 797 (setq eof-flag t)) |
747 (forward-line -1) | 798 (forward-line -1) |
748 (setq end (point)) | 799 (setq part-end (point)) |
749 (forward-line 1)) | 800 (forward-line 1)) |
750 (t (setq end body-end | 801 (t (setq part-end body-end |
751 eof-flag t))) | 802 eof-flag t))) |
752 (nndoc-dissect-mime-parts-sub begin end | 803 (save-excursion |
753 (concat position (when position ".") | 804 (nndoc-dissect-mime-parts-sub |
754 (format "%d" | 805 part-begin part-end article-insert |
755 (incf part-counter))) | 806 (concat position |
756 (nnmail-message-id) | 807 (and position ".") |
757 message-id))))))) | 808 (format "%d" (incf part-counter))) |
809 message-id))))))))) | |
758 | 810 |
759 ;;;###autoload | 811 ;;;###autoload |
760 (defun nndoc-add-type (definition &optional position) | 812 (defun nndoc-add-type (definition &optional position) |
761 "Add document DEFINITION to the list of nndoc document definitions. | 813 "Add document DEFINITION to the list of nndoc document definitions. |
762 If POSITION is nil or `last', the definition will be added | 814 If POSITION is nil or `last', the definition will be added |