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