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

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