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

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