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 - 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
 261 \f
 262 ;;; Internal functions.
 263
 264 (defun nndoc-possibly-change-buffer (group source)
 265   (let (buf)
 266     (cond
 267      ;; The current buffer is this group's buffer.
 268      ((and 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       (save-excursion
 287         (set-buffer nndoc-current-buffer)
 288         (buffer-disable-undo (current-buffer))
 289         (erase-buffer)
 290         (if (stringp nndoc-address)
 291             (insert-file-contents nndoc-address)
 292           (save-excursion
 293             (set-buffer nndoc-address)
 294             (widen))
 295           (insert-buffer-substring nndoc-address))
 296         t)))))
 297
 298 ;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
 299 (defun nndoc-set-header-dependent-regexps ()
 300   (if (not (eq nndoc-article-type 'digest))
 301       ()
 302     (let ((case-fold-search t)          ; We match a bit too much, keep it simple.
 303           (boundary-id) (b-delimiter))
 304       (save-excursion
 305         (set-buffer nndoc-current-buffer)
 306         (goto-char (point-min))
 307         (if (and
 308              (re-search-forward
 309               (concat "\n\n\\|^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
 310                       "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
 311               nil t)
 312              (match-beginning 1))
 313             (setq nndoc-digest-type 'rfc1341
 314                   boundary-id (format "%s"
 315                                       (buffer-substring
 316                                        (match-beginning 1) (match-end 1)))
 317                   b-delimiter       (concat "\n--" boundary-id "[\n \t]+")
 318                   nndoc-article-begin b-delimiter ; Too strict: "[ \t]*$"
 319                   nndoc-article-end (concat "\n--" boundary-id
 320                                             "\\(--\\)?[\n \t]+")
 321                   nndoc-first-article b-delimiter ; ^eof ends article too.
 322                   nndoc-end-of-file (concat "\n--" boundary-id "--[ \t]*$"))
 323           (setq nndoc-digest-type 'traditional))))))
 324
 325 (defun nndoc-forward-article (n)
 326   (while (and (> n 0)
 327               (re-search-forward nndoc-article-begin nil t)
 328               (or (not nndoc-head-begin)
 329                   (re-search-forward nndoc-head-begin nil t))
 330               (re-search-forward nndoc-head-end nil t))
 331     (setq n (1- n)))
 332   (zerop n))
 333
 334 (defun nndoc-number-of-articles ()
 335   (save-excursion
 336     (set-buffer nndoc-current-buffer)
 337     (widen)
 338     (goto-char (point-min))
 339     (let ((num 0))
 340       (if (re-search-forward (or nndoc-first-article
 341                                  nndoc-article-begin) nil t)
 342           (progn
 343             (setq num 1)
 344             (while (and (re-search-forward nndoc-article-begin nil t)
 345                         (or (not nndoc-end-of-file)
 346                             (not (looking-at nndoc-end-of-file)))
 347                         (or (not nndoc-head-begin)
 348                             (re-search-forward nndoc-head-begin nil t))
 349                         (re-search-forward nndoc-head-end nil t))
 350               (setq num (1+ num)))))
 351       num)))
 352
 353 (defun nndoc-narrow-to-article (article)
 354   (save-excursion
 355     (set-buffer nndoc-current-buffer)
 356     (widen)
 357     (goto-char (point-min))
 358     (while (and (re-search-forward nndoc-article-begin nil t)
 359                 (not (zerop (setq article (1- article))))))
 360     (if (not (zerop article))
 361         ()
 362       (narrow-to-region
 363        (match-end 0)
 364        (or (and (re-search-forward nndoc-article-end nil t)
 365                 (match-beginning 0))
 366            (point-max)))
 367       t)))
 368
 369 ;; Insert article ARTICLE in the current buffer.
 370 (defun nndoc-insert-article (article)
 371   (let ((ibuf (current-buffer)))
 372     (save-excursion
 373       (set-buffer nndoc-current-buffer)
 374       (widen)
 375       (goto-char (point-min))
 376       (while (and (re-search-forward nndoc-article-begin nil t)
 377                   (not (zerop (setq article (1- article))))))
 378       (if (not (zerop article))
 379           ()
 380         (narrow-to-region
 381          (match-end 0)
 382          (or (and (re-search-forward nndoc-article-end nil t)
 383                   (match-beginning 0))
 384              (point-max)))
 385         (goto-char (point-min))
 386         (and nndoc-head-begin
 387              (re-search-forward nndoc-head-begin nil t)
 388              (narrow-to-region (point) (point-max)))
 389         (or (re-search-forward nndoc-head-end nil t)
 390             (goto-char (point-max)))
 391         (append-to-buffer ibuf (point-min) (point))
 392         (and nndoc-body-begin
 393              (re-search-forward nndoc-body-begin nil t))
 394         (append-to-buffer ibuf (point) (point-max))
 395         t))))
 396
 397 (provide 'nndoc)
 398
 399 ;;; nndoc.el ends here