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