git.chise.org Git - elisp/gnus.git-/blob - lisp/nndoc.el

   1 ;;; nndoc.el --- single file access for Gnus
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
   3 ;;        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 2, or (at your option)
  14 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  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' or `guess'.")
  45
  46 (defvoo nndoc-post-type 'mail
  47   "*Whether the nndoc group is `mail' or `post'.")
  48
  49 (defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr
  50   "Hook run after opening a document.
  51 The default function removes all trailing carriage returns
  52 from the document.")
  53
  54 (defvar nndoc-type-alist
  55   `((mmdf
  56      (article-begin .  "^\^A\^A\^A\^A\n")
  57      (body-end .  "^\^A\^A\^A\^A\n"))
  58     (nsmail
  59      (article-begin .  "^From - "))
  60     (news
  61      (article-begin . "^Path:"))
  62     (rnews
  63      (article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
  64      (body-end-function . nndoc-rnews-body-end))
  65     (mbox
  66      (article-begin-function . nndoc-mbox-article-begin)
  67      (body-end-function . nndoc-mbox-body-end))
  68     (babyl
  69      (article-begin . "\^_\^L *\n")
  70      (body-end . "\^_")
  71      (body-begin-function . nndoc-babyl-body-begin)
  72      (head-begin-function . nndoc-babyl-head-begin))
  73     (forward
  74      (article-begin . "^-+ \\(Start of \\)?forwarded message -+\n+")
  75      (body-end . "^-+ End \\(of \\)?forwarded message -+$")
  76      (prepare-body-function . nndoc-unquote-dashes))
  77     (rfc934
  78      (article-begin . "^--.*\n+")
  79      (body-end . "^--.*$")
  80      (prepare-body-function . nndoc-unquote-dashes))
  81     (clari-briefs
  82      (article-begin . "^ \\*")
  83      (body-end . "^\t------*[ \t]^*\n^ \\*")
  84      (body-begin . "^\t")
  85      (head-end . "^\t")
  86      (generate-head-function . nndoc-generate-clari-briefs-head)
  87      (article-transform-function . nndoc-transform-clari-briefs))
  88     (mime-digest
  89      (article-begin . "")
  90      (head-end . "^ ?$")
  91      (body-end . "")
  92      (file-end . "")
  93      (subtype digest guess))
  94     (mime-parts
  95      (generate-head-function . nndoc-generate-mime-parts-head)
  96      (article-transform-function . nndoc-transform-mime-parts))
  97     (standard-digest
  98      (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+"))
  99      (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+"))
 100      (prepare-body-function . nndoc-unquote-dashes)
 101      (body-end-function . nndoc-digest-body-end)
 102      (head-end . "^ *$")
 103      (body-begin . "^ *\n")
 104      (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$")
 105      (subtype digest guess))
 106     (slack-digest
 107      (article-begin . "^------------------------------*[\n \t]+")
 108      (head-end . "^ ?$")
 109      (body-end-function . nndoc-digest-body-end)
 110      (body-begin . "^ ?$")
 111      (file-end . "^End of")
 112      (prepare-body-function . nndoc-unquote-dashes)
 113      (subtype digest guess))
 114     (lanl-gov-announce
 115      (article-begin . "^\\\\\\\\\n")
 116      (head-begin . "^Paper.*:")
 117      (head-end   . "\\(^\\\\\\\\.*\n\\|-----------------\\)")
 118      (body-begin . "")
 119      (body-end   . "-------------------------------------------------")
 120      (file-end   . "^Title: Recent Seminal")
 121      (generate-head-function . nndoc-generate-lanl-gov-head)
 122      (article-transform-function . nndoc-transform-lanl-gov-announce)
 123      (subtype preprints guess))
 124     (rfc822-forward
 125      (article-begin . "^\n")
 126      (body-end-function . nndoc-rfc822-forward-body-end-function))
 127     (guess
 128      (guess . t)
 129      (subtype nil))
 130     (digest
 131      (guess . t)
 132      (subtype nil))
 133     (preprints
 134      (guess . t)
 135      (subtype nil))))
 136
 137 \f
 138 (defvoo nndoc-file-begin nil)
 139 (defvoo nndoc-first-article nil)
 140 (defvoo nndoc-article-begin nil)
 141 (defvoo nndoc-head-begin nil)
 142 (defvoo nndoc-head-end nil)
 143 (defvoo nndoc-file-end nil)
 144 (defvoo nndoc-body-begin nil)
 145 (defvoo nndoc-body-end-function nil)
 146 (defvoo nndoc-body-begin-function nil)
 147 (defvoo nndoc-head-begin-function nil)
 148 (defvoo nndoc-body-end nil)
 149 ;; nndoc-dissection-alist is a list of sublists.  Each sublist holds the
 150 ;; following items.  ARTICLE acts as the association key and is an ordinal
 151 ;; starting at 1.  HEAD-BEGIN [0], HEAD-END [1], BODY-BEGIN [2] and BODY-END
 152 ;; [3] are positions in the `nndoc' buffer.  LINE-COUNT [4] is a count of
 153 ;; lines in the body.  For MIME dissections only, ARTICLE-INSERT [5] and
 154 ;; SUMMARY-INSERT [6] give headers to insert for full article or summary line
 155 ;; generation, respectively.  Other headers usually follow directly from the
 156 ;; buffer.  Value `nil' means no insert.
 157 (defvoo nndoc-dissection-alist nil)
 158 (defvoo nndoc-prepare-body-function nil)
 159 (defvoo nndoc-generate-head-function nil)
 160 (defvoo nndoc-article-transform-function nil)
 161 (defvoo nndoc-article-begin-function nil)
 162
 163 (defvoo nndoc-status-string "")
 164 (defvoo nndoc-group-alist nil)
 165 (defvoo nndoc-current-buffer nil
 166   "Current nndoc news buffer.")
 167 (defvoo nndoc-address nil)
 168
 169 (defconst nndoc-version "nndoc 1.0"
 170   "nndoc version.")
 171
 172 \f
 173
 174 ;;; Interface functions
 175
 176 (nnoo-define-basics nndoc)
 177
 178 (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
 179   (when (nndoc-possibly-change-buffer newsgroup server)
 180     (save-excursion
 181       (set-buffer nntp-server-buffer)
 182       (erase-buffer)
 183       (let (article entry)
 184         (if (stringp (car articles))
 185             'headers
 186           (while articles
 187             (when (setq entry (cdr (assq (setq article (pop articles))
 188                                          nndoc-dissection-alist)))
 189               (insert (format "221 %d Article retrieved.\n" article))
 190               (if nndoc-generate-head-function
 191                   (funcall nndoc-generate-head-function article)
 192                 (insert-buffer-substring
 193                  nndoc-current-buffer (car entry) (nth 1 entry)))
 194               (goto-char (point-max))
 195               (unless (eq (char-after (1- (point))) ?\n)
 196                 (insert "\n"))
 197               (insert (format "Lines: %d\n" (nth 4 entry)))
 198               (insert ".\n")))
 199
 200           (nnheader-fold-continuation-lines)
 201           'headers)))))
 202
 203 (deffoo nndoc-request-article (article &optional newsgroup server buffer)
 204   (nndoc-possibly-change-buffer newsgroup server)
 205   (save-excursion
 206     (let ((buffer (or buffer nntp-server-buffer))
 207           (entry (cdr (assq article nndoc-dissection-alist)))
 208           beg)
 209       (set-buffer buffer)
 210       (erase-buffer)
 211       (when entry
 212         (if (stringp article)
 213             nil
 214           (insert-buffer-substring
 215            nndoc-current-buffer (car entry) (nth 1 entry))
 216           (insert "\n")
 217           (setq beg (point))
 218           (insert-buffer-substring
 219            nndoc-current-buffer (nth 2 entry) (nth 3 entry))
 220           (goto-char beg)
 221           (when nndoc-prepare-body-function
 222             (funcall nndoc-prepare-body-function))
 223           (when nndoc-article-transform-function
 224             (funcall nndoc-article-transform-function article))
 225           t)))))
 226
 227 (deffoo nndoc-request-group (group &optional server dont-check)
 228   "Select news GROUP."
 229   (let (number)
 230     (cond
 231      ((not (nndoc-possibly-change-buffer group server))
 232       (nnheader-report 'nndoc "No such file or buffer: %s"
 233                        nndoc-address))
 234      (dont-check
 235       (nnheader-report 'nndoc "Selected group %s" group)
 236       t)
 237      ((zerop (setq number (length nndoc-dissection-alist)))
 238       (nndoc-close-group group)
 239       (nnheader-report 'nndoc "No articles in group %s" group))
 240      (t
 241       (nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
 242
 243 (deffoo nndoc-request-type (group &optional article)
 244   (cond ((not article) 'unknown)
 245         (nndoc-post-type nndoc-post-type)
 246         (t 'unknown)))
 247
 248 (deffoo nndoc-close-group (group &optional server)
 249   (nndoc-possibly-change-buffer group server)
 250   (and nndoc-current-buffer
 251        (buffer-name nndoc-current-buffer)
 252        (kill-buffer nndoc-current-buffer))
 253   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
 254                                 nndoc-group-alist))
 255   (setq nndoc-current-buffer nil)
 256   (nnoo-close-server 'nndoc server)
 257   (setq nndoc-dissection-alist nil)
 258   t)
 259
 260 (deffoo nndoc-request-list (&optional server)
 261   nil)
 262
 263 (deffoo nndoc-request-newgroups (date &optional server)
 264   nil)
 265
 266 (deffoo nndoc-request-list-newsgroups (&optional server)
 267   nil)
 268
 269 \f
 270 ;;; Internal functions.
 271
 272 (defun nndoc-possibly-change-buffer (group source)
 273   (let (buf)
 274     (cond
 275      ;; The current buffer is this group's buffer.
 276      ((and nndoc-current-buffer
 277            (buffer-name nndoc-current-buffer)
 278            (eq nndoc-current-buffer
 279                (setq buf (cdr (assoc group nndoc-group-alist))))))
 280      ;; We change buffers by taking an old from the group alist.
 281      ;; `source' is either a string (a file name) or a buffer object.
 282      (buf
 283       (setq nndoc-current-buffer buf))
 284      ;; It's a totally new group.
 285      ((or (and (bufferp nndoc-address)
 286                (buffer-name nndoc-address))
 287           (and (stringp nndoc-address)
 288                (file-exists-p nndoc-address)
 289                (not (file-directory-p nndoc-address))))
 290       (push (cons group (setq nndoc-current-buffer
 291                               (get-buffer-create
 292                                (concat " *nndoc " group "*"))))
 293             nndoc-group-alist)
 294       (setq nndoc-dissection-alist nil)
 295       (save-excursion
 296         (set-buffer nndoc-current-buffer)
 297         (mm-enable-multibyte)
 298         (erase-buffer)
 299         (if (stringp nndoc-address)
 300             (nnheader-insert-file-contents nndoc-address)
 301           (insert-buffer-substring nndoc-address))
 302         (run-hooks 'nndoc-open-document-hook))))
 303     ;; Initialize the nndoc structures according to this new document.
 304     (when (and nndoc-current-buffer
 305                (not nndoc-dissection-alist))
 306       (save-excursion
 307         (set-buffer nndoc-current-buffer)
 308         (nndoc-set-delims)
 309         (if (eq nndoc-article-type 'mime-parts)
 310             (nndoc-dissect-mime-parts)
 311           (nndoc-dissect-buffer))))
 312     (unless nndoc-current-buffer
 313       (nndoc-close-server))
 314     ;; Return whether we managed to select a file.
 315     nndoc-current-buffer))
 316
 317 ;;;
 318 ;;; Deciding what document type we have
 319 ;;;
 320
 321 (defun nndoc-set-delims ()
 322   "Set the nndoc delimiter variables according to the type of the document."
 323   (let ((vars '(nndoc-file-begin
 324                 nndoc-first-article
 325                 nndoc-article-begin-function
 326                 nndoc-head-begin nndoc-head-end
 327                 nndoc-file-end nndoc-article-begin
 328                 nndoc-body-begin nndoc-body-end-function nndoc-body-end
 329                 nndoc-prepare-body-function nndoc-article-transform-function
 330                 nndoc-generate-head-function nndoc-body-begin-function
 331                 nndoc-head-begin-function)))
 332     (while vars
 333       (set (pop vars) nil)))
 334   (let (defs)
 335     ;; Guess away until we find the real file type.
 336     (while (assq 'guess (setq defs (cdr (assq nndoc-article-type
 337                                               nndoc-type-alist))))
 338       (setq nndoc-article-type (nndoc-guess-type nndoc-article-type)))
 339     ;; Set the nndoc variables.
 340     (while defs
 341       (set (intern (format "nndoc-%s" (caar defs)))
 342            (cdr (pop defs))))))
 343
 344 (defun nndoc-guess-type (subtype)
 345   (let ((alist nndoc-type-alist)
 346         results result entry)
 347     (while (and (not result)
 348                 (setq entry (pop alist)))
 349       (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess)))
 350         (goto-char (point-min))
 351         ;; Remove blank lines.
 352         (while (eq (following-char) ?\n)
 353           (delete-char 1))
 354         (when (numberp (setq result (funcall (intern
 355                                               (format "nndoc-%s-type-p"
 356                                                       (car entry))))))
 357           (push (cons result entry) results)
 358           (setq result nil))))
 359     (unless (or result results)
 360       (error "Document is not of any recognized type"))
 361     (if result
 362         (car entry)
 363       (cadar (sort results 'car-less-than-car)))))
 364
 365 ;;;
 366 ;;; Built-in type predicates and functions
 367 ;;;
 368
 369 (defun nndoc-mbox-type-p ()
 370   (when (looking-at message-unix-mail-delimiter)
 371     t))
 372
 373 (defun nndoc-mbox-article-begin ()
 374   (when (re-search-forward (concat "^" message-unix-mail-delimiter) nil t)
 375     (goto-char (match-beginning 0))))
 376
 377 (defun nndoc-mbox-body-end ()
 378   (let ((beg (point))
 379         len end)
 380     (when
 381         (save-excursion
 382           (and (re-search-backward
 383                 (concat "^" message-unix-mail-delimiter) nil t)
 384                (setq end (point))
 385                (search-forward "\n\n" beg t)
 386                (re-search-backward
 387                 "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
 388                (setq len (string-to-int (match-string 1)))
 389                (search-forward "\n\n" beg t)
 390                (unless (= (setq len (+ (point) len)) (point-max))
 391                  (and (< len (point-max))
 392                       (goto-char len)
 393                       (looking-at message-unix-mail-delimiter)))))
 394       (goto-char len))))
 395
 396 (defun nndoc-mmdf-type-p ()
 397   (when (looking-at "\^A\^A\^A\^A$")
 398     t))
 399
 400 (defun nndoc-news-type-p ()
 401   (when (looking-at "^Path:.*\n")
 402     t))
 403
 404 (defun nndoc-rnews-type-p ()
 405   (when (looking-at "#! *rnews")
 406     t))
 407
 408 (defun nndoc-rnews-body-end ()
 409   (and (re-search-backward nndoc-article-begin nil t)
 410        (forward-line 1)
 411        (goto-char (+ (point) (string-to-int (match-string 1))))))
 412
 413 (defun nndoc-babyl-type-p ()
 414   (when (re-search-forward "\^_\^L *\n" nil t)
 415     t))
 416
 417 (defun nndoc-babyl-body-begin ()
 418   (re-search-forward "^\n" nil t)
 419   (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
 420     (let ((next (or (save-excursion
 421                       (re-search-forward nndoc-article-begin nil t))
 422                     (point-max))))
 423       (unless (re-search-forward "^\n" next t)
 424         (goto-char next)
 425         (forward-line -1)
 426         (insert "\n")
 427         (forward-line -1)))))
 428
 429 (defun nndoc-babyl-head-begin ()
 430   (when (re-search-forward "^[0-9].*\n" nil t)
 431     (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
 432       (forward-line 1))
 433     t))
 434
 435 (defun nndoc-forward-type-p ()
 436   (when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
 437              (not (re-search-forward "^Subject:.*digest" nil t))
 438              (not (re-search-backward "^From:" nil t 2))
 439              (not (re-search-forward "^From:" nil t 2)))
 440     t))
 441
 442 (defun nndoc-rfc934-type-p ()
 443   (when (and (re-search-forward "^-+ Start of forwarded.*\n+" nil t)
 444              (not (re-search-forward "^Subject:.*digest" nil t))
 445              (not (re-search-backward "^From:" nil t 2))
 446              (not (re-search-forward "^From:" nil t 2)))
 447     t))
 448
 449 (defun nndoc-rfc822-forward-type-p ()
 450   (save-restriction
 451     (message-narrow-to-head)
 452     (when (re-search-forward "^Content-Type: *message/rfc822" nil t)
 453       t)))
 454
 455 (defun nndoc-rfc822-forward-body-end-function ()
 456   (goto-char (point-max)))
 457
 458 (defun nndoc-mime-parts-type-p ()
 459   (let ((case-fold-search t)
 460         (limit (search-forward "\n\n" nil t)))
 461     (goto-char (point-min))
 462     (when (and limit
 463                (re-search-forward
 464                 (concat "\
 465 ^Content-Type:[ \t]*multipart/[a-z]+ *; *\\(\\(\n[ \t]\\)?.*;\\)*"
 466                         "\\(\n[ \t]\\)?[ \t]*boundary=\"?[^\"\n]*[^\" \t\n]")
 467                 limit t))
 468       t)))
 469
 470 (defun nndoc-transform-mime-parts (article)
 471   (let* ((entry (cdr (assq article nndoc-dissection-alist)))
 472          (headers (nth 5 entry)))
 473     (when headers
 474       (goto-char (point-min))
 475       (insert headers))))
 476
 477 (defun nndoc-generate-mime-parts-head (article)
 478   (let* ((entry (cdr (assq article nndoc-dissection-alist)))
 479          (headers (nth 6 entry)))
 480     (save-restriction
 481       (narrow-to-region (point) (point))
 482       (insert-buffer-substring
 483        nndoc-current-buffer (car entry) (nth 1 entry))
 484       (goto-char (point-max)))
 485     (when headers
 486       (insert headers))))
 487
 488 (defun nndoc-clari-briefs-type-p ()
 489   (when (let ((case-fold-search nil))
 490           (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
 491     t))
 492
 493 (defun nndoc-transform-clari-briefs (article)
 494   (goto-char (point-min))
 495   (when (looking-at " *\\*\\(.*\\)\n")
 496     (replace-match "" t t))
 497   (nndoc-generate-clari-briefs-head article))
 498
 499 (defun nndoc-generate-clari-briefs-head (article)
 500   (let ((entry (cdr (assq article nndoc-dissection-alist)))
 501         subject from)
 502     (save-excursion
 503       (set-buffer nndoc-current-buffer)
 504       (save-restriction
 505         (narrow-to-region (car entry) (nth 3 entry))
 506         (goto-char (point-min))
 507         (when (looking-at " *\\*\\(.*\\)$")
 508           (setq subject (match-string 1))
 509           (when (string-match "[ \t]+$" subject)
 510             (setq subject (substring subject 0 (match-beginning 0)))))
 511         (when
 512             (let ((case-fold-search nil))
 513               (re-search-forward
 514                "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
 515           (setq from (match-string 1)))))
 516     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
 517             "\nSubject: " (or subject "(no subject)") "\n")))
 518
 519
 520 (defun nndoc-mime-digest-type-p ()
 521   (let ((case-fold-search t)
 522         boundary-id b-delimiter entry)
 523     (when (and
 524            (re-search-forward
 525             (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
 526                     "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
 527             nil t)
 528            (match-beginning 1))
 529       (setq boundary-id (match-string 1)
 530             b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
 531       (setq entry (assq 'mime-digest nndoc-type-alist))
 532       (setcdr entry
 533               (list
 534                (cons 'head-end "^ ?$")
 535                (cons 'body-begin "^ ?\n")
 536                (cons 'article-begin b-delimiter)
 537                (cons 'body-end-function 'nndoc-digest-body-end)
 538                (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
 539       t)))
 540
 541 (defun nndoc-standard-digest-type-p ()
 542   (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
 543              (re-search-forward
 544               (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
 545     t))
 546
 547 (defun nndoc-digest-body-end ()
 548   (and (re-search-forward nndoc-article-begin nil t)
 549        (goto-char (match-beginning 0))))
 550
 551 (defun nndoc-slack-digest-type-p ()
 552   0)
 553
 554 (defun nndoc-lanl-gov-announce-type-p ()
 555   (when (let ((case-fold-search nil))
 556           (re-search-forward "^\\\\\\\\\nPaper: [a-z-]+/[0-9]+" nil t))
 557     t))
 558
 559 (defun nndoc-transform-lanl-gov-announce (article)
 560   (goto-char (point-max))
 561   (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t)
 562     (replace-match "\n\nGet it at \\1 (\\2)" t nil)))
 563
 564 (defun nndoc-generate-lanl-gov-head (article)
 565   (let ((entry (cdr (assq article nndoc-dissection-alist)))
 566         (e-mail "no address given")
 567         subject from)
 568     (save-excursion
 569       (set-buffer nndoc-current-buffer)
 570       (save-restriction
 571         (narrow-to-region (car entry) (nth 1 entry))
 572         (goto-char (point-min))
 573         (when (looking-at "^Paper.*: \\([a-z-]+/[0-9]+\\)")
 574           (setq subject (concat " (" (match-string 1) ")"))
 575           (when (re-search-forward "^From: \\([^ ]+\\)" nil t)
 576             (setq e-mail (match-string 1)))
 577           (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)"
 578                                    nil t)
 579             (setq subject (concat (match-string 1) subject))
 580             (setq from (concat (match-string 2) " <" e-mail ">"))))))
 581     (while (and from (string-match "(\[^)\]*)" from))
 582       (setq from (replace-match "" t t from)))
 583     (insert "From: "  (or from "unknown")
 584             "\nSubject: " (or subject "(no subject)") "\n")))
 585
 586 (defun nndoc-nsmail-type-p ()
 587   (when (looking-at "From - ")
 588     t))
 589
 590 (deffoo nndoc-request-accept-article (group &optional server last)
 591   nil)
 592
 593
 594 ;;;
 595 ;;; Functions for dissecting the documents
 596 ;;;
 597
 598 (defun nndoc-search (regexp)
 599   (prog1
 600       (re-search-forward regexp nil t)
 601     (beginning-of-line)))
 602
 603 (defun nndoc-dissect-buffer ()
 604   "Go through the document and partition it into heads/bodies/articles."
 605   (let ((i 0)
 606         (first t)
 607         head-begin head-end body-begin body-end)
 608     (setq nndoc-dissection-alist nil)
 609     (save-excursion
 610       (set-buffer nndoc-current-buffer)
 611       (goto-char (point-min))
 612       ;; Remove blank lines.
 613       (while (eq (following-char) ?\n)
 614         (delete-char 1))
 615       ;; Find the beginning of the file.
 616       (when nndoc-file-begin
 617         (nndoc-search nndoc-file-begin))
 618       ;; Go through the file.
 619       (while (if (and first nndoc-first-article)
 620                  (nndoc-search nndoc-first-article)
 621                (nndoc-article-begin))
 622         (setq first nil)
 623         (cond (nndoc-head-begin-function
 624                (funcall nndoc-head-begin-function))
 625               (nndoc-head-begin
 626                (nndoc-search nndoc-head-begin)))
 627         (if (or (eobp)
 628                 (and nndoc-file-end
 629                      (looking-at nndoc-file-end)))
 630             (goto-char (point-max))
 631           (setq head-begin (point))
 632           (nndoc-search (or nndoc-head-end "^$"))
 633           (setq head-end (point))
 634           (if nndoc-body-begin-function
 635               (funcall nndoc-body-begin-function)
 636             (nndoc-search (or nndoc-body-begin "^\n")))
 637           (setq body-begin (point))
 638           (or (and nndoc-body-end-function
 639                    (funcall nndoc-body-end-function))
 640               (and nndoc-body-end
 641                    (nndoc-search nndoc-body-end))
 642               (nndoc-article-begin)
 643               (progn
 644                 (goto-char (point-max))
 645                 (when nndoc-file-end
 646                   (and (re-search-backward nndoc-file-end nil t)
 647                        (beginning-of-line)))))
 648           (setq body-end (point))
 649           (push (list (incf i) head-begin head-end body-begin body-end
 650                       (count-lines body-begin body-end))
 651                 nndoc-dissection-alist))))))
 652
 653 (defun nndoc-article-begin ()
 654   (if nndoc-article-begin-function
 655       (funcall nndoc-article-begin-function)
 656     (ignore-errors
 657       (nndoc-search nndoc-article-begin))))
 658
 659 (defun nndoc-unquote-dashes ()
 660   "Unquote quoted non-separators in digests."
 661   (while (re-search-forward "^- -"nil t)
 662     (replace-match "-" t t)))
 663
 664 ;; Against compiler warnings.
 665 (defvar nndoc-mime-split-ordinal)
 666
 667 (defun nndoc-dissect-mime-parts ()
 668   "Go through a MIME composite article and partition it into sub-articles.
 669 When a MIME entity contains sub-entities, dissection produces one article for
 670 the header of this entity, and one article per sub-entity."
 671   (setq nndoc-dissection-alist nil
 672         nndoc-mime-split-ordinal 0)
 673   (save-excursion
 674     (set-buffer nndoc-current-buffer)
 675     (nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil)))
 676
 677 (defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert
 678                                                 position parent)
 679   "Dissect an entity, within a composite MIME message.
 680 The complete message or MIME entity extends from HEAD-BEGIN to BODY-END.
 681 ARTICLE-INSERT should be added at beginning for generating a full article.
 682 The string POSITION holds a dotted decimal representation of the article
 683 position in the hierarchical structure, it is nil for the outer entity.
 684 PARENT is the message-ID of the parent summary line, or nil for none."
 685   (let ((case-fold-search t)
 686         (message-id (nnmail-message-id))
 687         head-end body-begin summary-insert message-rfc822 multipart-any
 688         subject content-type type subtype boundary-regexp)
 689     ;; Gracefully handle a missing body.
 690     (goto-char head-begin)
 691     (if (search-forward "\n\n" body-end t)
 692         (setq head-end (1- (point))
 693               body-begin (point))
 694       (setq head-end body-end
 695             body-begin body-end))
 696     (narrow-to-region head-begin head-end)
 697     ;; Save MIME attributes.
 698     (goto-char head-begin)
 699     (setq content-type (message-fetch-field "Content-Type"))
 700     (when content-type
 701       (when (string-match
 702              "^ *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" content-type)
 703         (setq type (downcase (match-string 1 content-type))
 704               subtype (downcase (match-string 2 content-type))
 705               message-rfc822 (and (string= type "message")
 706                                   (string= subtype "rfc822"))
 707               multipart-any (string= type "multipart")))
 708       (when (string-match ";[ \t\n]*name=\\([^ \t\n;]+\\)" content-type)
 709         (setq subject (match-string 1 content-type)))
 710       (when (string-match "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)" content-type)
 711         (setq boundary-regexp (concat "^--"
 712                                       (regexp-quote
 713                                        (match-string 1 content-type))
 714                                       "\\(--\\)?[ \t]*\n"))))
 715     (unless subject
 716       (when (or multipart-any (not article-insert))
 717         (setq subject (message-fetch-field "Subject"))))
 718     (unless type
 719       (setq type "text"
 720             subtype "plain"))
 721     ;; Prepare the article and summary inserts.
 722     (unless article-insert
 723       (setq article-insert (buffer-substring (point-min) (point-max))
 724             head-end head-begin))
 725     (setq summary-insert article-insert)
 726     ;; - summary Subject.
 727     (setq summary-insert
 728           (let ((line (concat "Subject: <" position
 729                               (and position multipart-any ".")
 730                               (and multipart-any "*")
 731                               (and (or position multipart-any) " ")
 732                               (cond ((string= subtype "plain") type)
 733                                     ((string= subtype "basic") type)
 734                                     (t subtype))
 735                               ">"
 736                               (and subject " ")
 737                               subject
 738                               "\n")))
 739             (if (string-match "Subject:.*\n\\([ \t].*\n\\)*" summary-insert)
 740                 (replace-match line t t summary-insert)
 741               (concat summary-insert line))))
 742     ;; - summary Message-ID.
 743     (setq summary-insert
 744           (let ((line (concat "Message-ID: " message-id "\n")))
 745             (if (string-match "Message-ID:.*\n\\([ \t].*\n\\)*" summary-insert)
 746                 (replace-match line t t summary-insert)
 747               (concat summary-insert line))))
 748     ;; - summary References.
 749     (when parent
 750       (setq summary-insert
 751             (let ((line (concat "References: " parent "\n")))
 752               (if (string-match "References:.*\n\\([ \t].*\n\\)*"
 753                                 summary-insert)
 754                   (replace-match line t t summary-insert)
 755                 (concat summary-insert line)))))
 756     ;; Generate dissection information for this entity.
 757     (push (list (incf nndoc-mime-split-ordinal)
 758                 head-begin head-end body-begin body-end
 759                 (count-lines body-begin body-end)
 760                 article-insert summary-insert)
 761           nndoc-dissection-alist)
 762     ;; Recurse for all sub-entities, if any.
 763     (widen)
 764     (cond
 765      (message-rfc822
 766       (save-excursion
 767         (nndoc-dissect-mime-parts-sub body-begin body-end nil
 768                                       position message-id)))
 769      ((and multipart-any boundary-regexp)
 770       (let ((part-counter 0)
 771             part-begin part-end eof-flag)
 772         (while (string-match "\
 773 ^\\(Lines\\|Content-\\(Type\\|Transfer-Encoding\\)\\):.*\n\\([ \t].*\n\\)*"
 774                              article-insert)
 775           (setq article-insert (replace-match "" t t article-insert)))
 776         (let ((case-fold-search nil))
 777           (goto-char body-begin)
 778           (setq eof-flag (not (re-search-forward boundary-regexp body-end t)))
 779           (while (not eof-flag)
 780             (setq part-begin (point))
 781             (cond ((re-search-forward boundary-regexp body-end t)
 782                    (or (not (match-string 1))
 783                        (string= (match-string 1) "")
 784                        (setq eof-flag t))
 785                    (forward-line -1)
 786                    (setq part-end (point))
 787                    (forward-line 1))
 788                   (t (setq part-end body-end
 789                            eof-flag t)))
 790             (save-excursion
 791               (nndoc-dissect-mime-parts-sub
 792                part-begin part-end article-insert
 793                (concat position
 794                        (and position ".")
 795                        (format "%d" (incf part-counter)))
 796                message-id)))))))))
 797
 798 ;;;###autoload
 799 (defun nndoc-add-type (definition &optional position)
 800   "Add document DEFINITION to the list of nndoc document definitions.
 801 If POSITION is nil or `last', the definition will be added
 802 as the last checked definition, if t or `first', add as the
 803 first definition, and if any other symbol, add after that
 804 symbol in the alist."
 805   ;; First remove any old instances.
 806   (gnus-pull (car definition) nndoc-type-alist)
 807   ;; Then enter the new definition in the proper place.
 808   (cond
 809    ((or (null position) (eq position 'last))
 810     (setq nndoc-type-alist (nconc nndoc-type-alist (list definition))))
 811    ((or (eq position t) (eq position 'first))
 812     (push definition nndoc-type-alist))
 813    (t
 814     (let ((list (memq (assq position nndoc-type-alist)
 815                       nndoc-type-alist)))
 816       (unless list
 817         (error "No such position: %s" position))
 818       (setcdr list (cons definition (cdr list)))))))
 819
 820 (provide 'nndoc)
 821
 822 ;;; nndoc.el ends here