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