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

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