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