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

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