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