cgit.sxemacs.org Git - gnus/blob - lisp/nndoc.el

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