code.delx.au - gnu-emacs/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 - one of `mbox', `babyl' or `digest'.")
  34
  35 (defvar nndoc-digest-type 'traditional
  36   "Type of the last digest.  Auto-detected from the article header.
  37 Possible values:
  38   `traditional' -- the \"lots of dashes\" (30+) rules used;
  39                    we currently also do unconditional RFC 934 unquoting.
  40   `rfc1341' -- RFC 1341 digest (MIME, unique boundary, no quoting).")
  41
  42 (defconst nndoc-type-to-regexp
  43   (list (list 'mbox
  44               (concat "^" rmail-unix-mail-delimiter)
  45               (concat "^" rmail-unix-mail-delimiter)
  46               nil "^$" nil nil nil)
  47         (list 'babyl "\^_\^L *\n" "\^_" "^[0-9].*\n" "^$" nil nil
  48               "\\*\\*\\* EOOH \\*\\*\\*\n\\(^.+\n\\)*")
  49         (list 'digest
  50               "^------------------------------*[\n \t]+"
  51               "^------------------------------*[\n \t]+"
  52               nil "^ ?$"
  53               "^------------------------------*[\n \t]+"
  54               "^End of" nil))
  55   "Regular expressions for articles of the various types.")
  56
  57 \f
  58
  59 (defvar nndoc-article-begin nil)
  60 (defvar nndoc-article-end nil)
  61 (defvar nndoc-head-begin nil)
  62 (defvar nndoc-head-end nil)
  63 (defvar nndoc-first-article nil)
  64 (defvar nndoc-end-of-file nil)
  65 (defvar nndoc-body-begin nil)
  66
  67 (defvar nndoc-current-server nil)
  68 (defvar nndoc-server-alist nil)
  69 (defvar nndoc-server-variables
  70   (list
  71    (list 'nndoc-article-type nndoc-article-type)
  72    '(nndoc-article-begin nil)
  73    '(nndoc-article-end nil)
  74    '(nndoc-head-begin nil)
  75    '(nndoc-head-end nil)
  76    '(nndoc-first-article nil)
  77    '(nndoc-current-buffer nil)
  78    '(nndoc-group-alist nil)
  79    '(nndoc-end-of-file nil)
  80    '(nndoc-body-begin nil)
  81    '(nndoc-address nil)))
  82
  83 (defconst nndoc-version "nndoc 1.0"
  84   "nndoc version.")
  85
  86 (defvar nndoc-current-buffer nil
  87   "Current nndoc news buffer.")
  88
  89 (defvar nndoc-address nil)
  90
  91 \f
  92
  93 (defvar nndoc-status-string "")
  94
  95 (defvar nndoc-group-alist nil)
  96
  97 ;;; Interface functions
  98
  99 (defun nndoc-retrieve-headers (sequence &optional newsgroup server)
 100   (save-excursion
 101     (set-buffer nntp-server-buffer)
 102     (erase-buffer)
 103     (let ((prev 2)
 104           article p beg lines)
 105       (nndoc-possibly-change-buffer newsgroup server)
 106       (if (stringp (car sequence))
 107           'headers
 108         (set-buffer nndoc-current-buffer)
 109         (widen)
 110         (goto-char (point-min))
 111         (re-search-forward (or nndoc-first-article
 112                                nndoc-article-begin) nil t)
 113         (or (not nndoc-head-begin)
 114             (re-search-forward nndoc-head-begin nil t))
 115         (re-search-forward nndoc-head-end nil t)
 116         (while sequence
 117           (setq article (car sequence))
 118           (set-buffer nndoc-current-buffer)
 119           (if (not (nndoc-forward-article (max 0 (- article prev))))
 120               ()
 121             (setq p (point))
 122             (setq beg (or (and
 123                            (re-search-backward nndoc-article-begin nil t)
 124                            (match-end 0))
 125                           (point-min)))
 126             (goto-char p)
 127             (setq lines (count-lines
 128                          (point)
 129                          (or
 130                           (and (re-search-forward nndoc-article-end nil t)
 131                                (goto-char (match-beginning 0)))
 132                           (goto-char (point-max)))))
 133
 134             (set-buffer nntp-server-buffer)
 135             (insert (format "221 %d Article retrieved.\n" article))
 136             (insert-buffer-substring nndoc-current-buffer beg p)
 137             (goto-char (point-max))
 138             (or (= (char-after (1- (point))) ?\n) (insert "\n"))
 139             (insert (format "Lines: %d\n" lines))
 140             (insert ".\n"))
 141
 142           (setq prev article
 143                 sequence (cdr sequence)))
 144
 145         ;; Fold continuation lines.
 146         (set-buffer nntp-server-buffer)
 147         (goto-char (point-min))
 148         (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 149           (replace-match " " t t))
 150         'headers))))
 151
 152 (defun nndoc-open-server (server &optional defs)
 153   (nnheader-init-server-buffer)
 154   (if (equal server nndoc-current-server)
 155       t
 156     (if nndoc-current-server
 157         (setq nndoc-server-alist
 158               (cons (list nndoc-current-server
 159                           (nnheader-save-variables nndoc-server-variables))
 160                     nndoc-server-alist)))
 161     (let ((state (assoc server nndoc-server-alist)))
 162       (if state
 163           (progn
 164             (nnheader-restore-variables (nth 1 state))
 165             (setq nndoc-server-alist (delq state nndoc-server-alist)))
 166         (nnheader-set-init-variables nndoc-server-variables defs)))
 167     (setq nndoc-current-server server)
 168     (let ((defs (cdr (assq nndoc-article-type nndoc-type-to-regexp))))
 169       (setq nndoc-article-begin (nth 0 defs))
 170       (setq nndoc-article-end (nth 1 defs))
 171       (setq nndoc-head-begin (nth 2 defs))
 172       (setq nndoc-head-end (nth 3 defs))
 173       (setq nndoc-first-article (nth 4 defs))
 174       (setq nndoc-end-of-file (nth 5 defs))
 175       (setq nndoc-body-begin (nth 6 defs)))
 176     t))
 177
 178 (defun nndoc-close-server (&optional server)
 179   t)
 180
 181 (defun nndoc-server-opened (&optional server)
 182   (and (equal server nndoc-current-server)
 183        nntp-server-buffer
 184        (buffer-name nntp-server-buffer)))
 185
 186 (defun nndoc-status-message (&optional server)
 187   nndoc-status-string)
 188
 189 (defun nndoc-request-article (article &optional newsgroup server buffer)
 190   (nndoc-possibly-change-buffer newsgroup server)
 191   (save-excursion
 192     (let ((buffer (or buffer nntp-server-buffer)))
 193       (set-buffer buffer)
 194       (erase-buffer)
 195       (if (stringp article)
 196           nil
 197         (nndoc-insert-article article)
 198         ;; Unquote quoted non-separators in digests.
 199         (if (and (eq nndoc-article-type 'digest)
 200                  (eq nndoc-digest-type 'traditional))
 201             (progn
 202               (goto-char (point-min))
 203               (while (re-search-forward "^- -"nil t)
 204                 (replace-match "-" t t))))
 205         ;; Some assholish digests do not have a blank line after the
 206         ;; headers. Aargh!
 207         (goto-char (point-min))
 208         (if (search-forward "\n\n" nil t)
 209             ()                          ; We let this one pass.
 210           (if (re-search-forward "^[ \t]+$" nil t)
 211               (replace-match "" t t)    ; We nix out a line of blanks.
 212             (while (and (looking-at "[^ ]+:")
 213                         (zerop (forward-line 1))))
 214             ;; We just insert a couple of lines. If you read digests
 215             ;; that are so badly formatted, you don't deserve any
 216             ;; better. Blphphpht!
 217             (insert "\n\n")))
 218         t))))
 219
 220 (defun nndoc-request-group (group &optional server dont-check)
 221   "Select news GROUP."
 222   (save-excursion
 223     (if (not (nndoc-possibly-change-buffer group server))
 224         (progn
 225           (setq nndoc-status-string "No such file or buffer")
 226           nil)
 227       (nndoc-set-header-dependent-regexps) ; hack for MIME digests
 228       (if dont-check
 229           t
 230         (save-excursion
 231           (set-buffer nntp-server-buffer)
 232           (erase-buffer)
 233           (let ((number (nndoc-number-of-articles)))
 234             (if (zerop number)
 235                 (progn
 236                   (nndoc-close-group group)
 237                   nil)
 238               (insert (format "211 %d %d %d %s\n" number 1 number group))
 239               t)))))))
 240
 241 (defun nndoc-close-group (group &optional server)
 242   (nndoc-possibly-change-buffer group server)
 243   (kill-buffer nndoc-current-buffer)
 244   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
 245                                 nndoc-group-alist))
 246   (setq nndoc-current-buffer nil)
 247   (setq nndoc-current-server nil)
 248   t)
 249
 250 (defun nndoc-request-list (&optional server)
 251   nil)
 252
 253 (defun nndoc-request-newgroups (date &optional server)
 254   nil)
 255
 256 (defun nndoc-request-list-newsgroups (&optional server)
 257   nil)
 258
 259 (defalias 'nndoc-request-post 'nnmail-request-post)
 260 (defalias 'nndoc-request-post-buffer 'nnmail-request-post-buffer)
 261
 262 \f
 263 ;;; Internal functions.
 264
 265 (defun nndoc-possibly-change-buffer (group source)
 266   (let (buf)
 267     (cond
 268      ;; The current buffer is this group's buffer.
 269      ((and nndoc-current-buffer
 270            (eq nndoc-current-buffer
 271                (setq buf (cdr (assoc group nndoc-group-alist))))))
 272      ;; We change buffers by taking an old from the group alist.
 273      ;; `source' is either a string (a file name) or a buffer object.
 274      (buf
 275       (setq nndoc-current-buffer buf))
 276      ;; It's a totally new group.
 277      ((or (and (bufferp nndoc-address)
 278                (buffer-name nndoc-address))
 279           (and (stringp nndoc-address)
 280                (file-exists-p nndoc-address)
 281                (not (file-directory-p nndoc-address))))
 282       (setq nndoc-group-alist
 283             (cons (cons group (setq nndoc-current-buffer
 284                                     (get-buffer-create
 285                                      (concat " *nndoc " group "*"))))
 286                   nndoc-group-alist))
 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           (save-excursion
 294             (set-buffer nndoc-address)
 295             (widen))
 296           (insert-buffer-substring nndoc-address))
 297         t)))))
 298
 299 ;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
 300 (defun nndoc-set-header-dependent-regexps ()
 301   (if (not (eq nndoc-article-type 'digest))
 302       ()
 303     (let ((case-fold-search t)          ; We match a bit too much, keep it simple.
 304           (boundary-id) (b-delimiter))
 305       (save-excursion
 306         (set-buffer nndoc-current-buffer)
 307         (goto-char (point-min))
 308         (if (and
 309              (re-search-forward
 310               (concat "\n\n\\|^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
 311                       "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
 312               nil t)
 313              (match-beginning 1))
 314             (setq nndoc-digest-type 'rfc1341
 315                   boundary-id (format "%s"
 316                                       (buffer-substring
 317                                        (match-beginning 1) (match-end 1)))
 318                   b-delimiter       (concat "\n--" boundary-id "[\n \t]+")
 319                   nndoc-article-begin b-delimiter ; Too strict: "[ \t]*$"
 320                   nndoc-article-end (concat "\n--" boundary-id
 321                                             "\\(--\\)?[\n \t]+")
 322                   nndoc-first-article b-delimiter ; ^eof ends article too.
 323                   nndoc-end-of-file (concat "\n--" boundary-id "--[ \t]*$"))
 324           (setq nndoc-digest-type 'traditional))))))
 325
 326 (defun nndoc-forward-article (n)
 327   (while (and (> n 0)
 328               (re-search-forward nndoc-article-begin nil t)
 329               (or (not nndoc-head-begin)
 330                   (re-search-forward nndoc-head-begin nil t))
 331               (re-search-forward nndoc-head-end nil t))
 332     (setq n (1- n)))
 333   (zerop n))
 334
 335 (defun nndoc-number-of-articles ()
 336   (save-excursion
 337     (set-buffer nndoc-current-buffer)
 338     (widen)
 339     (goto-char (point-min))
 340     (let ((num 0))
 341       (if (re-search-forward (or nndoc-first-article
 342                                  nndoc-article-begin) nil t)
 343           (progn
 344             (setq num 1)
 345             (while (and (re-search-forward nndoc-article-begin nil t)
 346                         (or (not nndoc-end-of-file)
 347                             (not (looking-at nndoc-end-of-file)))
 348                         (or (not nndoc-head-begin)
 349                             (re-search-forward nndoc-head-begin nil t))
 350                         (re-search-forward nndoc-head-end nil t))
 351               (setq num (1+ num)))))
 352       num)))
 353
 354 (defun nndoc-narrow-to-article (article)
 355   (save-excursion
 356     (set-buffer nndoc-current-buffer)
 357     (widen)
 358     (goto-char (point-min))
 359     (while (and (re-search-forward nndoc-article-begin nil t)
 360                 (not (zerop (setq article (1- article))))))
 361     (if (not (zerop article))
 362         ()
 363       (narrow-to-region
 364        (match-end 0)
 365        (or (and (re-search-forward nndoc-article-end nil t)
 366                 (match-beginning 0))
 367            (point-max)))
 368       t)))
 369
 370 ;; Insert article ARTICLE in the current buffer.
 371 (defun nndoc-insert-article (article)
 372   (let ((ibuf (current-buffer)))
 373     (save-excursion
 374       (set-buffer nndoc-current-buffer)
 375       (widen)
 376       (goto-char (point-min))
 377       (while (and (re-search-forward nndoc-article-begin nil t)
 378                   (not (zerop (setq article (1- article))))))
 379       (if (not (zerop article))
 380           ()
 381         (narrow-to-region
 382          (match-end 0)
 383          (or (and (re-search-forward nndoc-article-end nil t)
 384                   (match-beginning 0))
 385              (point-max)))
 386         (goto-char (point-min))
 387         (and nndoc-head-begin
 388              (re-search-forward nndoc-head-begin nil t)
 389              (narrow-to-region (point) (point-max)))
 390         (or (re-search-forward nndoc-head-end nil t)
 391             (goto-char (point-max)))
 392         (append-to-buffer ibuf (point-min) (point))
 393         (and nndoc-body-begin
 394              (re-search-forward nndoc-body-begin nil t))
 395         (append-to-buffer ibuf (point) (point-max))
 396         t))))
 397
 398 (provide 'nndoc)
 399
 400 ;;; nndoc.el ends here