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