lisp/gnus/nndoc.el

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