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

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