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