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