Update copyright year to 2016
[gnus] / lisp / nndoc.el
1 ;;; nndoc.el --- single file access for Gnus
2
3 ;; Copyright (C) 1995-2016 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7 ;; Keywords: news
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 by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU 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.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;; For Outlook mail boxes format, see http://mbx2mbox.sourceforge.net/
27
28 ;;; Code:
29
30 (require 'nnheader)
31 (require 'message)
32 (require 'nnmail)
33 (require 'nnoo)
34 (require 'gnus-util)
35 (require 'mm-util)
36 (eval-when-compile (require 'cl))
37
38 (nnoo-declare nndoc)
39
40 (defvoo nndoc-article-type 'guess
41   "*Type of the file.
42 One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
43 `rfc934', `rfc822-forward', `mime-parts', `standard-digest',
44 `slack-digest', `clari-briefs', `nsmail', `outlook', `oe-dbx',
45 `mailman', `exim-bounce', or `guess'.")
46
47 (defvoo nndoc-post-type 'mail
48   "*Whether the nndoc group is `mail' or `post'.")
49
50 (defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr
51   "Hook run after opening a document.
52 The default function removes all trailing carriage returns
53 from the document.")
54
55 (defvar nndoc-type-alist
56   `((mmdf
57      (article-begin .  "^\^A\^A\^A\^A\n")
58      (body-end .  "^\^A\^A\^A\^A\n"))
59     (debbugs-db
60      (file-begin    . "^\005")
61      (article-begin . "^[\005\007]\n")
62      (body-end      . "^\003"))
63     (mime-digest
64      (article-begin . "")
65      (head-begin . "^ ?\n")
66      (head-end . "^ ?$")
67      (body-end . "")
68      (file-end . "")
69      (subtype digest guess))
70     (nsmail
71      (article-begin .  "^From - "))
72     (news
73      (article-begin . "^Path:"))
74     (rnews
75      (article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
76      (body-end-function . nndoc-rnews-body-end))
77     (mbox
78      (article-begin-function . nndoc-mbox-article-begin)
79      (body-end-function . nndoc-mbox-body-end))
80     (babyl
81      (article-begin . "\^_\^L *\n")
82      (body-end . "\^_")
83      (body-begin-function . nndoc-babyl-body-begin)
84      (head-begin-function . nndoc-babyl-head-begin))
85     (mime-parts
86      (generate-head-function . nndoc-generate-mime-parts-head)
87      (article-transform-function . nndoc-transform-mime-parts))
88     (exim-bounce
89      (article-begin . "^------ This is a copy of the message, including all the headers. ------\n\n")
90      (body-end-function . nndoc-exim-bounce-body-end-function))
91     (rfc934
92      (article-begin . "^--.*\n+")
93      (body-end . "^--.*$")
94      (prepare-body-function . nndoc-unquote-dashes))
95     (mailman
96      (article-begin . "^--__--__--\n\nMessage:")
97      (body-end . "^--__--__--$")
98      (prepare-body-function . nndoc-unquote-dashes))
99     (clari-briefs
100      (article-begin . "^ \\*")
101      (body-end . "^\t------*[ \t]^*\n^ \\*")
102      (body-begin . "^\t")
103      (head-end . "^\t")
104      (generate-head-function . nndoc-generate-clari-briefs-head)
105      (article-transform-function . nndoc-transform-clari-briefs))
106
107     (standard-digest
108      (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+"))
109      (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+"))
110      (prepare-body-function . nndoc-unquote-dashes)
111      (body-end-function . nndoc-digest-body-end)
112      (head-end . "^ *$")
113      (body-begin . "^ *\n")
114      (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$")
115      (subtype digest guess))
116     (slack-digest
117      (article-begin . "^------------------------------*[\n \t]+")
118      (head-end . "^ ?$")
119      (body-end-function . nndoc-digest-body-end)
120      (body-begin . "^ ?$")
121      (file-end . "^End of")
122      (prepare-body-function . nndoc-unquote-dashes)
123      (subtype digest guess))
124     (google
125      (pre-dissection-function . nndoc-decode-content-transfer-encoding)
126      (article-begin . "^== [0-9]+ of [0-9]+ ==$")
127      (head-begin . "^Date:")
128      (head-end . "^$")
129      (body-end-function . nndoc-digest-body-end)
130      (body-begin . "^$")
131      (file-end . "^==============================================================================$")
132      (prepare-body-function . nndoc-unquote-dashes)
133      (subtype digest guess))
134     (lanl-gov-announce
135      (article-begin . "^\\\\\\\\\n")
136      (head-begin . "^\\(Paper.*:\\|arXiv:\\)")
137      (head-end   . "\\(^\\\\\\\\.*\n\\|-----------------\\)")
138      (body-begin . "")
139      (body-end   . "\\(-------------------------------------------------\\|%-%-%-%-%-%-%-%-%-%-%-%-%-%-\\|%%--%%--%%--%%--%%--%%--%%--%%--\\|%%%---%%%---%%%---%%%---\\)")
140      (file-end   . "\\(^Title: Recent Seminal\\|%%%---%%%---%%%---%%%---\\)")
141      (generate-head-function . nndoc-generate-lanl-gov-head)
142      (article-transform-function . nndoc-transform-lanl-gov-announce)
143      (subtype preprints guess))
144     (git
145      (file-begin . "\n- Log ---.*")
146      (article-begin . "^commit ")
147      (head-begin . "^Author: ")
148      (body-begin . "^$")
149      (file-end . "\n-----------------------------------------------------------------------")
150      (article-transform-function . nndoc-transform-git-article)
151      (header-transform-function . nndoc-transform-git-headers))
152     (rfc822-forward
153      (article-begin . "^\n+")
154      (body-end-function . nndoc-rfc822-forward-body-end-function)
155      (generate-head-function . nndoc-rfc822-forward-generate-head)
156      (generate-article-function . nndoc-rfc822-forward-generate-article))
157     (outlook
158      (article-begin-function . nndoc-outlook-article-begin)
159      (body-end .  "\0"))
160     (oe-dbx  ;; Outlook Express DBX format
161      (dissection-function . nndoc-oe-dbx-dissection)
162      (generate-head-function . nndoc-oe-dbx-generate-head)
163      (generate-article-function . nndoc-oe-dbx-generate-article))
164     (forward
165      (article-begin . "^-+ \\(Start of \\)?forwarded message.*\n+")
166      (body-end . "^-+ End \\(of \\)?forwarded message.*$")
167      (prepare-body-function . nndoc-unquote-dashes))
168     (mail-in-mail ;; Wild guess on mailer daemon's messages or others
169      (article-begin-function . nndoc-mail-in-mail-article-begin))
170     (guess
171      (guess . t)
172      (subtype nil))
173     (digest
174      (guess . t)
175      (subtype nil))
176     (preprints
177      (guess . t)
178      (subtype nil))))
179
180 (defvar nndoc-binary-file-names ".[Dd][Bb][Xx]$"
181   "Regexp for binary nndoc file names.")
182
183 \f
184 (defvoo nndoc-file-begin nil)
185 (defvoo nndoc-first-article nil)
186 (defvoo nndoc-article-begin nil)
187 (defvoo nndoc-head-begin nil)
188 (defvoo nndoc-head-end nil)
189 (defvoo nndoc-file-end nil)
190 (defvoo nndoc-body-begin nil)
191 (defvoo nndoc-body-end-function nil)
192 (defvoo nndoc-body-begin-function nil)
193 (defvoo nndoc-head-begin-function nil)
194 (defvoo nndoc-body-end nil)
195 ;; nndoc-dissection-alist is a list of sublists.  Each sublist holds the
196 ;; following items.  ARTICLE acts as the association key and is an ordinal
197 ;; starting at 1.  HEAD-BEGIN [0], HEAD-END [1], BODY-BEGIN [2] and BODY-END
198 ;; [3] are positions in the `nndoc' buffer.  LINE-COUNT [4] is a count of
199 ;; lines in the body.  For MIME dissections only, ARTICLE-INSERT [5] and
200 ;; SUMMARY-INSERT [6] give headers to insert for full article or summary line
201 ;; generation, respectively.  Other headers usually follow directly from the
202 ;; buffer.  Value nil means no insert.
203 (defvoo nndoc-dissection-alist nil)
204 (defvoo nndoc-prepare-body-function nil)
205 (defvoo nndoc-generate-head-function nil)
206 (defvoo nndoc-article-transform-function nil)
207 (defvoo nndoc-header-transform-function nil)
208 (defvoo nndoc-article-begin-function nil)
209 (defvoo nndoc-generate-article-function nil)
210 (defvoo nndoc-dissection-function nil)
211 (defvoo nndoc-pre-dissection-function nil)
212
213 (defvoo nndoc-status-string "")
214 (defvoo nndoc-group-alist nil)
215 (defvoo nndoc-current-buffer nil
216   "Current nndoc news buffer.")
217 (defvoo nndoc-address nil)
218
219 (defconst nndoc-version "nndoc 1.0"
220   "nndoc version.")
221
222 \f
223
224 ;;; Interface functions
225
226 (nnoo-define-basics nndoc)
227
228 (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
229   (when (nndoc-possibly-change-buffer newsgroup server)
230     (with-current-buffer nntp-server-buffer
231       (erase-buffer)
232       (let (article entry)
233         (if (stringp (car articles))
234             'headers
235           (while articles
236             (when (setq entry (cdr (assq (setq article (pop articles))
237                                          nndoc-dissection-alist)))
238               (let ((start (point)))
239                 (insert (format "221 %d Article retrieved.\n" article))
240                 (if nndoc-generate-head-function
241                     (funcall nndoc-generate-head-function article)
242                   (insert-buffer-substring
243                    nndoc-current-buffer (car entry) (nth 1 entry)))
244                 (goto-char (point-max))
245                 (unless (eq (char-after (1- (point))) ?\n)
246                   (insert "\n"))
247                 (insert (format "Lines: %d\n" (nth 4 entry)))
248                 (insert ".\n")
249                 (when nndoc-header-transform-function
250                   (save-excursion
251                     (save-restriction
252                       (narrow-to-region start (point))
253                       (funcall nndoc-header-transform-function entry)))))))
254           (nnheader-fold-continuation-lines)
255           'headers)))))
256
257 (deffoo nndoc-request-article (article &optional newsgroup server buffer)
258   (nndoc-possibly-change-buffer newsgroup server)
259   (save-excursion
260     (let ((buffer (or buffer nntp-server-buffer))
261           (entry (cdr (assq article nndoc-dissection-alist)))
262           beg)
263       (set-buffer buffer)
264       (erase-buffer)
265       (when entry
266         (cond
267          ((stringp article) nil)
268          (nndoc-generate-article-function
269           (funcall nndoc-generate-article-function article))
270          (t
271           (insert-buffer-substring
272            nndoc-current-buffer (car entry) (nth 1 entry))
273           (insert "\n")
274           (setq beg (point))
275           (insert-buffer-substring
276            nndoc-current-buffer (nth 2 entry) (nth 3 entry))
277           (goto-char beg)
278           (when nndoc-prepare-body-function
279             (funcall nndoc-prepare-body-function))
280           (when nndoc-article-transform-function
281             (funcall nndoc-article-transform-function article))
282           t))))))
283
284 (deffoo nndoc-request-group (group &optional server dont-check info)
285   "Select news GROUP."
286   (let (number)
287     (cond
288      ((not (nndoc-possibly-change-buffer group server))
289       (nnheader-report 'nndoc "No such file or buffer: %s"
290                        nndoc-address))
291      (dont-check
292       (nnheader-report 'nndoc "Selected group %s" group)
293       t)
294      ((zerop (setq number (length nndoc-dissection-alist)))
295       (nndoc-close-group group)
296       (nnheader-report 'nndoc "No articles in group %s" group))
297      (t
298       (nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
299
300 (deffoo nndoc-retrieve-groups (groups &optional server)
301   (dolist (group groups)
302     (nndoc-request-group group server))
303   t)
304
305 (deffoo nndoc-request-type (group &optional article)
306   (cond ((not article) 'unknown)
307         (nndoc-post-type nndoc-post-type)
308         (t 'unknown)))
309
310 (deffoo nndoc-close-group (group &optional server)
311   (nndoc-possibly-change-buffer group server)
312   (and nndoc-current-buffer
313        (buffer-name nndoc-current-buffer)
314        (kill-buffer nndoc-current-buffer))
315   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
316                                 nndoc-group-alist))
317   (setq nndoc-current-buffer nil)
318   (nnoo-close-server 'nndoc server)
319   (setq nndoc-dissection-alist nil)
320   t)
321
322 (deffoo nndoc-request-list (&optional server)
323   t)
324
325 (deffoo nndoc-request-newgroups (date &optional server)
326   nil)
327
328 (deffoo nndoc-request-list-newsgroups (&optional server)
329   nil)
330
331 \f
332 ;;; Internal functions.
333
334 (defun nndoc-possibly-change-buffer (group source)
335   (let (buf)
336     (cond
337      ;; The current buffer is this group's buffer.
338      ((and nndoc-current-buffer
339            (buffer-name nndoc-current-buffer)
340            (eq nndoc-current-buffer
341                (setq buf (cdr (assoc group nndoc-group-alist))))))
342      ;; We change buffers by taking an old from the group alist.
343      ;; `source' is either a string (a file name) or a buffer object.
344      (buf
345       (setq nndoc-current-buffer buf))
346      ;; It's a totally new group.
347      ((or (and (bufferp nndoc-address)
348                (buffer-name nndoc-address))
349           (and (stringp nndoc-address)
350                (file-exists-p nndoc-address)
351                (not (file-directory-p nndoc-address))))
352       (push (cons group (setq nndoc-current-buffer
353                               (get-buffer-create
354                                (concat " *nndoc " group "*"))))
355             nndoc-group-alist)
356       (setq nndoc-dissection-alist nil)
357       (with-current-buffer nndoc-current-buffer
358         (erase-buffer)
359         (if (and (stringp nndoc-address)
360                  (string-match nndoc-binary-file-names nndoc-address))
361             (let ((coding-system-for-read 'binary))
362               (mm-insert-file-contents nndoc-address))
363           (if (stringp nndoc-address)
364               (nnheader-insert-file-contents nndoc-address)
365             (insert-buffer-substring nndoc-address))
366           (run-hooks 'nndoc-open-document-hook)))))
367     ;; Initialize the nndoc structures according to this new document.
368     (when (and nndoc-current-buffer
369                (not nndoc-dissection-alist))
370       (with-current-buffer nndoc-current-buffer
371         (nndoc-set-delims)
372         (if (eq nndoc-article-type 'mime-parts)
373             (nndoc-dissect-mime-parts)
374           (nndoc-dissect-buffer))))
375     (unless nndoc-current-buffer
376       (nndoc-close-server))
377     ;; Return whether we managed to select a file.
378     nndoc-current-buffer))
379
380 ;;;
381 ;;; Deciding what document type we have
382 ;;;
383
384 (defun nndoc-set-delims ()
385   "Set the nndoc delimiter variables according to the type of the document."
386   (let ((vars '(nndoc-file-begin
387                 nndoc-first-article
388                 nndoc-article-begin-function
389                 nndoc-head-begin nndoc-head-end
390                 nndoc-file-end nndoc-article-begin
391                 nndoc-body-begin nndoc-body-end-function nndoc-body-end
392                 nndoc-prepare-body-function nndoc-article-transform-function
393                 nndoc-header-transform-function
394                 nndoc-generate-head-function nndoc-body-begin-function
395                 nndoc-head-begin-function
396                 nndoc-generate-article-function
397                 nndoc-dissection-function
398                 nndoc-pre-dissection-function)))
399     (while vars
400       (set (pop vars) nil)))
401   (let (defs)
402     ;; Guess away until we find the real file type.
403     (while (assq 'guess (setq defs (cdr (assq nndoc-article-type
404                                               nndoc-type-alist))))
405       (setq nndoc-article-type (nndoc-guess-type nndoc-article-type)))
406     ;; Set the nndoc variables.
407     (while defs
408       (set (intern (format "nndoc-%s" (caar defs)))
409            (cdr (pop defs))))))
410
411 (defun nndoc-guess-type (subtype)
412   (let ((alist nndoc-type-alist)
413         results result entry)
414     (while (and (not result)
415                 (setq entry (pop alist)))
416       (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess)))
417         (goto-char (point-min))
418         ;; Remove blank lines.
419         (while (eq (following-char) ?\n)
420           (delete-char 1))
421         (when (numberp (setq result (funcall (intern
422                                               (format "nndoc-%s-type-p"
423                                                       (car entry))))))
424           (push (cons result entry) results)
425           (setq result nil))))
426     (unless (or result results)
427       (error "Document is not of any recognized type"))
428     (if result
429         (car entry)
430       (cadar (last (sort results 'car-less-than-car))))))
431
432 ;;;
433 ;;; Built-in type predicates and functions
434 ;;;
435
436 (defun nndoc-mbox-type-p ()
437   (when (looking-at message-unix-mail-delimiter)
438     t))
439
440 (defun nndoc-mbox-article-begin ()
441   (when (re-search-forward (concat "^" message-unix-mail-delimiter) nil t)
442     (goto-char (match-beginning 0))))
443
444 (defun nndoc-mbox-body-end ()
445   (let ((beg (point))
446         len end)
447     (when
448         (save-excursion
449           (and (re-search-backward
450                 (concat "^" message-unix-mail-delimiter) nil t)
451                (setq end (point))
452                (search-forward "\n\n" beg t)
453                (re-search-backward
454                 "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
455                (setq len (string-to-number (match-string 1)))
456                (search-forward "\n\n" beg t)
457                (unless (= (setq len (+ (point) len)) (point-max))
458                  (and (< len (point-max))
459                       (goto-char len)
460                       (looking-at message-unix-mail-delimiter)))))
461       (goto-char len))))
462
463 (defun nndoc-mmdf-type-p ()
464   (when (looking-at "\^A\^A\^A\^A$")
465     t))
466
467 (defun nndoc-debbugs-db-type-p ()
468   (when (looking-at "\006$")
469     t))
470
471 (defun nndoc-news-type-p ()
472   (when (looking-at "^Path:.*\n")
473     t))
474
475 (defun nndoc-rnews-type-p ()
476   (when (looking-at "#! *rnews")
477     t))
478
479 (defun nndoc-rnews-body-end ()
480   (and (re-search-backward nndoc-article-begin nil t)
481        (forward-line 1)
482        (goto-char (+ (point) (string-to-number (match-string 1))))))
483
484 (defun nndoc-google-type-p ()
485   (when (re-search-forward "^=3D=3D 1 of [0-9]+ =3D=3D$" nil t)
486     t))
487
488 (defun nndoc-decode-content-transfer-encoding ()
489   (let ((encoding
490          (save-restriction
491            (message-narrow-to-head)
492            (message-fetch-field "content-transfer-encoding"))))
493     (when (and encoding
494                (search-forward "\n\n" nil t))
495       (save-restriction
496         (narrow-to-region (point) (point-max))
497         (mm-decode-content-transfer-encoding
498          (intern (downcase (mail-header-strip encoding))))))))
499
500 (defun nndoc-babyl-type-p ()
501   (when (re-search-forward "\^_\^L *\n" nil t)
502     t))
503
504 (defun nndoc-babyl-body-begin ()
505   (re-search-forward "^\n" nil t)
506   (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
507     (let ((next (or (save-excursion
508                       (re-search-forward nndoc-article-begin nil t))
509                     (point-max))))
510       (unless (re-search-forward "^\n" next t)
511         (goto-char next)
512         (forward-line -1)
513         (insert "\n")
514         (forward-line -1)))))
515
516 (defun nndoc-babyl-head-begin ()
517   (when (re-search-forward "^[0-9].*\n" nil t)
518     (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
519       (forward-line 1))
520     t))
521
522 (defun nndoc-forward-type-p ()
523   (when (and (re-search-forward "^-+ \\(Start of \\)?forwarded message.*\n+"
524                                 nil t)
525              (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:\\|^>?From "))
526     t))
527
528 (defun nndoc-rfc934-type-p ()
529   (when (and (re-search-forward "^-+ Start of forwarded.*\n+" nil t)
530              (not (re-search-forward "^Subject:.*digest" nil t))
531              (not (re-search-backward "^From:" nil t 2))
532              (not (re-search-forward "^From:" nil t 2)))
533     t))
534
535 (defun nndoc-mailman-type-p ()
536   (when (re-search-forward "^--__--__--\n+" nil t)
537     t))
538
539 (defun nndoc-rfc822-forward-type-p ()
540   (save-restriction
541     (message-narrow-to-head)
542     (when (re-search-forward "^Content-Type: *message/rfc822" nil t)
543       t)))
544
545 (defun nndoc-rfc822-forward-body-end-function ()
546   (goto-char (point-max)))
547
548 (defun nndoc-rfc822-forward-generate-article (article &optional head)
549   (let ((entry (cdr (assq article nndoc-dissection-alist)))
550         (begin (point))
551         encoding)
552     (with-current-buffer nndoc-current-buffer
553       (save-restriction
554         (message-narrow-to-head)
555         (setq encoding (message-fetch-field "content-transfer-encoding"))))
556     (insert-buffer-substring nndoc-current-buffer (car entry) (nth 3 entry))
557     (when encoding
558       (save-restriction
559         (narrow-to-region begin (point-max))
560         (mm-decode-content-transfer-encoding
561          (intern (downcase (mail-header-strip encoding))))))
562     (when head
563       (goto-char begin)
564       (when (search-forward "\n\n" nil t)
565         (delete-region (1- (point)) (point-max)))))
566   t)
567
568 (defun nndoc-rfc822-forward-generate-head (article)
569   (nndoc-rfc822-forward-generate-article article 'head))
570
571 (defun nndoc-mime-parts-type-p ()
572   (let ((case-fold-search t)
573         (limit (search-forward "\n\n" nil t)))
574     (goto-char (point-min))
575     (when (and limit
576                (re-search-forward
577                 (concat "\
578 ^Content-Type:[ \t]*multipart/[a-z]+ *; *\\(\\(\n[ \t]\\)?.*;\\)*"
579                         "\\(\n[ \t]\\)?[ \t]*boundary=\"?[^\"\n]*[^\" \t\n]")
580                 limit t))
581       t)))
582
583 (defun nndoc-transform-mime-parts (article)
584   (let* ((entry (cdr (assq article nndoc-dissection-alist)))
585          (headers (nth 5 entry)))
586     (when headers
587       (goto-char (point-min))
588       (insert headers))))
589
590 (defun nndoc-generate-mime-parts-head (article)
591   (let* ((entry (cdr (assq article nndoc-dissection-alist)))
592          (headers (nth 6 entry)))
593     (save-restriction
594       (narrow-to-region (point) (point))
595       (insert-buffer-substring
596        nndoc-current-buffer (car entry) (nth 1 entry))
597       (goto-char (point-max)))
598     (when headers
599       (insert headers))))
600
601 (defun nndoc-clari-briefs-type-p ()
602   (when (let ((case-fold-search nil))
603           (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
604     t))
605
606 (defun nndoc-transform-clari-briefs (article)
607   (goto-char (point-min))
608   (when (looking-at " *\\*\\(.*\\)\n")
609     (replace-match "" t t))
610   (nndoc-generate-clari-briefs-head article))
611
612 (defun nndoc-generate-clari-briefs-head (article)
613   (let ((entry (cdr (assq article nndoc-dissection-alist)))
614         subject from)
615     (with-current-buffer nndoc-current-buffer
616       (save-restriction
617         (narrow-to-region (car entry) (nth 3 entry))
618         (goto-char (point-min))
619         (when (looking-at " *\\*\\(.*\\)$")
620           (setq subject (match-string 1))
621           (when (string-match "[ \t]+$" subject)
622             (setq subject (substring subject 0 (match-beginning 0)))))
623         (when
624             (let ((case-fold-search nil))
625               (re-search-forward
626                "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
627           (setq from (match-string 1)))))
628     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
629             "\nSubject: " (or subject "(no subject)") "\n")))
630
631 (defun nndoc-exim-bounce-type-p ()
632   (and (re-search-forward "^------ This is a copy of the message, including all the headers. ------" nil t)
633        t))
634
635 (defun nndoc-exim-bounce-body-end-function ()
636   (goto-char (point-max)))
637
638
639 (defun nndoc-mime-digest-type-p ()
640   (let ((case-fold-search t)
641         boundary-id b-delimiter entry)
642     (when (and
643            (re-search-forward
644             (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
645                     "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
646             nil t)
647            (match-beginning 1))
648       (setq boundary-id (match-string 1)
649             b-delimiter (concat "\n--" boundary-id "[ \t]*$"))
650       (setq entry (assq 'mime-digest nndoc-type-alist))
651       (setcdr entry
652               (list
653                (cons 'head-begin "^ ?\n")
654                (cons 'head-end "^ ?$")
655                (cons 'body-begin "^ ?\n")
656                (cons 'article-begin b-delimiter)
657                (cons 'body-end-function 'nndoc-digest-body-end)
658                (cons 'file-end (concat "^--" boundary-id "--[ \t]*$"))))
659       t)))
660
661 (defun nndoc-standard-digest-type-p ()
662   (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
663              (re-search-forward
664               (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
665     t))
666
667 (defun nndoc-digest-body-end ()
668   (and (re-search-forward nndoc-article-begin nil t)
669        (goto-char (match-beginning 0))))
670
671 (defun nndoc-slack-digest-type-p ()
672   0)
673
674 (defun nndoc-git-type-p ()
675   (and (search-forward "\n- Log ---" nil t)
676        (search-forward "\ncommit " nil t)
677        (search-forward "\nAuthor: " nil t)))
678
679 (defun nndoc-transform-git-article (article)
680   (goto-char (point-min))
681   (when (re-search-forward "^Author: " nil t)
682     (replace-match "From: " t t)))
683
684 (defun nndoc-transform-git-headers (entry)
685   (goto-char (point-min))
686   (when (re-search-forward "^Author: " nil t)
687     (replace-match "From: " t t))
688   (let (subject)
689     (with-current-buffer nndoc-current-buffer
690       (goto-char (car entry))
691       (when (search-forward "\n\n" nil t)
692         (setq subject (buffer-substring (point) (line-end-position)))))
693     (when subject
694       (goto-char (point-min))
695       (forward-line 1)
696       (insert (format "Subject: %s\n" subject)))))
697
698 (defun nndoc-lanl-gov-announce-type-p ()
699   (when (let ((case-fold-search nil))
700           (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+\\|arXiv:\\)" nil t))
701     t))
702
703 (defun nndoc-transform-lanl-gov-announce (article)
704   (let ((case-fold-search nil))
705     (goto-char (point-max))
706     (when (re-search-backward "^\\\\\\\\ +( *\\([^ ]*\\) , *\\([^ ]*\\))" nil t)
707       (replace-match "\n\nGet it at \\1 (\\2)" t nil))
708     (goto-char (point-min))
709     (while (re-search-forward "^\\\\\\\\$" nil t)
710       (replace-match "" t nil))
711     (goto-char (point-min))
712     (when (re-search-forward "^replaced with revised version +\\(.*[^ ]\\) +" nil t)
713       (replace-match "Date: \\1 (revised) " t nil))
714     (goto-char (point-min))
715     (unless (re-search-forward "^From" nil t)
716       (goto-char (point-min))
717       (when (re-search-forward "^Authors?: \\(.*\\)" nil t)
718         (goto-char (point-min))
719         (insert "From: " (match-string 1) "\n")))
720     (when (re-search-forward "^arXiv:" nil t)
721       (replace-match "Paper: arXiv:" t nil))))
722
723 (defun nndoc-generate-lanl-gov-head (article)
724   (let ((entry (cdr (assq article nndoc-dissection-alist)))
725         (from "<no address given>")
726         subject date)
727     (with-current-buffer nndoc-current-buffer
728       (save-restriction
729         (narrow-to-region (car entry) (nth 1 entry))
730         (goto-char (point-min))
731         (when (looking-at "^\\(Paper.*: \\|arXiv:\\)\\([0-9a-zA-Z-\\./]+\\)")
732           (setq subject (concat " (" (match-string 2) ")"))
733           (when (re-search-forward "^From: \\(.*\\)" nil t)
734             (setq from (concat "<"
735                                (cadr (funcall gnus-extract-address-components
736                                               (match-string 1))) ">")))
737           (if (re-search-forward "^Date: +\\([^(]*\\)" nil t)
738               (setq date (match-string 1))
739             (when (re-search-forward "^replaced with revised version +\\([^(]*\\)" nil t)
740               (setq date (match-string 1))))
741           (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)"
742                                    nil t)
743             (setq subject (concat (match-string 1) subject))
744             (setq from (concat (match-string 2) " " from))))))
745     (while (and from (string-match "([^)]*)" from))
746       (setq from (replace-match "" t t from)))
747     (insert "From: "  (or from "unknown")
748             "\nSubject: " (or subject "(no subject)") "\n")
749     (if date (insert "Date: " date))))
750
751 (defun nndoc-nsmail-type-p ()
752   (when (looking-at "From - ")
753     t))
754
755 (defun nndoc-outlook-article-begin ()
756   (prog1 (re-search-forward "From:\\|Received:" nil t)
757     (goto-char (match-beginning 0))))
758
759 (defun nndoc-outlook-type-p ()
760   ;; FIXME: Is JMF the magic of outlook mailbox? -- ShengHuo.
761   (looking-at "JMF"))
762
763 (defun nndoc-oe-dbx-type-p ()
764   (looking-at (mm-string-to-multibyte "\317\255\022\376")))
765
766 (defun nndoc-read-little-endian ()
767   (+ (prog1 (char-after) (forward-char 1))
768      (lsh (prog1 (char-after) (forward-char 1)) 8)
769      (lsh (prog1 (char-after) (forward-char 1)) 16)
770      (lsh (prog1 (char-after) (forward-char 1)) 24)))
771
772 (defun nndoc-oe-dbx-decode-block ()
773   (list
774    (nndoc-read-little-endian)   ;; this address
775    (nndoc-read-little-endian)   ;; next address offset
776    (nndoc-read-little-endian)   ;; blocksize
777    (nndoc-read-little-endian))) ;; next address
778
779 (defun nndoc-oe-dbx-dissection ()
780   (let ((i 0) blk p tp)
781     (goto-char 60117) ;; 0x0000EAD4+1
782     (setq p (point))
783     (unless (eobp)
784       (setq blk (nndoc-oe-dbx-decode-block)))
785     (while (and blk (> (car blk) 0) (or (zerop (nth 3 blk))
786                                         (> (nth 3 blk) p)))
787       (push (list (incf i) p nil nil nil 0) nndoc-dissection-alist)
788       (while (and (> (car blk) 0) (> (nth 3 blk) p))
789         (goto-char (1+ (nth 3 blk)))
790         (setq blk (nndoc-oe-dbx-decode-block)))
791       (if (or (<= (car blk) p)
792               (<= (nth 1 blk) 0)
793               (not (zerop (nth 3 blk))))
794           (setq blk nil)
795         (setq tp (+ (car blk) (nth 1 blk) 17))
796         (if (or (<= tp p) (>= tp (point-max)))
797             (setq blk nil)
798           (goto-char tp)
799           (setq p tp
800                 blk (nndoc-oe-dbx-decode-block)))))))
801
802 (defun nndoc-oe-dbx-generate-article (article &optional head)
803   (let ((entry (cdr (assq article nndoc-dissection-alist)))
804         (cur (current-buffer))
805         (begin (point))
806         blk p)
807     (with-current-buffer nndoc-current-buffer
808       (setq p (car entry))
809       (while (> p (point-min))
810         (goto-char p)
811         (setq blk (nndoc-oe-dbx-decode-block))
812         (setq p (point))
813         (with-current-buffer cur
814           (insert-buffer-substring nndoc-current-buffer p (+ p (nth 2 blk))))
815         (setq p (1+ (nth 3 blk)))))
816     (goto-char begin)
817     (while (re-search-forward "\r$" nil t)
818       (delete-char -1))
819     (when head
820       (goto-char begin)
821       (when (search-forward "\n\n" nil t)
822         (setcar (cddddr entry) (count-lines (point) (point-max)))
823         (delete-region (1- (point)) (point-max))))
824     t))
825
826 (defun nndoc-oe-dbx-generate-head (article)
827   (nndoc-oe-dbx-generate-article article 'head))
828
829 (defun nndoc-mail-in-mail-type-p ()
830   (let (found)
831     (save-excursion
832       (catch 'done
833         (while (re-search-forward "\n\n[-A-Za-z0-9]+:" nil t)
834           (setq found 0)
835           (forward-line)
836           (while (looking-at "[ \t]\\|[-A-Za-z0-9]+:")
837             (if (looking-at "[-A-Za-z0-9]+:")
838                 (setq found (1+ found)))
839             (forward-line))
840           (if (and (> found 0) (looking-at "\n"))
841               (throw 'done 9999)))
842         nil))))
843
844 (defun nndoc-mail-in-mail-article-begin ()
845   (let (point found)
846     (if (catch 'done
847           (while (re-search-forward "\n\n\\([-A-Za-z0-9]+:\\)" nil t)
848             (setq found 0)
849             (setq point (match-beginning 1))
850             (forward-line)
851             (while (looking-at "[ \t]\\|[-A-Za-z0-9]+:")
852               (if (looking-at "[-A-Za-z0-9]+:")
853                   (setq found (1+ found)))
854               (forward-line))
855             (if (and (> found 0) (looking-at "\n"))
856                 (throw 'done t)))
857           nil)
858         (goto-char point))))
859
860 (deffoo nndoc-request-accept-article (group &optional server last)
861   nil)
862
863 ;;;
864 ;;; Functions for dissecting the documents
865 ;;;
866
867 (defun nndoc-search (regexp)
868   (prog1
869       (re-search-forward regexp nil t)
870     (beginning-of-line)))
871
872 (defun nndoc-dissect-buffer ()
873   "Go through the document and partition it into heads/bodies/articles."
874   (let ((i 0)
875         (first t)
876         art-begin head-begin head-end body-begin body-end)
877     (setq nndoc-dissection-alist nil)
878     (with-current-buffer nndoc-current-buffer
879       (goto-char (point-min))
880       ;; Remove blank lines.
881       (while (eq (following-char) ?\n)
882         (delete-char 1))
883       (when nndoc-pre-dissection-function
884         (save-excursion
885           (funcall nndoc-pre-dissection-function)))
886       (if nndoc-dissection-function
887           (funcall nndoc-dissection-function)
888         ;; Find the beginning of the file.
889         (when nndoc-file-begin
890           (nndoc-search nndoc-file-begin))
891         ;; Go through the file.
892         (while (if (and first nndoc-first-article)
893                    (nndoc-search nndoc-first-article)
894                  (if art-begin
895                      (goto-char art-begin)
896                    (nndoc-article-begin)))
897           (setq first nil
898                 art-begin nil)
899           (cond (nndoc-head-begin-function
900                  (funcall nndoc-head-begin-function))
901                 (nndoc-head-begin
902                  (nndoc-search nndoc-head-begin)))
903           (if (or (eobp)
904                   (and nndoc-file-end
905                        (looking-at nndoc-file-end)))
906               (goto-char (point-max))
907             (setq head-begin (point))
908             (nndoc-search (or nndoc-head-end "^$"))
909             (setq head-end (point))
910             (if nndoc-body-begin-function
911                 (funcall nndoc-body-begin-function)
912               (nndoc-search (or nndoc-body-begin "^\n")))
913             (setq body-begin (point))
914             (or (and nndoc-body-end-function
915                      (funcall nndoc-body-end-function))
916                 (and nndoc-body-end
917                      (nndoc-search nndoc-body-end))
918                 (and (nndoc-article-begin)
919                      (setq art-begin (point)))
920                 (progn
921                   (goto-char (point-max))
922                   (when nndoc-file-end
923                     (and (re-search-backward nndoc-file-end nil t)
924                          (beginning-of-line)))))
925             (setq body-end (point))
926             (push (list (incf i) head-begin head-end body-begin body-end
927                         (count-lines body-begin body-end))
928                   nndoc-dissection-alist)))))
929     (setq nndoc-dissection-alist (nreverse nndoc-dissection-alist))))
930
931 (defun nndoc-article-begin ()
932   (if nndoc-article-begin-function
933       (funcall nndoc-article-begin-function)
934     (ignore-errors
935       (nndoc-search nndoc-article-begin))))
936
937 (defun nndoc-unquote-dashes ()
938   "Unquote quoted non-separators in digests."
939   (while (re-search-forward "^- -"nil t)
940     (replace-match "-" t t)))
941
942 ;; Against compiler warnings.
943 (defvar nndoc-mime-split-ordinal)
944
945 (defun nndoc-dissect-mime-parts ()
946   "Go through a MIME composite article and partition it into sub-articles.
947 When a MIME entity contains sub-entities, dissection produces one article for
948 the header of this entity, and one article per sub-entity."
949   (setq nndoc-dissection-alist nil
950         nndoc-mime-split-ordinal 0)
951   (with-current-buffer nndoc-current-buffer
952     (nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil)))
953
954 (defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert
955                                                 position parent)
956   "Dissect an entity, within a composite MIME message.
957 The complete message or MIME entity extends from HEAD-BEGIN to BODY-END.
958 ARTICLE-INSERT should be added at beginning for generating a full article.
959 The string POSITION holds a dotted decimal representation of the article
960 position in the hierarchical structure, it is nil for the outer entity.
961 PARENT is the message-ID of the parent summary line, or nil for none."
962   (let ((case-fold-search t)
963         (message-id (nnmail-message-id))
964         head-end body-begin summary-insert message-rfc822 multipart-any
965         subject content-type type subtype boundary-regexp)
966     ;; Gracefully handle a missing body.
967     (goto-char head-begin)
968     (if (or (and (eq (char-after) ?\n) (or (forward-char 1) t))
969             (search-forward "\n\n" body-end t))
970         (setq head-end (1- (point))
971               body-begin (point))
972       (setq head-end body-end
973             body-begin body-end))
974     (narrow-to-region head-begin head-end)
975     ;; Save MIME attributes.
976     (goto-char head-begin)
977     (setq content-type (message-fetch-field "Content-Type"))
978     (when content-type
979       (when (string-match
980              "^ *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" content-type)
981         (setq type (downcase (match-string 1 content-type))
982               subtype (downcase (match-string 2 content-type))
983               message-rfc822 (and (string= type "message")
984                                   (string= subtype "rfc822"))
985               multipart-any (string= type "multipart")))
986       (when (string-match ";[ \t\n]*name=\\([^ \t\n;]+\\)" content-type)
987         (setq subject (match-string 1 content-type)))
988       (when (string-match "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)" content-type)
989         (setq boundary-regexp (concat "^--"
990                                       (regexp-quote
991                                        (match-string 1 content-type))
992                                       "\\(--\\)?[ \t]*\n"))))
993     (unless subject
994       (when (or multipart-any (not article-insert))
995         (setq subject (message-fetch-field "Subject"))))
996     (unless type
997       (setq type "text"
998             subtype "plain"))
999     ;; Prepare the article and summary inserts.
1000     (unless article-insert
1001       (setq article-insert (buffer-string)
1002             head-end head-begin))
1003     ;; Fix MIME-Version
1004     (unless (string-match "MIME-Version:" article-insert)
1005       (setq article-insert
1006             (concat article-insert "MIME-Version: 1.0\n")))
1007     (setq summary-insert article-insert)
1008     ;; - summary Subject.
1009     (setq summary-insert
1010           (let ((line (concat "Subject: <" position
1011                               (and position multipart-any ".")
1012                               (and multipart-any "*")
1013                               (and (or position multipart-any) " ")
1014                               (cond ((string= subtype "plain") type)
1015                                     ((string= subtype "basic") type)
1016                                     (t subtype))
1017                               ">"
1018                               (and subject " ")
1019                               subject
1020                               "\n")))
1021             (if (string-match "Subject:.*\n\\([ \t].*\n\\)*" summary-insert)
1022                 (replace-match line t t summary-insert)
1023               (concat summary-insert line))))
1024     ;; - summary Message-ID.
1025     (setq summary-insert
1026           (let ((line (concat "Message-ID: " message-id "\n")))
1027             (if (string-match "Message-ID:.*\n\\([ \t].*\n\\)*" summary-insert)
1028                 (replace-match line t t summary-insert)
1029               (concat summary-insert line))))
1030     ;; - summary References.
1031     (when parent
1032       (setq summary-insert
1033             (let ((line (concat "References: " parent "\n")))
1034               (if (string-match "References:.*\n\\([ \t].*\n\\)*"
1035                                 summary-insert)
1036                   (replace-match line t t summary-insert)
1037                 (concat summary-insert line)))))
1038     ;; Generate dissection information for this entity.
1039     (push (list (incf nndoc-mime-split-ordinal)
1040                 head-begin head-end body-begin body-end
1041                 (count-lines body-begin body-end)
1042                 article-insert summary-insert)
1043           nndoc-dissection-alist)
1044     ;; Recurse for all sub-entities, if any.
1045     (widen)
1046     (cond
1047      (message-rfc822
1048       (save-excursion
1049         (nndoc-dissect-mime-parts-sub body-begin body-end nil
1050                                       position message-id)))
1051      ((and multipart-any boundary-regexp)
1052       (let ((part-counter 0)
1053             part-begin part-end eof-flag)
1054         (while (string-match "\
1055 ^\\(Lines\\|Content-\\(Type\\|Transfer-Encoding\\|Disposition\\)\\):.*\n\\([ \t].*\n\\)*"
1056                              article-insert)
1057           (setq article-insert (replace-match "" t t article-insert)))
1058         (let ((case-fold-search nil))
1059           (goto-char body-begin)
1060           (setq eof-flag (not (re-search-forward boundary-regexp body-end t)))
1061           (while (not eof-flag)
1062             (setq part-begin (point))
1063             (cond ((re-search-forward boundary-regexp body-end t)
1064                    (or (not (match-string 1))
1065                        (string= (match-string 1) "")
1066                        (setq eof-flag t))
1067                    (forward-line -1)
1068                    (setq part-end (point))
1069                    (forward-line 1))
1070                   (t (setq part-end body-end
1071                            eof-flag t)))
1072             (save-excursion
1073               (nndoc-dissect-mime-parts-sub
1074                part-begin part-end article-insert
1075                (concat position
1076                        (and position ".")
1077                        (format "%d" (incf part-counter)))
1078                message-id)))))))))
1079
1080 ;;;###autoload
1081 (defun nndoc-add-type (definition &optional position)
1082   "Add document DEFINITION to the list of nndoc document definitions.
1083 If POSITION is nil or `last', the definition will be added
1084 as the last checked definition, if t or `first', add as the
1085 first definition, and if any other symbol, add after that
1086 symbol in the alist."
1087   ;; First remove any old instances.
1088   (gnus-alist-pull (car definition) nndoc-type-alist)
1089   ;; Then enter the new definition in the proper place.
1090   (cond
1091    ((or (null position) (eq position 'last))
1092     (setq nndoc-type-alist (nconc nndoc-type-alist (list definition))))
1093    ((or (eq position t) (eq position 'first))
1094     (push definition nndoc-type-alist))
1095    (t
1096     (let ((list (memq (assq position nndoc-type-alist)
1097                       nndoc-type-alist)))
1098       (unless list
1099         (error "No such position: %s" position))
1100       (setcdr list (cons definition (cdr list)))))))
1101
1102 (provide 'nndoc)
1103
1104 ;;; nndoc.el ends here