;;; nndoc.el --- single file access for Gnus
-;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
(require 'message)
(require 'nnmail)
(require 'nnoo)
+(require 'gnus-util)
(eval-when-compile (require 'cl))
(nnoo-declare nndoc)
(defvoo nndoc-article-type 'guess
"*Type of the file.
One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
-`rfc934', `rfc822-forward', `mime-digest', `standard-digest',
+`rfc934', `rfc822-forward', `mime-digest', `mime-parts', `standard-digest',
`slack-digest', `clari-briefs' or `guess'.")
(defvoo nndoc-post-type 'mail
(defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr
"Hook run after opening a document.
The default function removes all trailing carriage returns
-from the document.")
+from the document.")
(defvar nndoc-type-alist
`((mmdf
(body-end . "")
(file-end . "")
(subtype digest guess))
+ (mime-parts
+ (generate-head-function . nndoc-generate-mime-parts-head)
+ (article-transform-function . nndoc-transform-mime-parts))
(standard-digest
(first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+"))
(article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+"))
(subtype nil))))
\f
-
(defvoo nndoc-file-begin nil)
(defvoo nndoc-first-article nil)
-(defvoo nndoc-article-end nil)
(defvoo nndoc-article-begin nil)
(defvoo nndoc-head-begin nil)
(defvoo nndoc-head-end nil)
(defvoo nndoc-body-begin-function nil)
(defvoo nndoc-head-begin-function nil)
(defvoo nndoc-body-end nil)
+;; nndoc-dissection-alist is a list of sublists. Each sublist holds the
+;; following items. ARTICLE act as the association key and is an ordinal
+;; starting at 1. HEAD-BEGIN [0], HEAD-END [1], BODY-BEGIN [2] and BODY-END
+;; [3] are positions in the `nndoc' buffer. LINE-COUNT [4] is a count of
+;; lines in the body. For MIME dissections only, ARTICLE-INSERT [5] and
+;; SUMMARY-INSERT [6] give headers to insert for full article or summary line
+;; generation, respectively. Other headers usually follow directly from the
+;; buffer. Value `nil' means no insert.
(defvoo nndoc-dissection-alist nil)
(defvoo nndoc-prepare-body-function nil)
(defvoo nndoc-generate-head-function nil)
(insert-buffer-substring
nndoc-current-buffer (car entry) (nth 1 entry)))
(goto-char (point-max))
- (unless (= (char-after (1- (point))) ?\n)
+ (unless (eq (char-after (1- (point))) ?\n)
(insert "\n"))
(insert (format "Lines: %d\n" (nth 4 entry)))
(insert ".\n")))
(setq nndoc-dissection-alist nil)
(save-excursion
(set-buffer nndoc-current-buffer)
- (buffer-disable-undo (current-buffer))
(erase-buffer)
(if (stringp nndoc-address)
(nnheader-insert-file-contents nndoc-address)
(save-excursion
(set-buffer nndoc-current-buffer)
(nndoc-set-delims)
- (nndoc-dissect-buffer)))
+ (if (eq nndoc-article-type 'mime-parts)
+ (nndoc-dissect-mime-parts)
+ (nndoc-dissect-buffer))))
(unless nndoc-current-buffer
(nndoc-close-server))
;; Return whether we managed to select a file.
"Set the nndoc delimiter variables according to the type of the document."
(let ((vars '(nndoc-file-begin
nndoc-first-article
- nndoc-article-end nndoc-head-begin nndoc-head-end
+ nndoc-article-begin-function
+ nndoc-head-begin nndoc-head-end
nndoc-file-end nndoc-article-begin
nndoc-body-begin nndoc-body-end-function nndoc-body-end
nndoc-prepare-body-function nndoc-article-transform-function
(defun nndoc-rfc822-forward-body-end-function ()
(goto-char (point-max)))
+(defun nndoc-mime-parts-type-p ()
+ (let ((case-fold-search t)
+ (limit (search-forward "\n\n" nil t)))
+ (goto-char (point-min))
+ (when (and limit
+ (re-search-forward
+ (concat "\
+^Content-Type:[ \t]*multipart/[a-z]+ *;\\(\\(\n[ \t]\\)?.*;\\)*"
+ "\\(\n[ \t]\\)?[ \t]*boundary=\"?[^\"\n]*[^\" \t\n]")
+ limit t))
+ t)))
+
+(defun nndoc-transform-mime-parts (article)
+ (let* ((entry (cdr (assq article nndoc-dissection-alist)))
+ (headers (nth 5 entry)))
+ (when headers
+ (goto-char (point-min))
+ (insert headers))))
+
+(defun nndoc-generate-mime-parts-head (article)
+ (let* ((entry (cdr (assq article nndoc-dissection-alist)))
+ (headers (nth 6 entry)))
+ (when headers
+ (insert headers))
+ (insert-buffer-substring
+ nndoc-current-buffer (car entry) (nth 1 entry))))
+
(defun nndoc-clari-briefs-type-p ()
(when (let ((case-fold-search nil))
(re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
(when (and
(re-search-forward
(concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
- "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
+ "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
nil t)
(match-beginning 1))
(setq boundary-id (match-string 1)
(funcall nndoc-head-begin-function))
(nndoc-head-begin
(nndoc-search nndoc-head-begin)))
- (if (or (>= (point) (point-max))
+ (if (or (eobp)
(and nndoc-file-end
(looking-at nndoc-file-end)))
(goto-char (point-max))
(while (re-search-forward "^- -"nil t)
(replace-match "-" t t)))
+;; Against compiler warnings.
+(defvar nndoc-mime-split-ordinal)
+
+(defun nndoc-dissect-mime-parts ()
+ "Go through a MIME composite article and partition it into sub-articles.
+When a MIME entity contains sub-entities, dissection produces one article for
+the header of this entity, and one article per sub-entity."
+ (setq nndoc-dissection-alist nil
+ nndoc-mime-split-ordinal 0)
+ (save-excursion
+ (set-buffer nndoc-current-buffer)
+ (nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil)))
+
+(defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert
+ position parent)
+ "Dissect an entity, within a composite MIME message.
+The complete message or MIME entity extends from HEAD-BEGIN to BODY-END.
+ARTICLE-INSERT should be added at beginning for generating a full article.
+The string POSITION holds a dotted decimal representation of the article
+position in the hierarchical structure, it is nil for the outer entity.
+PARENT is the message-ID of the parent summary line, or nil for none."
+ (let ((case-fold-search t)
+ (message-id (nnmail-message-id))
+ head-end body-begin summary-insert message-rfc822 multipart-any
+ subject content-type type subtype boundary-regexp)
+ ;; Gracefully handle a missing body.
+ (goto-char head-begin)
+ (if (search-forward "\n\n" body-end t)
+ (setq head-end (1- (point))
+ body-begin (point))
+ (setq head-end body-end
+ body-begin body-end))
+ (narrow-to-region head-begin head-end)
+ ;; Save MIME attributes.
+ (goto-char head-begin)
+ (setq content-type (message-fetch-field "Content-Type"))
+ (when content-type
+ (when (string-match "^ *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" content-type)
+ (setq type (downcase (match-string 1 content-type))
+ subtype (downcase (match-string 2 content-type))
+ message-rfc822 (and (string= type "message")
+ (string= subtype "rfc822"))
+ multipart-any (string= type "multipart")))
+ (when (string-match ";[ \t\n]*name=\\([^ \t\n;]+\\)" content-type)
+ (setq subject (match-string 1 content-type)))
+ (when (string-match "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)" content-type)
+ (setq boundary-regexp (concat "^--"
+ (regexp-quote
+ (match-string 1 content-type))
+ "\\(--\\)?[ \t]*\n"))))
+ (unless subject
+ (when (or multipart-any (not article-insert))
+ (setq subject (message-fetch-field "Subject"))))
+ (unless type
+ (setq type "text"
+ subtype "plain"))
+ ;; Prepare the article and summary inserts.
+ (unless article-insert
+ (setq article-insert (buffer-substring (point-min) (point-max))
+ head-end head-begin))
+ (setq summary-insert article-insert)
+ ;; - summary Subject.
+ (setq summary-insert
+ (let ((line (concat "Subject: <" position
+ (and position multipart-any ".")
+ (and multipart-any "*")
+ (and (or position multipart-any) " ")
+ (cond ((string= subtype "plain") type)
+ ((string= subtype "basic") type)
+ (t subtype))
+ ">"
+ (and subject " ")
+ subject
+ "\n")))
+ (if (string-match "Subject:.*\n\\([ \t].*\n\\)*" summary-insert)
+ (replace-match line t t summary-insert)
+ (concat summary-insert line))))
+ ;; - summary Message-ID.
+ (setq summary-insert
+ (let ((line (concat "Message-ID: " message-id "\n")))
+ (if (string-match "Message-ID:.*\n\\([ \t].*\n\\)*" summary-insert)
+ (replace-match line t t summary-insert)
+ (concat summary-insert line))))
+ ;; - summary References.
+ (when parent
+ (setq summary-insert
+ (let ((line (concat "References: " parent "\n")))
+ (if (string-match "References:.*\n\\([ \t].*\n\\)*"
+ summary-insert)
+ (replace-match line t t summary-insert)
+ (concat summary-insert line)))))
+ ;; Generate dissection information for this entity.
+ (push (list (incf nndoc-mime-split-ordinal)
+ head-begin head-end body-begin body-end
+ (count-lines body-begin body-end)
+ article-insert summary-insert)
+ nndoc-dissection-alist)
+ ;; Recurse for all sub-entities, if any.
+ (widen)
+ (cond
+ (message-rfc822
+ (save-excursion
+ (nndoc-dissect-mime-parts-sub body-begin body-end nil
+ position message-id)))
+ ((and multipart-any boundary-regexp)
+ (let ((part-counter 0)
+ part-begin part-end eof-flag)
+ (while (string-match "\
+^\\(Lines\\|Content-\\(Type\\|Transfer-Encoding\\)\\):.*\n\\([ \t].*\n\\)*"
+ article-insert)
+ (setq article-insert (replace-match "" t t article-insert)))
+ (let ((case-fold-search nil))
+ (goto-char body-begin)
+ (setq eof-flag (not (re-search-forward boundary-regexp body-end t)))
+ (while (not eof-flag)
+ (setq part-begin (point))
+ (cond ((re-search-forward boundary-regexp body-end t)
+ (or (not (match-string 1))
+ (string= (match-string 1) "")
+ (setq eof-flag t))
+ (forward-line -1)
+ (setq part-end (point))
+ (forward-line 1))
+ (t (setq part-end body-end
+ eof-flag t)))
+ (save-excursion
+ (nndoc-dissect-mime-parts-sub
+ part-begin part-end article-insert
+ (concat position
+ (and position ".")
+ (format "%d" (incf part-counter)))
+ message-id)))))))))
+
;;;###autoload
(defun nndoc-add-type (definition &optional position)
"Add document DEFINITION to the list of nndoc document definitions.
first definition, and if any other symbol, add after that
symbol in the alist."
;; First remove any old instances.
- (setq nndoc-type-alist
- (delq (assq (car definition) nndoc-type-alist)
- nndoc-type-alist))
+ (gnus-pull (car definition) nndoc-type-alist)
;; Then enter the new definition in the proper place.
(cond
((or (null position) (eq position 'last))
projects / gnus / blobdiff