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
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'nnheader)
  29 (require 'rmail)
  30 (require 'nnmail)
  31
  32 (defvar nndoc-article-type 'guess
  33   "*Type of the file.
  34 One of `mbox', `babyl', `digest', `news', `rnews', `mmdf',
  35 `forward', `mime-digest', `standard-digest', `slack-digest', or
  36 `guess'.")
  37
  38 (defvar nndoc-type-alist
  39   `((mmdf
  40      (article-begin .  "^\^A\^A\^A\^A\n")
  41      (body-end .  "^\^A\^A\^A\^A\n"))
  42     (news
  43      (article-begin . "^Path:"))
  44     (rnews
  45      (article-begin . "^#! *rnews +\\([0-9]\\)+ *\n")
  46      (body-end-function . nndoc-rnews-body-end))
  47     (mbox
  48      (article-begin .
  49                     ,(let ((delim (concat "^" rmail-unix-mail-delimiter)))
  50                        (if (string-match "\n\\'" delim)
  51                            (substring delim 0 (match-beginning 0))
  52                          delim)))
  53      (body-end-function . nndoc-mbox-body-end))
  54     (babyl
  55      (article-begin . "\^_\^L *\n")
  56      (body-end . "\^_")
  57      (head-begin . "^[0-9].*\n"))
  58     (forward
  59      (article-begin . "^-+ Start of forwarded message -+\n+")
  60      (body-end . "^-+ End of forwarded message -+\n"))
  61     (clari-briefs
  62      (article-begin . "^ \\*")
  63      (body-end . "^\t------*[ \t]^*\n^ \\*")
  64      (body-begin . "^\t")
  65      (head-end . "^\t")
  66      (generate-head . nndoc-generate-clari-briefs-head)
  67      (article-transform . nndoc-transform-clari-briefs))
  68     (slack-digest
  69      (article-begin . "^------------------------------*[\n \t]+")
  70      (head-end . "^ ?$")
  71      (body-begin . "^ ?$")
  72      (file-end . "^End of")
  73      (prepare-body . nndoc-prepare-digest-body))
  74     (mime-digest
  75      (article-begin . "")
  76      (head-end . "^ ?$")
  77      (body-end . "")
  78      (file-end . ""))
  79     (standard-digest
  80      (first-article . ,(concat "^" (make-string 70 ?-) "\n\n"))
  81      (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n"))
  82      (prepare-body . nndoc-prepare-digest-body)
  83      (body-end-function . nndoc-digest-body-end)
  84      (file-end . "^End of .* Digest"))
  85     (guess
  86      (guess . nndoc-guess-type))
  87     (digest
  88      (guess . nndoc-guess-digest-type))
  89     ))
  90
  91 \f
  92
  93 (defvar nndoc-file-begin nil)
  94 (defvar nndoc-first-article nil)
  95 (defvar nndoc-article-end nil)
  96 (defvar nndoc-article-begin nil)
  97 (defvar nndoc-head-begin nil)
  98 (defvar nndoc-head-end nil)
  99 (defvar nndoc-file-end nil)
 100 (defvar nndoc-body-begin nil)
 101 (defvar nndoc-body-end-function nil)
 102 (defvar nndoc-body-end nil)
 103 (defvar nndoc-dissection-alist nil)
 104 (defvar nndoc-prepare-body nil)
 105 (defvar nndoc-generate-head nil)
 106 (defvar nndoc-article-transform nil)
 107
 108 (defvar nndoc-current-server nil)
 109 (defvar nndoc-server-alist nil)
 110 (defvar nndoc-server-variables
 111   (list
 112    (list 'nndoc-article-type nndoc-article-type)
 113    '(nndoc-article-begin nil)
 114    '(nndoc-article-end nil)
 115    '(nndoc-head-begin nil)
 116    '(nndoc-head-end nil)
 117    '(nndoc-first-article nil)
 118    '(nndoc-current-buffer nil)
 119    '(nndoc-group-alist nil)
 120    '(nndoc-end-of-file nil)
 121    '(nndoc-body-begin nil)
 122    '(nndoc-address nil)))
 123
 124 (defconst nndoc-version "nndoc 1.0"
 125   "nndoc version.")
 126
 127 (defvar nndoc-current-buffer nil
 128   "Current nndoc news buffer.")
 129
 130 (defvar nndoc-address nil)
 131
 132 \f
 133
 134 (defvar nndoc-status-string "")
 135
 136 (defvar nndoc-group-alist nil)
 137
 138 ;;; Interface functions
 139
 140 (defun nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
 141   (when (nndoc-possibly-change-buffer newsgroup server)
 142     (save-excursion
 143       (set-buffer nntp-server-buffer)
 144       (erase-buffer)
 145       (let (article entry)
 146         (if (stringp (car articles))
 147             'headers
 148           (while articles
 149             (setq entry (cdr (assq (setq article (pop articles))
 150                                    nndoc-dissection-alist)))
 151             (insert (format "221 %d Article retrieved.\n" article))
 152             (if nndoc-generate-head
 153                 (funcall nndoc-generate-head article)
 154               (insert-buffer-substring
 155                nndoc-current-buffer (car entry) (nth 1 entry)))
 156             (goto-char (point-max))
 157             (or (= (char-after (1- (point))) ?\n) (insert "\n"))
 158             (insert (format "Lines: %d\n" (nth 4 entry)))
 159             (insert ".\n"))
 160
 161           (nnheader-fold-continuation-lines)
 162           'headers)))))
 163
 164 (defun nndoc-open-server (server &optional defs)
 165   (nnheader-init-server-buffer)
 166   (if (equal server nndoc-current-server)
 167       t
 168     (if nndoc-current-server
 169         (setq nndoc-server-alist
 170               (cons (list nndoc-current-server
 171                           (nnheader-save-variables nndoc-server-variables))
 172                     nndoc-server-alist)))
 173     (let ((state (assoc server nndoc-server-alist)))
 174       (if state
 175           (progn
 176             (nnheader-restore-variables (nth 1 state))
 177             (setq nndoc-server-alist (delq state nndoc-server-alist)))
 178         (nnheader-set-init-variables nndoc-server-variables defs)))
 179     (setq nndoc-current-server server)
 180     t))
 181
 182 (defun nndoc-close-server (&optional server)
 183   t)
 184
 185 (defun nndoc-server-opened (&optional server)
 186   (and (equal server nndoc-current-server)
 187        nntp-server-buffer
 188        (buffer-name nntp-server-buffer)))
 189
 190 (defun nndoc-status-message (&optional server)
 191   nndoc-status-string)
 192
 193 (defun nndoc-request-article (article &optional newsgroup server buffer)
 194   (nndoc-possibly-change-buffer newsgroup server)
 195   (save-excursion
 196     (let ((buffer (or buffer nntp-server-buffer))
 197           (entry (cdr (assq article nndoc-dissection-alist)))
 198           beg)
 199       (set-buffer buffer)
 200       (erase-buffer)
 201       (if (stringp article)
 202           nil
 203         (insert-buffer-substring
 204          nndoc-current-buffer (car entry) (nth 1 entry))
 205         (insert "\n")
 206         (setq beg (point))
 207         (insert-buffer-substring
 208          nndoc-current-buffer (nth 2 entry) (nth 3 entry))
 209         (goto-char beg)
 210         (when nndoc-prepare-body
 211           (funcall nndoc-prepare-body))
 212         (when nndoc-article-transform
 213           (funcall nndoc-article-transform article))
 214         t))))
 215
 216 (defun nndoc-request-group (group &optional server dont-check)
 217   "Select news GROUP."
 218   (save-excursion
 219     (let (number)
 220       (cond
 221        ((not (nndoc-possibly-change-buffer group server))
 222         (nnheader-report 'nndoc "No such file or buffer: %s"
 223                          nndoc-address))
 224        (dont-check
 225         (nnheader-report 'nndoc "Selected group %s" group)
 226         t)
 227        ((zerop (setq number (length nndoc-dissection-alist)))
 228         (nndoc-close-group group)
 229         (nnheader-report 'nndoc "No articles in group %s" group))
 230        (t
 231         (save-excursion
 232           (set-buffer nntp-server-buffer)
 233           (erase-buffer)
 234           (insert (format "211 %d %d %d %s\n" number 1 number group))
 235           t))))))
 236
 237 (defun nndoc-close-group (group &optional server)
 238   (nndoc-possibly-change-buffer group server)
 239   (and nndoc-current-buffer
 240        (buffer-name nndoc-current-buffer)
 241        (kill-buffer nndoc-current-buffer))
 242   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
 243                                 nndoc-group-alist))
 244   (setq nndoc-current-buffer nil)
 245   (setq nndoc-current-server nil)
 246   (setq nndoc-dissection-alist nil)
 247   t)
 248
 249 (defun nndoc-request-list (&optional server)
 250   nil)
 251
 252 (defun nndoc-request-newgroups (date &optional server)
 253   nil)
 254
 255 (defun nndoc-request-list-newsgroups (&optional server)
 256   nil)
 257
 258 (defalias 'nndoc-request-post 'nnmail-request-post)
 259
 260 \f
 261 ;;; Internal functions.
 262
 263 (defun nndoc-possibly-change-buffer (group source)
 264   (let (buf)
 265     (cond
 266      ;; The current buffer is this group's buffer.
 267      ((and nndoc-current-buffer
 268            (buffer-name nndoc-current-buffer)
 269            (eq nndoc-current-buffer
 270                (setq buf (cdr (assoc group nndoc-group-alist))))))
 271      ;; We change buffers by taking an old from the group alist.
 272      ;; `source' is either a string (a file name) or a buffer object.
 273      (buf
 274       (setq nndoc-current-buffer buf))
 275      ;; It's a totally new group.
 276      ((or (and (bufferp nndoc-address)
 277                (buffer-name nndoc-address))
 278           (and (stringp nndoc-address)
 279                (file-exists-p nndoc-address)
 280                (not (file-directory-p nndoc-address))))
 281       (setq nndoc-group-alist
 282             (cons (cons group (setq nndoc-current-buffer
 283                                     (get-buffer-create
 284                                      (concat " *nndoc " group "*"))))
 285                   nndoc-group-alist))
 286       (setq nndoc-dissection-alist nil)
 287       (save-excursion
 288         (set-buffer nndoc-current-buffer)
 289         (buffer-disable-undo (current-buffer))
 290         (erase-buffer)
 291         (if (stringp nndoc-address)
 292             (insert-file-contents nndoc-address)
 293           (insert-buffer-substring nndoc-address)))))
 294     (when (and nndoc-current-buffer
 295                (not nndoc-dissection-alist))
 296       (save-excursion
 297         (set-buffer nndoc-current-buffer)
 298         (nndoc-set-delims)
 299         (nndoc-dissect-buffer)))
 300     t))
 301
 302 ;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
 303 (defun nndoc-guess-digest-type ()
 304   (let ((case-fold-search t)            ; We match a bit too much, keep it simple.
 305         boundary-id b-delimiter entry)
 306     (goto-char (point-min))
 307     (cond
 308      ;; MIME digest.
 309      ((and
 310        (re-search-forward
 311         (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
 312                 "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
 313         nil t)
 314        (match-beginning 1))
 315       (setq boundary-id (match-string 1)
 316             b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
 317       (setq entry (assq 'mime-digest nndoc-type-alist))
 318       (setcdr entry
 319               (list
 320                (cons 'head-end "^ ?$")
 321                (cons 'body-begin "^ \n")
 322                (cons 'article-begin b-delimiter)
 323                (cons 'body-end-function 'nndoc-digest-body-end)
 324 ;              (cons 'body-end
 325 ;                    (concat "\n--" boundary-id "\\(--\\)?[\n \t]+"))
 326                (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
 327       'mime-digest)
 328      ((and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
 329            (re-search-forward
 330             (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
 331       'standard-digest)
 332      ;; Stupid digest.
 333      (t
 334       'slack-digest))))
 335
 336 (defun nndoc-guess-type ()
 337   "Guess what document type is in the current buffer."
 338   (goto-char (point-min))
 339   (cond
 340    ((looking-at rmail-unix-mail-delimiter)
 341     'mbox)
 342    ((looking-at "\^A\^A\^A\^A$")
 343     'mmdf)
 344    ((looking-at "^Path:.*\n")
 345     'rnews)
 346    ((re-search-forward "\^_\^L *\n" nil t)
 347     'babyl)
 348    ((save-excursion
 349       (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
 350            (not (re-search-forward "^Subject:.*digest" nil t))))
 351     'forward)
 352    ((let ((case-fold-search nil))
 353       (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
 354     'clari-briefs)
 355    ((re-search-forward "^Path: .*!" nil t)
 356     'news)
 357    (t
 358     'digest)))
 359
 360 (defun nndoc-set-delims ()
 361   (let ((vars '(nndoc-file-begin
 362                 nndoc-first-article
 363                 nndoc-article-end nndoc-head-begin nndoc-head-end
 364                 nndoc-file-end nndoc-article-begin
 365                 nndoc-body-begin nndoc-body-end-function nndoc-body-end
 366                 nndoc-prepare-body nndoc-article-transform
 367                 nndoc-generate-head)))
 368     (while vars
 369       (set (pop vars) nil)))
 370   (let* (defs guess)
 371     ;; Guess away until we find the real file type.
 372     (while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist))
 373                  guess (assq 'guess defs))
 374       (setq nndoc-article-type (funcall (cdr guess))))
 375     (while defs
 376       (set (intern (format "nndoc-%s" (car (car defs))))
 377            (cdr (pop defs))))))
 378
 379 (defun nndoc-search (regexp)
 380   (prog1
 381       (re-search-forward regexp nil t)
 382     (beginning-of-line)))
 383
 384 (defun nndoc-dissect-buffer ()
 385   (let ((i 0)
 386         (first t)
 387         head-begin head-end body-begin body-end)
 388     (setq nndoc-dissection-alist nil)
 389     (save-excursion
 390       (set-buffer nndoc-current-buffer)
 391       (goto-char (point-min))
 392       ;; Find the beginning of the file.
 393       (when nndoc-file-begin
 394         (nndoc-search nndoc-file-begin))
 395       ;; Go through the file.
 396       (while (if (and first nndoc-first-article)
 397                  (nndoc-search nndoc-first-article)
 398                (nndoc-search nndoc-article-begin))
 399         (setq first nil)
 400         (when nndoc-head-begin
 401           (nndoc-search nndoc-head-begin))
 402         (setq head-begin (point))
 403         (nndoc-search (or nndoc-head-end "^$"))
 404         (setq head-end (point))
 405         (nndoc-search (or nndoc-body-begin "^\n"))
 406         (setq body-begin (point))
 407         (or (and nndoc-body-end-function
 408                  (funcall nndoc-body-end-function))
 409             (and nndoc-body-end
 410                  (nndoc-search nndoc-body-end))
 411             (nndoc-search nndoc-article-begin)
 412             (progn
 413               (goto-char (point-max))
 414               (when nndoc-file-end
 415                 (and (re-search-backward nndoc-file-end nil t)
 416                      (beginning-of-line)))))
 417         (setq body-end (point))
 418         (push (list (incf i) head-begin head-end body-begin body-end
 419                     (count-lines body-begin body-end))
 420               nndoc-dissection-alist)))))
 421
 422 (defun nndoc-prepare-digest-body ()
 423   "Unquote quoted non-separators in digests."
 424   (while (re-search-forward "^- -"nil t)
 425     (replace-match "-" t t)))
 426
 427 (defun nndoc-digest-body-end ()
 428   (and (re-search-forward nndoc-article-begin nil t)
 429        (goto-char (match-beginning 0))))
 430
 431 (defun nndoc-mbox-body-end ()
 432   (let ((beg (point))
 433         len end)
 434     (when
 435         (save-excursion
 436           (and (re-search-backward nndoc-article-begin nil t)
 437                (setq end (point))
 438                (search-forward "\n\n" beg t)
 439                (re-search-backward "^Content-Length: \\([0-9]+\\) *$" end t)
 440                (setq len (string-to-int (match-string 1)))
 441                (search-forward "\n\n" beg t)
 442                (or (= (setq len (+ (point) len)) (point-max))
 443                    (and (< len (point-max))
 444                         (goto-char len)
 445                         (looking-at nndoc-article-begin)))))
 446       (goto-char len))))
 447
 448 (defun nndoc-rnews-body-end ()
 449   (save-excursion
 450     (and (re-search-backward nndoc-article-begin nil t)
 451          (goto-char (+ (point) (string-to-int (match-string 1)))))))
 452
 453 (defun nndoc-transform-clari-briefs (article)
 454   (goto-char (point-min))
 455   (when (looking-at " *\\*\\(.*\\)\n")
 456     (replace-match "" t t))
 457   (nndoc-generate-clari-briefs-head article))
 458
 459 (defun nndoc-generate-clari-briefs-head (article)
 460   (let ((entry (cdr (assq article nndoc-dissection-alist)))
 461         subject from)
 462     (save-excursion
 463       (set-buffer nndoc-current-buffer)
 464       (save-restriction
 465         (narrow-to-region (car entry) (nth 3 entry))
 466         (goto-char (point-min))
 467         (when (looking-at " *\\*\\(.*\\)$")
 468           (setq subject (match-string 1)))
 469         (when
 470             (let ((case-fold-search nil))
 471               (re-search-forward
 472                "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
 473           (setq from (match-string 1)))))
 474     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
 475             "\nSubject: " (or subject "(no subject)") "\n")))
 476
 477 (provide 'nndoc)
 478
 479 ;;; nndoc.el ends here