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

   1 ;;; nndoc.el --- single file access for Gnus
   2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'nnheader)
  30 (require 'message)
  31 (require 'nnmail)
  32 (require 'nnoo)
  33 (eval-when-compile (require 'cl))
  34
  35 (nnoo-declare nndoc)
  36
  37 (defvoo nndoc-article-type 'guess
  38   "*Type of the file.
  39 One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
  40 `mime-digest', `standard-digest', `slack-digest', `clari-briefs' or
  41 `guess'.")
  42
  43 (defvoo nndoc-post-type 'mail
  44   "*Whether the nndoc group is `mail' or `post'.")
  45
  46 (defvar nndoc-type-alist
  47   `((mmdf
  48      (article-begin .  "^\^A\^A\^A\^A\n")
  49      (body-end .  "^\^A\^A\^A\^A\n"))
  50     (news
  51      (article-begin . "^Path:"))
  52     (rnews
  53      (article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
  54      (body-end-function . nndoc-rnews-body-end))
  55     (mbox
  56      (article-begin .
  57                     ,(let ((delim (concat "^" message-unix-mail-delimiter)))
  58                        (if (string-match "\n\\'" delim)
  59                            (substring delim 0 (match-beginning 0))
  60                          delim)))
  61      (body-end-function . nndoc-mbox-body-end))
  62     (babyl
  63      (article-begin . "\^_\^L *\n")
  64      (body-end . "\^_")
  65      (body-begin-function . nndoc-babyl-body-begin)
  66      (head-begin-function . nndoc-babyl-head-begin))
  67     (forward
  68      (article-begin . "^-+ Start of forwarded message -+\n+")
  69      (body-end . "^-+ End of forwarded message -+$")
  70      (prepare-body-function . nndoc-unquote-dashes))
  71     (clari-briefs
  72      (article-begin . "^ \\*")
  73      (body-end . "^\t------*[ \t]^*\n^ \\*")
  74      (body-begin . "^\t")
  75      (head-end . "^\t")
  76      (generate-head-function . nndoc-generate-clari-briefs-head)
  77      (article-transform-function . nndoc-transform-clari-briefs))
  78     (mime-digest
  79      (article-begin . "")
  80      (head-end . "^ ?$")
  81      (body-end . "")
  82      (file-end . "")
  83      (subtype digest guess))
  84     (standard-digest
  85      (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+"))
  86      (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n+"))
  87      (prepare-body-function . nndoc-unquote-dashes)
  88      (body-end-function . nndoc-digest-body-end)
  89      (head-end . "^ ?$")
  90      (body-begin . "^ ?\n")
  91      (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$")
  92      (subtype digest guess))
  93     (slack-digest
  94      (article-begin . "^------------------------------*[\n \t]+")
  95      (head-end . "^ ?$")
  96      (body-end-function . nndoc-digest-body-end)
  97      (body-begin . "^ ?$")
  98      (file-end . "^End of")
  99      (prepare-body-function . nndoc-unquote-dashes)
 100      (subtype digest guess))
 101     (guess
 102      (guess . nndoc-guess-type))
 103     (digest
 104      (guess . nndoc-guess-digest-type))
 105     ))
 106
 107 \f
 108
 109 (defvoo nndoc-file-begin nil)
 110 (defvoo nndoc-first-article nil)
 111 (defvoo nndoc-article-end nil)
 112 (defvoo nndoc-article-begin nil)
 113 (defvoo nndoc-head-begin nil)
 114 (defvoo nndoc-head-end nil)
 115 (defvoo nndoc-file-end nil)
 116 (defvoo nndoc-body-begin nil)
 117 (defvoo nndoc-body-end-function nil)
 118 (defvoo nndoc-body-begin-function nil)
 119 (defvoo nndoc-head-begin-function nil)
 120 (defvoo nndoc-body-end nil)
 121 (defvoo nndoc-dissection-alist nil)
 122 (defvoo nndoc-prepare-body-function nil)
 123 (defvoo nndoc-generate-head-function nil)
 124 (defvoo nndoc-article-transform-function nil)
 125
 126 (defvoo nndoc-status-string "")
 127 (defvoo nndoc-group-alist nil)
 128 (defvoo nndoc-current-buffer nil
 129   "Current nndoc news buffer.")
 130 (defvoo nndoc-address nil)
 131
 132 (defconst nndoc-version "nndoc 1.0"
 133   "nndoc version.")
 134
 135 \f
 136
 137 ;;; Interface functions
 138
 139 (nnoo-define-basics nndoc)
 140
 141 (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
 142   (when (nndoc-possibly-change-buffer newsgroup server)
 143     (save-excursion
 144       (set-buffer nntp-server-buffer)
 145       (erase-buffer)
 146       (let (article entry)
 147         (if (stringp (car articles))
 148             'headers
 149           (while articles
 150             (when (setq entry (cdr (assq (setq article (pop articles))
 151                                          nndoc-dissection-alist)))
 152               (insert (format "221 %d Article retrieved.\n" article))
 153               (if nndoc-generate-head-function
 154                   (funcall nndoc-generate-head-function article)
 155                 (insert-buffer-substring
 156                  nndoc-current-buffer (car entry) (nth 1 entry)))
 157               (goto-char (point-max))
 158               (or (= (char-after (1- (point))) ?\n) (insert "\n"))
 159               (insert (format "Lines: %d\n" (nth 4 entry)))
 160               (insert ".\n")))
 161
 162           (nnheader-fold-continuation-lines)
 163           'headers)))))
 164
 165 (deffoo nndoc-request-article (article &optional newsgroup server buffer)
 166   (nndoc-possibly-change-buffer newsgroup server)
 167   (save-excursion
 168     (let ((buffer (or buffer nntp-server-buffer))
 169           (entry (cdr (assq article nndoc-dissection-alist)))
 170           beg)
 171       (set-buffer buffer)
 172       (erase-buffer)
 173       (if (stringp article)
 174           nil
 175         (insert-buffer-substring
 176          nndoc-current-buffer (car entry) (nth 1 entry))
 177         (insert "\n")
 178         (setq beg (point))
 179         (insert-buffer-substring
 180          nndoc-current-buffer (nth 2 entry) (nth 3 entry))
 181         (goto-char beg)
 182         (when nndoc-prepare-body-function
 183           (funcall nndoc-prepare-body-function))
 184         (when nndoc-article-transform-function
 185           (funcall nndoc-article-transform-function article))
 186         t))))
 187
 188 (deffoo nndoc-request-group (group &optional server dont-check)
 189   "Select news GROUP."
 190   (let (number)
 191     (cond
 192      ((not (nndoc-possibly-change-buffer group server))
 193       (nnheader-report 'nndoc "No such file or buffer: %s"
 194                        nndoc-address))
 195      (dont-check
 196       (nnheader-report 'nndoc "Selected group %s" group)
 197       t)
 198      ((zerop (setq number (length nndoc-dissection-alist)))
 199       (nndoc-close-group group)
 200       (nnheader-report 'nndoc "No articles in group %s" group))
 201      (t
 202       (nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
 203
 204 (deffoo nndoc-request-type (group &optional article)
 205   (cond ((not article) 'unknown)
 206         (nndoc-post-type nndoc-post-type)
 207         (t 'unknown)))
 208
 209 (deffoo nndoc-close-group (group &optional server)
 210   (nndoc-possibly-change-buffer group server)
 211   (and nndoc-current-buffer
 212        (buffer-name nndoc-current-buffer)
 213        (kill-buffer nndoc-current-buffer))
 214   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
 215                                 nndoc-group-alist))
 216   (setq nndoc-current-buffer nil)
 217   (nnoo-close-server 'nndoc server)
 218   (setq nndoc-dissection-alist nil)
 219   t)
 220
 221 (deffoo nndoc-request-list (&optional server)
 222   nil)
 223
 224 (deffoo nndoc-request-newgroups (date &optional server)
 225   nil)
 226
 227 (deffoo nndoc-request-list-newsgroups (&optional server)
 228   nil)
 229
 230 \f
 231 ;;; Internal functions.
 232
 233 (defun nndoc-possibly-change-buffer (group source)
 234   (let (buf)
 235     (cond
 236      ;; The current buffer is this group's buffer.
 237      ((and nndoc-current-buffer
 238            (buffer-name nndoc-current-buffer)
 239            (eq nndoc-current-buffer
 240                (setq buf (cdr (assoc group nndoc-group-alist))))))
 241      ;; We change buffers by taking an old from the group alist.
 242      ;; `source' is either a string (a file name) or a buffer object.
 243      (buf
 244       (setq nndoc-current-buffer buf))
 245      ;; It's a totally new group.
 246      ((or (and (bufferp nndoc-address)
 247                (buffer-name nndoc-address))
 248           (and (stringp nndoc-address)
 249                (file-exists-p nndoc-address)
 250                (not (file-directory-p nndoc-address))))
 251       (push (cons group (setq nndoc-current-buffer
 252                               (get-buffer-create
 253                                (concat " *nndoc " group "*"))))
 254             nndoc-group-alist)
 255       (setq nndoc-dissection-alist nil)
 256       (save-excursion
 257         (set-buffer nndoc-current-buffer)
 258         (buffer-disable-undo (current-buffer))
 259         (erase-buffer)
 260         (if (stringp nndoc-address)
 261             (insert-file-contents nndoc-address)
 262           (insert-buffer-substring nndoc-address)))))
 263     ;; Initialize the nndoc structures according to this new document.
 264     (when (and nndoc-current-buffer
 265                (not nndoc-dissection-alist))
 266       (save-excursion
 267         (set-buffer nndoc-current-buffer)
 268         (nndoc-set-delims)
 269         (nndoc-dissect-buffer)))
 270     (unless nndoc-current-buffer
 271       (nndoc-close-server))
 272     ;; Return whether we managed to select a file.
 273     nndoc-current-buffer))
 274
 275 ;;;
 276 ;;; Deciding what document type we have
 277 ;;;
 278
 279 (defun nndoc-set-delims ()
 280   "Set the nndoc delimiter variables according to the type of the document."
 281   (let ((vars '(nndoc-file-begin
 282                 nndoc-first-article
 283                 nndoc-article-end nndoc-head-begin nndoc-head-end
 284                 nndoc-file-end nndoc-article-begin
 285                 nndoc-body-begin nndoc-body-end-function nndoc-body-end
 286                 nndoc-prepare-body-function nndoc-article-transform-function
 287                 nndoc-generate-head-function nndoc-body-begin-function
 288                 nndoc-head-begin-function)))
 289     (while vars
 290       (set (pop vars) nil)))
 291   (let (defs)
 292     ;; Guess away until we find the real file type.
 293     (while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist))
 294                  guess (assq 'guess defs))
 295       (setq nndoc-article-type (nndoc-guess-type nndoc-article-type)))
 296     ;; Set the nndoc variables.
 297     (while defs
 298       (set (intern (format "nndoc-%s" (caar defs)))
 299            (cdr (pop defs))))))
 300
 301 (defun nndoc-guess-type (subtype)
 302   (let ((alist nndoc-type-alist)
 303         results result entry)
 304     (while (and (not result)
 305                 (setq entry (pop alist)))
 306       (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess)))
 307         (goto-char (point-min))
 308         (when (numberp (setq result (funcall (intern
 309                                               (format "nndoc-%s-type-p"
 310                                                       (car entry))))))
 311           (push (cons result entry) results)
 312           (setq result nil))))
 313     (unless (or result results)
 314       (error "Document is not of any recognized type"))
 315     (if result
 316         (car entry)
 317       (cadar (sort results (lambda (r1 r2) (< (car r1) (car r2))))))))
 318
 319 ;;;
 320 ;;; Built-in type predicates and functions
 321 ;;;
 322
 323 (defun nndoc-mbox-type-p ()
 324   (when (looking-at message-unix-mail-delimiter)
 325     t))
 326
 327 (defun nndoc-mbox-body-end ()
 328   (let ((beg (point))
 329         len end)
 330     (when
 331         (save-excursion
 332           (and (re-search-backward nndoc-article-begin nil t)
 333                (setq end (point))
 334                (search-forward "\n\n" beg t)
 335                (re-search-backward
 336                 "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
 337                (setq len (string-to-int (match-string 1)))
 338                (search-forward "\n\n" beg t)
 339                (or (= (setq len (+ (point) len)) (point-max))
 340                    (and (< len (point-max))
 341                         (goto-char len)
 342                         (looking-at nndoc-article-begin)))))
 343       (goto-char len))))
 344
 345 (defun nndoc-mmdf-type-p ()
 346   (when (looking-at "\^A\^A\^A\^A$")
 347     t))
 348
 349 (defun nndoc-news-type-p ()
 350   (when (looking-at "^Path:.*\n")
 351     t))
 352
 353 (defun nndoc-rnews-type-p ()
 354   (when (looking-at "#! *rnews")
 355     t))
 356
 357 (defun nndoc-rnews-body-end ()
 358   (and (re-search-backward nndoc-article-begin nil t)
 359        (forward-line 1)
 360        (goto-char (+ (point) (string-to-int (match-string 1))))))
 361
 362 (defun nndoc-babyl-type-p ()
 363   (when (re-search-forward "\^_\^L *\n" nil t)
 364     t))
 365
 366 (defun nndoc-babyl-body-begin ()
 367   (re-search-forward "^\n" nil t)
 368   (when (looking-at "\*\*\* EOOH \*\*\*")
 369     (re-search-forward "^\n" nil t)))
 370
 371 (defun nndoc-babyl-head-begin ()
 372   (when (re-search-forward "^[0-9].*\n" nil t)
 373     (when (looking-at "\*\*\* EOOH \*\*\*")
 374       (forward-line 1))
 375     t))
 376
 377 (defun nndoc-forward-type-p ()
 378   (when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
 379              (not (re-search-forward "^Subject:.*digest" nil t)))
 380     t))
 381
 382 (defun nndoc-clari-briefs-type-p ()
 383   (when (let ((case-fold-search nil))
 384           (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
 385     t))
 386
 387 (defun nndoc-transform-clari-briefs (article)
 388   (goto-char (point-min))
 389   (when (looking-at " *\\*\\(.*\\)\n")
 390     (replace-match "" t t))
 391   (nndoc-generate-clari-briefs-head article))
 392
 393 (defun nndoc-generate-clari-briefs-head (article)
 394   (let ((entry (cdr (assq article nndoc-dissection-alist)))
 395         subject from)
 396     (save-excursion
 397       (set-buffer nndoc-current-buffer)
 398       (save-restriction
 399         (narrow-to-region (car entry) (nth 3 entry))
 400         (goto-char (point-min))
 401         (when (looking-at " *\\*\\(.*\\)$")
 402           (setq subject (match-string 1))
 403           (when (string-match "[ \t]+$" subject)
 404             (setq subject (substring subject 0 (match-beginning 0)))))
 405         (when
 406             (let ((case-fold-search nil))
 407               (re-search-forward
 408                "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
 409           (setq from (match-string 1)))))
 410     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
 411             "\nSubject: " (or subject "(no subject)") "\n")))
 412
 413 (defun nndoc-mime-digest-type-p ()
 414   (let ((case-fold-search t)
 415         boundary-id b-delimiter entry)
 416      (when (and
 417             (re-search-forward
 418              (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
 419                      "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
 420              nil t)
 421             (match-beginning 1))
 422        (setq boundary-id (match-string 1)
 423              b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
 424        (setq entry (assq 'mime-digest nndoc-type-alist))
 425        (setcdr entry
 426                (list
 427                 (cons 'head-end "^ ?$")
 428                 (cons 'body-begin "^ ?\n")
 429                 (cons 'article-begin b-delimiter)
 430                 (cons 'body-end-function 'nndoc-digest-body-end)
 431                 (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
 432        t)))
 433
 434 (defun nndoc-standard-digest-type-p ()
 435   (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
 436              (re-search-forward
 437               (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
 438     t))
 439
 440 (defun nndoc-digest-body-end ()
 441   (and (re-search-forward nndoc-article-begin nil t)
 442        (goto-char (match-beginning 0))))
 443
 444 (defun nndoc-slack-digest-type-p ()
 445   0)
 446
 447 ;;;
 448 ;;; Functions for dissecting the documents
 449 ;;;
 450
 451 (defun nndoc-search (regexp)
 452   (prog1
 453       (re-search-forward regexp nil t)
 454     (beginning-of-line)))
 455
 456 (defun nndoc-dissect-buffer ()
 457   "Go through the document and partition it into heads/bodies/articles."
 458   (let ((i 0)
 459         (first t)
 460         head-begin head-end body-begin body-end)
 461     (setq nndoc-dissection-alist nil)
 462     (save-excursion
 463       (set-buffer nndoc-current-buffer)
 464       (goto-char (point-min))
 465       ;; Find the beginning of the file.
 466       (when nndoc-file-begin
 467         (nndoc-search nndoc-file-begin))
 468       ;; Go through the file.
 469       (while (if (and first nndoc-first-article)
 470                  (nndoc-search nndoc-first-article)
 471                (nndoc-search nndoc-article-begin))
 472         (setq first nil)
 473         (cond (nndoc-head-begin-function
 474                (funcall nndoc-head-begin-function))
 475               (nndoc-head-begin
 476                (nndoc-search nndoc-head-begin)))
 477         (if (and nndoc-file-end
 478                  (looking-at nndoc-file-end))
 479             (goto-char (point-max))
 480           (setq head-begin (point))
 481           (nndoc-search (or nndoc-head-end "^$"))
 482           (setq head-end (point))
 483           (if nndoc-body-begin-function
 484               (funcall nndoc-body-begin-function)
 485             (nndoc-search (or nndoc-body-begin "^\n")))
 486           (setq body-begin (point))
 487           (or (and nndoc-body-end-function
 488                    (funcall nndoc-body-end-function))
 489               (and nndoc-body-end
 490                    (nndoc-search nndoc-body-end))
 491               (nndoc-search nndoc-article-begin)
 492               (progn
 493                 (goto-char (point-max))
 494                 (when nndoc-file-end
 495                   (and (re-search-backward nndoc-file-end nil t)
 496                        (beginning-of-line)))))
 497           (setq body-end (point))
 498           (push (list (incf i) head-begin head-end body-begin body-end
 499                       (count-lines body-begin body-end))
 500                 nndoc-dissection-alist))))))
 501
 502 (defun nndoc-unquote-dashes ()
 503   "Unquote quoted non-separators in digests."
 504   (while (re-search-forward "^- -"nil t)
 505     (replace-match "-" t t)))
 506
 507 ;;;###autoload
 508 (defun nndoc-add-type (definition &optional position)
 509   "Add document DEFINITION to the list of nndoc document definitions.
 510 If POSITION is nil or `last', the definition will be added
 511 as the last checked definition, if t or `first', add as the
 512 first definition, and if any other symbol, add after that
 513 symbol in the alist."
 514   (cond
 515    ((or (null position) (eq position 'last))
 516     (setq nndoc-type-alist (nconc nndoc-type-alist (list definition))))
 517    ((or (eq position t) (eq position 'first))
 518     (push definition nndoc-type-alist))
 519    (t
 520     (let ((list (memq (assq position nndoc-type-alist))))
 521       (unless list
 522         (error "No such position: %s" position))
 523       (setcdr list (cons definition (cdr list)))))))
 524
 525 (provide 'nndoc)
 526
 527 ;;; nndoc.el ends here