*** empty log message ***
[gnus] / lisp / nndoc.el
1 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
2
3 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
4 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5 ;; Keywords: news
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;;; Code:
27
28 (require 'nnheader)
29 (require 'message)
30 (require 'nnmail)
31 (require 'nnoo)
32 (eval-when-compile (require 'cl))
33
34 (nnoo-declare nndoc)
35
36 (defvoo nndoc-article-type 'guess
37   "*Type of the file.
38 One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
39 `mime-digest', `standard-digest', `slack-digest', `clari-briefs' or
40 `guess'.")
41
42 (defvoo nndoc-post-type 'mail
43   "*Whether the nndoc group is `mail' or `post'.")
44
45 (defvar nndoc-type-alist 
46   `((mmdf 
47      (article-begin .  "^\^A\^A\^A\^A\n")
48      (body-end .  "^\^A\^A\^A\^A\n"))
49     (news
50      (article-begin . "^Path:"))
51     (rnews
52      (article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
53      (body-end-function . nndoc-rnews-body-end))
54     (mbox 
55      (article-begin . 
56                     ,(let ((delim (concat "^" message-unix-mail-delimiter)))
57                        (if (string-match "\n\\'" delim)
58                            (substring delim 0 (match-beginning 0))
59                          delim)))
60      (body-end-function . nndoc-mbox-body-end))
61     (babyl 
62      (article-begin . "\^_\^L *\n")
63      (body-end . "\^_")
64      (body-begin-function . nndoc-babyl-body-begin)
65      (head-begin-function . nndoc-babyl-head-begin))
66     (forward
67      (article-begin . "^-+ Start of forwarded message -+\n+")
68      (body-end . "^-+ End of forwarded message -+$")
69      (prepare-body-function . nndoc-unquote-dashes))
70     (clari-briefs
71      (article-begin . "^ \\*")
72      (body-end . "^\t------*[ \t]^*\n^ \\*")
73      (body-begin . "^\t")
74      (head-end . "^\t")
75      (generate-head-function . nndoc-generate-clari-briefs-head)
76      (article-transform-function . nndoc-transform-clari-briefs))
77     (mime-digest
78      (article-begin . "")
79      (head-end . "^ ?$")
80      (body-end . "")
81      (file-end . "")
82      (subtype digest guess))
83     (standard-digest
84      (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+"))
85      (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n+"))
86      (prepare-body-function . nndoc-unquote-dashes)
87      (body-end-function . nndoc-digest-body-end)
88      (head-end . "^ ?$")
89      (body-begin . "^ ?\n")
90      (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$")
91      (subtype digest guess))
92     (slack-digest
93      (article-begin . "^------------------------------*[\n \t]+")
94      (head-end . "^ ?$")
95      (body-end-function . nndoc-digest-body-end)
96      (body-begin . "^ ?$")
97      (file-end . "^End of")
98      (prepare-body-function . nndoc-unquote-dashes)
99      (subtype digest guess))
100     (lanl-gov-announce
101       (article-begin . "^\\\\\\\\\n")
102       (head-begin . "^Paper.*:")
103       (head-end   . "\\(^\\\\\\\\.*\n\\|-----------------\\)")
104       (body-begin . "")  
105       (body-end   . "-------------------------------------------------")     
106       (file-end   . "^Title: Recent Seminal")
107       (generate-head-function . nndoc-generate-lanl-gov-head)
108       (article-transform-function . nndoc-transform-lanl-gov-announce)
109       (subtype preprints guess))
110     (guess 
111      (guess . t)
112      (subtype nil))
113     (digest
114      (guess . t)
115      (subtype nil))
116     (preprints
117      (guess . t)
118      (subtype nil))
119     ))
120
121 \f
122
123 (defvoo nndoc-file-begin nil)
124 (defvoo nndoc-first-article nil)
125 (defvoo nndoc-article-end nil)
126 (defvoo nndoc-article-begin nil)
127 (defvoo nndoc-head-begin nil)
128 (defvoo nndoc-head-end nil)
129 (defvoo nndoc-file-end nil)
130 (defvoo nndoc-body-begin nil)
131 (defvoo nndoc-body-end-function nil)
132 (defvoo nndoc-body-begin-function nil)
133 (defvoo nndoc-head-begin-function nil)
134 (defvoo nndoc-body-end nil)
135 (defvoo nndoc-dissection-alist nil)
136 (defvoo nndoc-prepare-body-function nil)
137 (defvoo nndoc-generate-head-function nil)
138 (defvoo nndoc-article-transform-function nil)
139
140 (defvoo nndoc-status-string "")
141 (defvoo nndoc-group-alist nil)
142 (defvoo nndoc-current-buffer nil
143   "Current nndoc news buffer.")
144 (defvoo nndoc-address nil)
145
146 (defconst nndoc-version "nndoc 1.0"
147   "nndoc version.")
148
149 \f
150
151 ;;; Interface functions
152
153 (nnoo-define-basics nndoc)
154
155 (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
156   (when (nndoc-possibly-change-buffer newsgroup server)
157     (save-excursion
158       (set-buffer nntp-server-buffer)
159       (erase-buffer)
160       (let (article entry)
161         (if (stringp (car articles))
162             'headers
163           (while articles
164             (when (setq entry (cdr (assq (setq article (pop articles))
165                                          nndoc-dissection-alist)))
166               (insert (format "221 %d Article retrieved.\n" article))
167               (if nndoc-generate-head-function
168                   (funcall nndoc-generate-head-function article)
169                 (insert-buffer-substring
170                  nndoc-current-buffer (car entry) (nth 1 entry)))
171               (goto-char (point-max))
172               (or (= (char-after (1- (point))) ?\n) (insert "\n"))
173               (insert (format "Lines: %d\n" (nth 4 entry)))
174               (insert ".\n")))
175
176           (nnheader-fold-continuation-lines)
177           'headers)))))
178
179 (deffoo nndoc-request-article (article &optional newsgroup server buffer)
180   (nndoc-possibly-change-buffer newsgroup server)
181   (save-excursion
182     (let ((buffer (or buffer nntp-server-buffer))
183           (entry (cdr (assq article nndoc-dissection-alist)))
184           beg)
185       (set-buffer buffer)
186       (erase-buffer)
187       (if (stringp article)
188           nil
189         (insert-buffer-substring 
190          nndoc-current-buffer (car entry) (nth 1 entry))
191         (insert "\n")
192         (setq beg (point))
193         (insert-buffer-substring 
194          nndoc-current-buffer (nth 2 entry) (nth 3 entry))
195         (goto-char beg)
196         (when nndoc-prepare-body-function
197           (funcall nndoc-prepare-body-function))
198         (when nndoc-article-transform-function
199           (funcall nndoc-article-transform-function article))
200         t))))
201
202 (deffoo nndoc-request-group (group &optional server dont-check)
203   "Select news GROUP."
204   (let (number)
205     (cond 
206      ((not (nndoc-possibly-change-buffer group server))
207       (nnheader-report 'nndoc "No such file or buffer: %s"
208                        nndoc-address))
209      (dont-check
210       (nnheader-report 'nndoc "Selected group %s" group)
211       t)
212      ((zerop (setq number (length nndoc-dissection-alist)))
213       (nndoc-close-group group)
214       (nnheader-report 'nndoc "No articles in group %s" group))
215      (t
216       (nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
217
218 (deffoo nndoc-request-type (group &optional article)
219   (cond ((not article) 'unknown)
220         (nndoc-post-type nndoc-post-type)
221         (t 'unknown)))
222
223 (deffoo nndoc-close-group (group &optional server)
224   (nndoc-possibly-change-buffer group server)
225   (and nndoc-current-buffer
226        (buffer-name nndoc-current-buffer)
227        (kill-buffer nndoc-current-buffer))
228   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
229                                 nndoc-group-alist))
230   (setq nndoc-current-buffer nil)
231   (nnoo-close-server 'nndoc server)
232   (setq nndoc-dissection-alist nil)
233   t)
234
235 (deffoo nndoc-request-list (&optional server)
236   nil)
237
238 (deffoo nndoc-request-newgroups (date &optional server)
239   nil)
240
241 (deffoo nndoc-request-list-newsgroups (&optional server)
242   nil)
243
244 \f
245 ;;; Internal functions.
246
247 (defun nndoc-possibly-change-buffer (group source)
248   (let (buf)
249     (cond 
250      ;; The current buffer is this group's buffer.
251      ((and nndoc-current-buffer
252            (buffer-name nndoc-current-buffer)
253            (eq nndoc-current-buffer 
254                (setq buf (cdr (assoc group nndoc-group-alist))))))
255      ;; We change buffers by taking an old from the group alist.
256      ;; `source' is either a string (a file name) or a buffer object. 
257      (buf
258       (setq nndoc-current-buffer buf))
259      ;; It's a totally new group.    
260      ((or (and (bufferp nndoc-address)
261                (buffer-name nndoc-address))
262           (and (stringp nndoc-address)
263                (file-exists-p nndoc-address)
264                (not (file-directory-p nndoc-address))))
265       (push (cons group (setq nndoc-current-buffer 
266                               (get-buffer-create 
267                                (concat " *nndoc " group "*"))))
268             nndoc-group-alist)
269       (setq nndoc-dissection-alist nil)
270       (save-excursion
271         (set-buffer nndoc-current-buffer)
272         (buffer-disable-undo (current-buffer))
273         (erase-buffer)
274         (if (stringp nndoc-address)
275             (insert-file-contents nndoc-address)
276           (insert-buffer-substring nndoc-address)))))
277     ;; Initialize the nndoc structures according to this new document.
278     (when (and nndoc-current-buffer
279                (not nndoc-dissection-alist))
280       (save-excursion
281         (set-buffer nndoc-current-buffer)
282         (nndoc-set-delims)
283         (nndoc-dissect-buffer)))
284     (unless nndoc-current-buffer
285       (nndoc-close-server))
286     ;; Return whether we managed to select a file.
287     nndoc-current-buffer))
288
289 ;;;
290 ;;; Deciding what document type we have
291 ;;;
292
293 (defun nndoc-set-delims ()
294   "Set the nndoc delimiter variables according to the type of the document."
295   (let ((vars '(nndoc-file-begin 
296                 nndoc-first-article 
297                 nndoc-article-end nndoc-head-begin nndoc-head-end
298                 nndoc-file-end nndoc-article-begin
299                 nndoc-body-begin nndoc-body-end-function nndoc-body-end
300                 nndoc-prepare-body-function nndoc-article-transform-function
301                 nndoc-generate-head-function nndoc-body-begin-function
302                 nndoc-head-begin-function)))
303     (while vars
304       (set (pop vars) nil)))
305   (let (defs)
306     ;; Guess away until we find the real file type.
307     (while (assq 'guess (setq defs (cdr (assq nndoc-article-type 
308                                               nndoc-type-alist))))
309       (setq nndoc-article-type (nndoc-guess-type nndoc-article-type)))
310     ;; Set the nndoc variables.
311     (while defs
312       (set (intern (format "nndoc-%s" (caar defs)))
313            (cdr (pop defs))))))
314
315 (defun nndoc-guess-type (subtype)
316   (let ((alist nndoc-type-alist)
317         results result entry)
318     (while (and (not result)
319                 (setq entry (pop alist)))
320       (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess)))
321         (goto-char (point-min))
322         (when (numberp (setq result (funcall (intern
323                                               (format "nndoc-%s-type-p" 
324                                                       (car entry))))))
325           (push (cons result entry) results)
326           (setq result nil))))
327     (unless (or result results)
328       (error "Document is not of any recognized type"))
329     (if result
330         (car entry)
331       (cadar (sort results (lambda (r1 r2) (< (car r1) (car r2))))))))
332
333 ;;; 
334 ;;; Built-in type predicates and functions
335 ;;;
336
337 (defun nndoc-mbox-type-p ()
338   (when (looking-at message-unix-mail-delimiter)
339     t))
340
341 (defun nndoc-mbox-body-end ()
342   (let ((beg (point))
343         len end)
344     (when
345         (save-excursion
346           (and (re-search-backward nndoc-article-begin nil t)
347                (setq end (point))
348                (search-forward "\n\n" beg t)
349                (re-search-backward
350                 "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
351                (setq len (string-to-int (match-string 1)))
352                (search-forward "\n\n" beg t)
353                (or (= (setq len (+ (point) len)) (point-max))
354                    (and (< len (point-max))
355                         (goto-char len)
356                         (looking-at nndoc-article-begin)))))
357       (goto-char len))))
358
359 (defun nndoc-mmdf-type-p ()
360   (when (looking-at "\^A\^A\^A\^A$")
361     t))
362
363 (defun nndoc-news-type-p ()
364   (when (looking-at "^Path:.*\n")
365     t))
366
367 (defun nndoc-rnews-type-p ()
368   (when (looking-at "#! *rnews")
369     t))
370
371 (defun nndoc-rnews-body-end ()
372   (and (re-search-backward nndoc-article-begin nil t)
373        (forward-line 1)
374        (goto-char (+ (point) (string-to-int (match-string 1))))))
375
376 (defun nndoc-babyl-type-p ()
377   (when (re-search-forward "\^_\^L *\n" nil t)
378     t))
379
380 (defun nndoc-babyl-body-begin ()
381   (re-search-forward "^\n" nil t)
382   (when (looking-at "\*\*\* EOOH \*\*\*")
383     (let ((next (or (save-excursion
384                       (re-search-forward nndoc-article-begin nil t))
385                     (point-max))))
386       (unless (re-search-forward "^\n" next t)
387         (goto-char next)
388         (forward-line -1)
389         (insert "\n")
390         (forward-line -1)))))
391
392 (defun nndoc-babyl-head-begin ()
393   (when (re-search-forward "^[0-9].*\n" nil t)
394     (when (looking-at "\*\*\* EOOH \*\*\*")
395       (forward-line 1))
396     t))
397
398 (defun nndoc-forward-type-p ()
399   (when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
400              (not (re-search-forward "^Subject:.*digest" nil t)))
401     t))
402
403 (defun nndoc-clari-briefs-type-p ()
404   (when (let ((case-fold-search nil))
405           (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
406     t))
407
408 (defun nndoc-transform-clari-briefs (article)
409   (goto-char (point-min))
410   (when (looking-at " *\\*\\(.*\\)\n")
411     (replace-match "" t t))
412   (nndoc-generate-clari-briefs-head article))
413
414 (defun nndoc-generate-clari-briefs-head (article)
415   (let ((entry (cdr (assq article nndoc-dissection-alist)))
416         subject from)
417     (save-excursion
418       (set-buffer nndoc-current-buffer)
419       (save-restriction
420         (narrow-to-region (car entry) (nth 3 entry))
421         (goto-char (point-min))
422         (when (looking-at " *\\*\\(.*\\)$")
423           (setq subject (match-string 1))
424           (when (string-match "[ \t]+$" subject)
425             (setq subject (substring subject 0 (match-beginning 0)))))
426         (when
427             (let ((case-fold-search nil))
428               (re-search-forward
429                "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
430           (setq from (match-string 1)))))
431     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
432             "\nSubject: " (or subject "(no subject)") "\n")))
433
434 (defun nndoc-mime-digest-type-p ()
435   (let ((case-fold-search t)
436         boundary-id b-delimiter entry)
437      (when (and
438             (re-search-forward
439              (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
440                      "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
441              nil t)
442             (match-beginning 1))
443        (setq boundary-id (match-string 1)
444              b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
445        (setq entry (assq 'mime-digest nndoc-type-alist))
446        (setcdr entry
447                (list
448                 (cons 'head-end "^ ?$")
449                 (cons 'body-begin "^ ?\n")
450                 (cons 'article-begin b-delimiter)
451                 (cons 'body-end-function 'nndoc-digest-body-end)
452                 (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
453        t)))
454
455 (defun nndoc-standard-digest-type-p ()
456   (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
457              (re-search-forward 
458               (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
459     t))
460
461 (defun nndoc-digest-body-end ()
462   (and (re-search-forward nndoc-article-begin nil t)
463        (goto-char (match-beginning 0))))
464
465 (defun nndoc-slack-digest-type-p ()
466   0)
467
468 (defun nndoc-lanl-gov-announce-type-p ()
469   (when (let ((case-fold-search nil))
470           (re-search-forward "^\\\\\\\\\nPaper: [a-z-]+/[0-9]+" nil t))
471     t))
472
473 (defun nndoc-transform-lanl-gov-announce (article)
474   (goto-char (point-max))
475   (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t)
476     (replace-match "\n\nGet it at \\1 (\\2)" t nil))
477   ;;  (when (re-search-backward "^\\\\\\\\$" nil t)
478   ;;    (replace-match "" t t))
479   )
480  
481 (defun nndoc-generate-lanl-gov-head (article)
482   (let ((entry (cdr (assq article nndoc-dissection-alist)))
483         (e-mail "no address given")
484         subject from)
485     (save-excursion
486       (set-buffer nndoc-current-buffer)
487       (save-restriction
488         (narrow-to-region (car entry) (nth 1 entry))
489         (goto-char (point-min))
490         (when (looking-at "^Paper.*: \\([a-z-]+/[0-9]+\\)")
491           (setq subject (concat " (" (match-string 1) ")"))
492           (when (re-search-forward "^From: \\([^ ]+\\)" nil t)
493             (setq e-mail (match-string 1)))
494           (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)"
495                                    nil t)
496             (setq subject (concat (match-string 1) subject))
497             (setq from (concat (match-string 2) " <" e-mail ">"))))
498         ))
499     (while (and from (string-match "(\[^)\]*)" from))
500       (setq from (replace-match "" t t from)))
501     (insert "From: "  (or from "unknown")
502             "\nSubject: " (or subject "(no subject)") "\n")))
503  
504
505
506 ;;;
507 ;;; Functions for dissecting the documents
508 ;;;
509
510 (defun nndoc-search (regexp)
511   (prog1
512       (re-search-forward regexp nil t)
513     (beginning-of-line)))
514
515 (defun nndoc-dissect-buffer ()
516   "Go through the document and partition it into heads/bodies/articles."
517   (let ((i 0)
518         (first t)
519         head-begin head-end body-begin body-end)
520     (setq nndoc-dissection-alist nil)
521     (save-excursion
522       (set-buffer nndoc-current-buffer)
523       (goto-char (point-min))
524       ;; Find the beginning of the file.
525       (when nndoc-file-begin
526         (nndoc-search nndoc-file-begin))
527       ;; Go through the file.
528       (while (if (and first nndoc-first-article)
529                  (nndoc-search nndoc-first-article)
530                (nndoc-search nndoc-article-begin))
531         (setq first nil)
532         (cond (nndoc-head-begin-function
533                (funcall nndoc-head-begin-function))
534               (nndoc-head-begin 
535                (nndoc-search nndoc-head-begin)))
536         (if (or (>= (point) (point-max)) (and nndoc-file-end
537                  (looking-at nndoc-file-end)))
538             (goto-char (point-max))
539           (setq head-begin (point))
540           (nndoc-search (or nndoc-head-end "^$"))
541           (setq head-end (point))
542           (if nndoc-body-begin-function
543               (funcall nndoc-body-begin-function)
544             (nndoc-search (or nndoc-body-begin "^\n")))
545           (setq body-begin (point))
546           (or (and nndoc-body-end-function
547                    (funcall nndoc-body-end-function))
548               (and nndoc-body-end
549                    (nndoc-search nndoc-body-end))
550               (nndoc-search nndoc-article-begin)
551               (progn
552                 (goto-char (point-max))
553                 (when nndoc-file-end
554                   (and (re-search-backward nndoc-file-end nil t)
555                        (beginning-of-line)))))
556           (setq body-end (point))
557           (push (list (incf i) head-begin head-end body-begin body-end
558                       (count-lines body-begin body-end))
559                 nndoc-dissection-alist))))))
560
561 (defun nndoc-unquote-dashes ()
562   "Unquote quoted non-separators in digests."
563   (while (re-search-forward "^- -"nil t)
564     (replace-match "-" t t)))
565
566 ;;;###autoload
567 (defun nndoc-add-type (definition &optional position)
568   "Add document DEFINITION to the list of nndoc document definitions.
569 If POSITION is nil or `last', the definition will be added
570 as the last checked definition, if t or `first', add as the
571 first definition, and if any other symbol, add after that
572 symbol in the alist."
573   ;; First remove any old instances.
574   (setq nndoc-type-alist
575         (delq (assq (car definition) nndoc-type-alist)
576               nndoc-type-alist))
577   ;; Then enter the new definition in the proper place.
578   (cond
579    ((or (null position) (eq position 'last))
580     (setq nndoc-type-alist (nconc nndoc-type-alist (list definition))))
581    ((or (eq position t) (eq position 'first))
582     (push definition nndoc-type-alist))
583    (t
584     (let ((list (memq (assq position nndoc-type-alist)
585                       nndoc-type-alist)))
586       (unless list
587         (error "No such position: %s" position))
588       (setcdr list (cons definition (cdr list)))))))
589
590 (provide 'nndoc)
591
592 ;;; nndoc.el ends here