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