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

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