lisp/nndoc.el

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