cgit.sxemacs.org Git - gnus/blob - lisp/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     (mime-parts
  78      (generate-head-function . nndoc-generate-mime-parts-head)
  79      (article-transform-function . nndoc-transform-mime-parts))
  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-digest
  88      (article-begin . "")
  89      (head-end . "^ ?$")
  90      (body-end . "")
  91      (file-end . "")
  92      (subtype digest guess))
  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 full-subject)
 477   (let ((entry (cdr (assq article nndoc-dissection-alist))))
 478     (let ((subject (concat "<" (nth 5 entry) ">"))
 479           (message-id (nth 6 entry))
 480           (references (nth 7 entry)))
 481       (insert nndoc-mime-header
 482               "Subject: "
 483               (cond ((not full-subject) subject)
 484                     (nndoc-mime-subject (concat nndoc-mime-subject " " subject))
 485                     (t subject))
 486               "\n")
 487       (and message-id (insert "Message-ID: " message-id "\n"))
 488       (and references (insert "References: " references "\n")))))
 489
 490 (defun nndoc-clari-briefs-type-p ()
 491   (when (let ((case-fold-search nil))
 492           (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
 493     t))
 494
 495 (defun nndoc-transform-clari-briefs (article)
 496   (goto-char (point-min))
 497   (when (looking-at " *\\*\\(.*\\)\n")
 498     (replace-match "" t t))
 499   (nndoc-generate-clari-briefs-head article))
 500
 501 (defun nndoc-generate-clari-briefs-head (article)
 502   (let ((entry (cdr (assq article nndoc-dissection-alist)))
 503         subject from)
 504     (save-excursion
 505       (set-buffer nndoc-current-buffer)
 506       (save-restriction
 507         (narrow-to-region (car entry) (nth 3 entry))
 508         (goto-char (point-min))
 509         (when (looking-at " *\\*\\(.*\\)$")
 510           (setq subject (match-string 1))
 511           (when (string-match "[ \t]+$" subject)
 512             (setq subject (substring subject 0 (match-beginning 0)))))
 513         (when
 514             (let ((case-fold-search nil))
 515               (re-search-forward
 516                "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
 517           (setq from (match-string 1)))))
 518     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
 519             "\nSubject: " (or subject "(no subject)") "\n")))
 520
 521 (defun nndoc-mime-digest-type-p ()
 522   (let ((case-fold-search t)
 523         boundary-id b-delimiter entry)
 524     (when (and
 525            (re-search-forward
 526             (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
 527                     "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
 528             nil t)
 529            (match-beginning 1))
 530       (setq boundary-id (match-string 1)
 531             b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
 532       (setq entry (assq 'mime-digest nndoc-type-alist))
 533       (setcdr entry
 534               (list
 535                (cons 'head-end "^ ?$")
 536                (cons 'body-begin "^ ?\n")
 537                (cons 'article-begin b-delimiter)
 538                (cons 'body-end-function 'nndoc-digest-body-end)
 539                (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
 540       t)))
 541
 542 (defun nndoc-standard-digest-type-p ()
 543   (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
 544              (re-search-forward
 545               (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
 546     t))
 547
 548 (defun nndoc-digest-body-end ()
 549   (and (re-search-forward nndoc-article-begin nil t)
 550        (goto-char (match-beginning 0))))
 551
 552 (defun nndoc-slack-digest-type-p ()
 553   0)
 554
 555 (defun nndoc-lanl-gov-announce-type-p ()
 556   (when (let ((case-fold-search nil))
 557           (re-search-forward "^\\\\\\\\\nPaper: [a-z-]+/[0-9]+" nil t))
 558     t))
 559
 560 (defun nndoc-transform-lanl-gov-announce (article)
 561   (goto-char (point-max))
 562   (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t)
 563     (replace-match "\n\nGet it at \\1 (\\2)" t nil))
 564   ;;  (when (re-search-backward "^\\\\\\\\$" nil t)
 565   ;;    (replace-match "" t t))
 566   )
 567
 568 (defun nndoc-generate-lanl-gov-head (article)
 569   (let ((entry (cdr (assq article nndoc-dissection-alist)))
 570         (e-mail "no address given")
 571         subject from)
 572     (save-excursion
 573       (set-buffer nndoc-current-buffer)
 574       (save-restriction
 575         (narrow-to-region (car entry) (nth 1 entry))
 576         (goto-char (point-min))
 577         (when (looking-at "^Paper.*: \\([a-z-]+/[0-9]+\\)")
 578           (setq subject (concat " (" (match-string 1) ")"))
 579           (when (re-search-forward "^From: \\([^ ]+\\)" nil t)
 580             (setq e-mail (match-string 1)))
 581           (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)"
 582                                    nil t)
 583             (setq subject (concat (match-string 1) subject))
 584             (setq from (concat (match-string 2) " <" e-mail ">"))))
 585         ))
 586     (while (and from (string-match "(\[^)\]*)" from))
 587       (setq from (replace-match "" t t from)))
 588     (insert "From: "  (or from "unknown")
 589             "\nSubject: " (or subject "(no subject)") "\n")))
 590
 591 (deffoo nndoc-request-accept-article (group &optional server last)
 592   nil)
 593
 594
 595
 596 ;;;
 597 ;;; Functions for dissecting the documents
 598 ;;;
 599
 600 (defun nndoc-search (regexp)
 601   (prog1
 602       (re-search-forward regexp nil t)
 603     (beginning-of-line)))
 604
 605 (defun nndoc-dissect-buffer ()
 606   "Go through the document and partition it into heads/bodies/articles."
 607   (let ((i 0)
 608         (first t)
 609         head-begin head-end body-begin body-end)
 610     (setq nndoc-dissection-alist nil)
 611     (save-excursion
 612       (set-buffer nndoc-current-buffer)
 613       (goto-char (point-min))
 614       ;; Find the beginning of the file.
 615       (when nndoc-file-begin
 616         (nndoc-search nndoc-file-begin))
 617       ;; Go through the file.
 618       (while (if (and first nndoc-first-article)
 619                  (nndoc-search nndoc-first-article)
 620                (nndoc-article-begin))
 621         (setq first nil)
 622         (cond (nndoc-head-begin-function
 623                (funcall nndoc-head-begin-function))
 624               (nndoc-head-begin
 625                (nndoc-search nndoc-head-begin)))
 626         (if (or (eobp)
 627                 (and nndoc-file-end
 628                      (looking-at nndoc-file-end)))
 629             (goto-char (point-max))
 630           (setq head-begin (point))
 631           (nndoc-search (or nndoc-head-end "^$"))
 632           (setq head-end (point))
 633           (if nndoc-body-begin-function
 634               (funcall nndoc-body-begin-function)
 635             (nndoc-search (or nndoc-body-begin "^\n")))
 636           (setq body-begin (point))
 637           (or (and nndoc-body-end-function
 638                    (funcall nndoc-body-end-function))
 639               (and nndoc-body-end
 640                    (nndoc-search nndoc-body-end))
 641               (nndoc-article-begin)
 642               (progn
 643                 (goto-char (point-max))
 644                 (when nndoc-file-end
 645                   (and (re-search-backward nndoc-file-end nil t)
 646                        (beginning-of-line)))))
 647           (setq body-end (point))
 648           (push (list (incf i) head-begin head-end body-begin body-end
 649                       (count-lines body-begin body-end))
 650                 nndoc-dissection-alist))))))
 651
 652 (defun nndoc-article-begin ()
 653   (if nndoc-article-begin-function
 654       (funcall nndoc-article-begin-function)
 655     (ignore-errors
 656       (nndoc-search nndoc-article-begin))))
 657
 658 (defun nndoc-unquote-dashes ()
 659   "Unquote quoted non-separators in digests."
 660   (while (re-search-forward "^- -"nil t)
 661     (replace-match "-" t t)))
 662
 663 ;; Against compiler warnings.
 664 (defvar nndoc-mime-split-ordinal)
 665
 666 (defun nndoc-dissect-mime-parts ()
 667   "Go through a MIME composite article and partition it into sub-articles.
 668 When a MIME entity contains sub-entities, dissection produces one article for
 669 the header of this entity, and one article per sub-entity."
 670   (setq nndoc-dissection-alist nil
 671         nndoc-mime-split-ordinal 0)
 672   (save-excursion
 673     (set-buffer nndoc-current-buffer)
 674     (message-narrow-to-head)
 675     (let ((case-fold-search t)
 676           (message-id (message-fetch-field "Message-ID"))
 677           (references (message-fetch-field "References")))
 678       (setq nndoc-mime-header (buffer-substring (point-min) (point-max))
 679             nndoc-mime-subject (message-fetch-field "Subject"))
 680       (while (string-match "\
 681 ^\\(Subject\\|Message-ID\\|References\\|Lines\\|\
 682 MIME-Version\\|Content-Type\\|Content-Transfer-Encoding\\|\
 683 \\):.*\n\\([ \t].*\n\\)*"
 684                            nndoc-mime-header)
 685         (setq nndoc-mime-header (replace-match "" t t nndoc-mime-header)))
 686       (widen)
 687       (nndoc-dissect-mime-parts-sub (point-min) (point-max)
 688                                     nil message-id references))))
 689
 690 (defun nndoc-dissect-mime-parts-sub (begin end position message-id references)
 691   "Dissect an entity within a composite MIME message.
 692 The article, which corresponds to a MIME entity, extends from BEGIN to END.
 693 The string POSITION holds a dotted decimal representation of the article
 694 position in the hierarchical structure, it is nil for the outer entity.
 695 The generated article should use MESSAGE-ID and REFERENCES field values."
 696   ;; Note: `case-fold-search' is already `t' from the calling function.
 697   (let ((head-begin begin)
 698         (body-end end)
 699         head-end body-begin type subtype composite comment)
 700     (save-excursion
 701       ;; Gracefully handle a missing body.
 702       (goto-char head-begin)
 703       (if (search-forward "\n\n" body-end t)
 704           (setq head-end (1- (point))
 705                 body-begin (point))
 706         (setq head-end end
 707               body-begin end))
 708       ;; Save MIME attributes.
 709       (goto-char head-begin)
 710       (if (re-search-forward "\
 711 ^Content-Type: *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)"
 712                              head-end t)
 713           (setq type (downcase (match-string 1))
 714                 subtype (downcase (match-string 2)))
 715         (setq type "text"
 716               subtype "plain"))
 717       (setq composite (string= type "multipart")
 718             comment (concat position
 719                             (when (and position composite) ".")
 720                             (when composite "*")
 721                             (when (or position composite) " ")
 722                             (cond ((string= subtype "plain") type)
 723                                   ((string= subtype "basic") type)
 724                                   (t subtype))))
 725       ;; Generate dissection information for this entity.
 726       (push (list (incf nndoc-mime-split-ordinal)
 727                   head-begin head-end body-begin body-end
 728                   (count-lines body-begin body-end)
 729                   comment message-id references)
 730             nndoc-dissection-alist)
 731       ;; Recurse for all sub-entities, if any.
 732       (goto-char head-begin)
 733       (when (re-search-forward
 734              (concat "\
 735 ^Content-Type: *multipart/\\([a-z]+\\);\\(.*;\\)*"
 736                      "[ \t\n]*[ \t]boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
 737            head-end t)
 738         (let ((boundary (concat "\n--" (match-string 3) "\\(--\\)?[ \t]*\n"))
 739               (part-counter 0)
 740               begin end eof-flag)
 741           (goto-char head-end)
 742           (setq eof-flag (not (re-search-forward boundary body-end t)))
 743           (while (not eof-flag)
 744             (setq begin (point))
 745             (cond ((re-search-forward boundary body-end t)
 746                    (or (not (match-string 1))
 747                        (string= (match-string 1) "")
 748                        (setq eof-flag t))
 749                    (forward-line -1)
 750                    (setq end (point))
 751                    (forward-line 1))
 752                   (t (setq end body-end
 753                            eof-flag t)))
 754             (nndoc-dissect-mime-parts-sub begin end
 755                                           (concat position (when position ".")
 756                                                   (format "%d"
 757                                                           (incf part-counter)))
 758                                           (nnmail-message-id)
 759                                           message-id)))))))
 760
 761 ;;;###autoload
 762 (defun nndoc-add-type (definition &optional position)
 763   "Add document DEFINITION to the list of nndoc document definitions.
 764 If POSITION is nil or `last', the definition will be added
 765 as the last checked definition, if t or `first', add as the
 766 first definition, and if any other symbol, add after that
 767 symbol in the alist."
 768   ;; First remove any old instances.
 769   (gnus-pull (car definition) nndoc-type-alist)
 770   ;; Then enter the new definition in the proper place.
 771   (cond
 772    ((or (null position) (eq position 'last))
 773     (setq nndoc-type-alist (nconc nndoc-type-alist (list definition))))
 774    ((or (eq position t) (eq position 'first))
 775     (push definition nndoc-type-alist))
 776    (t
 777     (let ((list (memq (assq position nndoc-type-alist)
 778                       nndoc-type-alist)))
 779       (unless list
 780         (error "No such position: %s" position))
 781       (setcdr list (cons definition (cdr list)))))))
 782
 783 (provide 'nndoc)
 784
 785 ;;; nndoc.el ends here