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