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