cgit.sxemacs.org Git - gnus/blob - lisp/nndoc.el

   1 ;;; nndoc.el --- single file access for Gnus
   2 ;; Copyright (C) 1995,96 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 the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'nnheader)
  30 (require 'rmail)
  31 (require 'nnmail)
  32
  33 (defvar nndoc-article-type 'guess
  34   "*Type of the file.
  35 One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
  36 `mime-digest', `standard-digest', `slack-digest', `clari-briefs' or
  37 `guess'.")
  38
  39 (defvar nndoc-post-type 'mail
  40   "*Whether the nndoc group is `mail' or `post'.")
  41
  42 (defvar nndoc-type-alist
  43   `((mmdf
  44      (article-begin .  "^\^A\^A\^A\^A\n")
  45      (body-end .  "^\^A\^A\^A\^A\n"))
  46     (news
  47      (article-begin . "^Path:"))
  48     (rnews
  49      (article-begin . "^#! *rnews +\\([0-9]\\)+ *\n")
  50      (body-end-function . nndoc-rnews-body-end))
  51     (mbox
  52      (article-begin .
  53                     ,(let ((delim (concat "^" rmail-unix-mail-delimiter)))
  54                        (if (string-match "\n\\'" delim)
  55                            (substring delim 0 (match-beginning 0))
  56                          delim)))
  57      (body-end-function . nndoc-mbox-body-end))
  58     (babyl
  59      (article-begin . "\^_\^L *\n")
  60      (body-end . "\^_")
  61      (head-begin . "^[0-9].*\n"))
  62     (forward
  63      (article-begin . "^-+ Start of forwarded message -+\n+")
  64      (body-end . "^-+ End of forwarded message -+\n"))
  65     (clari-briefs
  66      (article-begin . "^ \\*")
  67      (body-end . "^\t------*[ \t]^*\n^ \\*")
  68      (body-begin . "^\t")
  69      (head-end . "^\t")
  70      (generate-head . nndoc-generate-clari-briefs-head)
  71      (article-transform . nndoc-transform-clari-briefs))
  72     (slack-digest
  73      (article-begin . "^------------------------------*[\n \t]+")
  74      (head-end . "^ ?$")
  75      (body-begin . "^ ?$")
  76      (file-end . "^End of")
  77      (prepare-body . nndoc-prepare-digest-body))
  78     (mime-digest
  79      (article-begin . "")
  80      (head-end . "^ ?$")
  81      (body-end . "")
  82      (file-end . ""))
  83     (standard-digest
  84      (first-article . ,(concat "^" (make-string 70 ?-) "\n\n"))
  85      (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n"))
  86      (prepare-body . nndoc-prepare-digest-body)
  87      (body-end-function . nndoc-digest-body-end)
  88      (file-end . "^End of .*digest.*[0-9].*\n\\*\\*"))
  89     (guess
  90      (guess . nndoc-guess-type))
  91     (digest
  92      (guess . nndoc-guess-digest-type))
  93     ))
  94
  95 \f
  96
  97 (defvar nndoc-file-begin nil)
  98 (defvar nndoc-first-article nil)
  99 (defvar nndoc-article-end nil)
 100 (defvar nndoc-article-begin nil)
 101 (defvar nndoc-head-begin nil)
 102 (defvar nndoc-head-end nil)
 103 (defvar nndoc-file-end nil)
 104 (defvar nndoc-body-begin nil)
 105 (defvar nndoc-body-end-function nil)
 106 (defvar nndoc-body-end nil)
 107 (defvar nndoc-dissection-alist nil)
 108 (defvar nndoc-prepare-body nil)
 109 (defvar nndoc-generate-head nil)
 110 (defvar nndoc-article-transform nil)
 111
 112 (defvar nndoc-current-server nil)
 113 (defvar nndoc-server-alist nil)
 114 (defvar nndoc-server-variables
 115   (list
 116    (list 'nndoc-article-type nndoc-article-type)
 117    '(nndoc-article-begin nil)
 118    '(nndoc-article-end nil)
 119    '(nndoc-head-begin nil)
 120    '(nndoc-head-end nil)
 121    '(nndoc-first-article nil)
 122    '(nndoc-current-buffer nil)
 123    '(nndoc-group-alist nil)
 124    '(nndoc-end-of-file nil)
 125    '(nndoc-body-begin nil)
 126    '(nndoc-address nil)))
 127
 128 (defconst nndoc-version "nndoc 1.0"
 129   "nndoc version.")
 130
 131 (defvar nndoc-current-buffer nil
 132   "Current nndoc news buffer.")
 133
 134 (defvar nndoc-address nil)
 135
 136 \f
 137
 138 (defvar nndoc-status-string "")
 139
 140 (defvar nndoc-group-alist nil)
 141
 142 ;;; Interface functions
 143
 144 (defun nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
 145   (when (nndoc-possibly-change-buffer newsgroup server)
 146     (save-excursion
 147       (set-buffer nntp-server-buffer)
 148       (erase-buffer)
 149       (let (article entry)
 150         (if (stringp (car articles))
 151             'headers
 152           (while articles
 153             (when (setq entry (cdr (assq (setq article (pop articles))
 154                                          nndoc-dissection-alist)))
 155               (insert (format "221 %d Article retrieved.\n" article))
 156               (if nndoc-generate-head
 157                   (funcall nndoc-generate-head article)
 158                 (insert-buffer-substring
 159                  nndoc-current-buffer (car entry) (nth 1 entry)))
 160               (goto-char (point-max))
 161               (or (= (char-after (1- (point))) ?\n) (insert "\n"))
 162               (insert (format "Lines: %d\n" (nth 4 entry)))
 163               (insert ".\n")))
 164
 165           (nnheader-fold-continuation-lines)
 166           'headers)))))
 167
 168 (defun nndoc-open-server (server &optional defs)
 169   (nnheader-init-server-buffer)
 170   (if (equal server nndoc-current-server)
 171       t
 172     (if nndoc-current-server
 173         (setq nndoc-server-alist
 174               (cons (list nndoc-current-server
 175                           (nnheader-save-variables nndoc-server-variables))
 176                     nndoc-server-alist)))
 177     (let ((state (assoc server nndoc-server-alist)))
 178       (if state
 179           (progn
 180             (nnheader-restore-variables (nth 1 state))
 181             (setq nndoc-server-alist (delq state nndoc-server-alist)))
 182         (nnheader-set-init-variables nndoc-server-variables defs)))
 183     (setq nndoc-current-server server)
 184     t))
 185
 186 (defun nndoc-close-server (&optional server)
 187   t)
 188
 189 (defun nndoc-server-opened (&optional server)
 190   (and (equal server nndoc-current-server)
 191        nntp-server-buffer
 192        (buffer-name nntp-server-buffer)))
 193
 194 (defun nndoc-status-message (&optional server)
 195   nndoc-status-string)
 196
 197 (defun nndoc-request-article (article &optional newsgroup server buffer)
 198   (nndoc-possibly-change-buffer newsgroup server)
 199   (save-excursion
 200     (let ((buffer (or buffer nntp-server-buffer))
 201           (entry (cdr (assq article nndoc-dissection-alist)))
 202           beg)
 203       (set-buffer buffer)
 204       (erase-buffer)
 205       (if (stringp article)
 206           nil
 207         (insert-buffer-substring
 208          nndoc-current-buffer (car entry) (nth 1 entry))
 209         (insert "\n")
 210         (setq beg (point))
 211         (insert-buffer-substring
 212          nndoc-current-buffer (nth 2 entry) (nth 3 entry))
 213         (goto-char beg)
 214         (when nndoc-prepare-body
 215           (funcall nndoc-prepare-body))
 216         (when nndoc-article-transform
 217           (funcall nndoc-article-transform article))
 218         t))))
 219
 220 (defun nndoc-request-group (group &optional server dont-check)
 221   "Select news GROUP."
 222   (save-excursion
 223     (let (number)
 224       (cond
 225        ((not (nndoc-possibly-change-buffer group server))
 226         (nnheader-report 'nndoc "No such file or buffer: %s"
 227                          nndoc-address))
 228        (dont-check
 229         (nnheader-report 'nndoc "Selected group %s" group)
 230         t)
 231        ((zerop (setq number (length nndoc-dissection-alist)))
 232         (nndoc-close-group group)
 233         (nnheader-report 'nndoc "No articles in group %s" group))
 234        (t
 235         (save-excursion
 236           (set-buffer nntp-server-buffer)
 237           (erase-buffer)
 238           (insert (format "211 %d %d %d %s\n" number 1 number group))
 239           t))))))
 240
 241 (defun nndoc-request-type (group &optional article)
 242   (cond ((not article) 'unknown)
 243         (nndoc-post-type nndoc-post-type)
 244         (t 'unknown)))
 245
 246 (defun nndoc-close-group (group &optional server)
 247   (nndoc-possibly-change-buffer group server)
 248   (and nndoc-current-buffer
 249        (buffer-name nndoc-current-buffer)
 250        (kill-buffer nndoc-current-buffer))
 251   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
 252                                 nndoc-group-alist))
 253   (setq nndoc-current-buffer nil)
 254   (setq nndoc-current-server nil)
 255   (setq nndoc-dissection-alist nil)
 256   t)
 257
 258 (defun nndoc-request-list (&optional server)
 259   nil)
 260
 261 (defun nndoc-request-newgroups (date &optional server)
 262   nil)
 263
 264 (defun nndoc-request-list-newsgroups (&optional server)
 265   nil)
 266
 267 (defalias 'nndoc-request-post 'nnmail-request-post)
 268
 269 \f
 270 ;;; Internal functions.
 271
 272 (defun nndoc-possibly-change-buffer (group source)
 273   (let (buf)
 274     (cond
 275      ;; The current buffer is this group's buffer.
 276      ((and nndoc-current-buffer
 277            (buffer-name nndoc-current-buffer)
 278            (eq nndoc-current-buffer
 279                (setq buf (cdr (assoc group nndoc-group-alist))))))
 280      ;; We change buffers by taking an old from the group alist.
 281      ;; `source' is either a string (a file name) or a buffer object.
 282      (buf
 283       (setq nndoc-current-buffer buf))
 284      ;; It's a totally new group.
 285      ((or (and (bufferp nndoc-address)
 286                (buffer-name nndoc-address))
 287           (and (stringp nndoc-address)
 288                (file-exists-p nndoc-address)
 289                (not (file-directory-p nndoc-address))))
 290       (setq nndoc-group-alist
 291             (cons (cons group (setq nndoc-current-buffer
 292                                     (get-buffer-create
 293                                      (concat " *nndoc " group "*"))))
 294                   nndoc-group-alist))
 295       (setq nndoc-dissection-alist nil)
 296       (save-excursion
 297         (set-buffer nndoc-current-buffer)
 298         (buffer-disable-undo (current-buffer))
 299         (erase-buffer)
 300         (if (stringp nndoc-address)
 301             (insert-file-contents nndoc-address)
 302           (insert-buffer-substring nndoc-address)))))
 303     (when (and nndoc-current-buffer
 304                (not nndoc-dissection-alist))
 305       (save-excursion
 306         (set-buffer nndoc-current-buffer)
 307         (nndoc-set-delims)
 308         (nndoc-dissect-buffer)))
 309     t))
 310
 311 ;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
 312 (defun nndoc-guess-digest-type ()
 313   (let ((case-fold-search t)            ; We match a bit too much, keep it simple.
 314         boundary-id b-delimiter entry)
 315     (goto-char (point-min))
 316     (cond
 317      ;; MIME digest.
 318      ((and
 319        (re-search-forward
 320         (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
 321                 "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
 322         nil t)
 323        (match-beginning 1))
 324       (setq boundary-id (match-string 1)
 325             b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
 326       (setq entry (assq 'mime-digest nndoc-type-alist))
 327       (setcdr entry
 328               (list
 329                (cons 'head-end "^ ?$")
 330                (cons 'body-begin "^ ?\n")
 331                (cons 'article-begin b-delimiter)
 332                (cons 'body-end-function 'nndoc-digest-body-end)
 333 ;              (cons 'body-end
 334 ;                    (concat "\n--" boundary-id "\\(--\\)?[\n \t]+"))
 335                (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
 336       'mime-digest)
 337      ((and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
 338            (re-search-forward
 339             (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
 340       'standard-digest)
 341      ;; Stupid digest.
 342      (t
 343       'slack-digest))))
 344
 345 (defun nndoc-guess-type ()
 346   "Guess what document type is in the current buffer."
 347   (goto-char (point-min))
 348   (cond
 349    ((looking-at rmail-unix-mail-delimiter)
 350     'mbox)
 351    ((looking-at "\^A\^A\^A\^A$")
 352     'mmdf)
 353    ((looking-at "^Path:.*\n")
 354     'news)
 355    ((looking-at "#! *rnews")
 356     'rnews)
 357    ((re-search-forward "\^_\^L *\n" nil t)
 358     'babyl)
 359    ((save-excursion
 360       (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
 361            (not (re-search-forward "^Subject:.*digest" nil t))))
 362     'forward)
 363    ((let ((case-fold-search nil))
 364       (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
 365     'clari-briefs)
 366    (t
 367     'digest)))
 368
 369 (defun nndoc-set-delims ()
 370   (let ((vars '(nndoc-file-begin
 371                 nndoc-first-article
 372                 nndoc-article-end nndoc-head-begin nndoc-head-end
 373                 nndoc-file-end nndoc-article-begin
 374                 nndoc-body-begin nndoc-body-end-function nndoc-body-end
 375                 nndoc-prepare-body nndoc-article-transform
 376                 nndoc-generate-head)))
 377     (while vars
 378       (set (pop vars) nil)))
 379   (let* (defs guess)
 380     ;; Guess away until we find the real file type.
 381     (while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist))
 382                  guess (assq 'guess defs))
 383       (setq nndoc-article-type (funcall (cdr guess))))
 384     (while defs
 385       (set (intern (format "nndoc-%s" (car (car defs))))
 386            (cdr (pop defs))))))
 387
 388 (defun nndoc-search (regexp)
 389   (prog1
 390       (re-search-forward regexp nil t)
 391     (beginning-of-line)))
 392
 393 (defun nndoc-dissect-buffer ()
 394   (let ((i 0)
 395         (first t)
 396         head-begin head-end body-begin body-end)
 397     (setq nndoc-dissection-alist nil)
 398     (save-excursion
 399       (set-buffer nndoc-current-buffer)
 400       (goto-char (point-min))
 401       ;; Find the beginning of the file.
 402       (when nndoc-file-begin
 403         (nndoc-search nndoc-file-begin))
 404       ;; Go through the file.
 405       (while (if (and first nndoc-first-article)
 406                  (nndoc-search nndoc-first-article)
 407                (nndoc-search nndoc-article-begin))
 408         (setq first nil)
 409         (when nndoc-head-begin
 410           (nndoc-search nndoc-head-begin))
 411         (if (and nndoc-file-end
 412                  (looking-at nndoc-file-end))
 413             (goto-char (point-max))
 414           (setq head-begin (point))
 415           (nndoc-search (or nndoc-head-end "^$"))
 416           (setq head-end (point))
 417           (nndoc-search (or nndoc-body-begin "^\n"))
 418           (setq body-begin (point))
 419           (or (and nndoc-body-end-function
 420                    (funcall nndoc-body-end-function))
 421               (and nndoc-body-end
 422                    (nndoc-search nndoc-body-end))
 423               (nndoc-search nndoc-article-begin)
 424               (progn
 425                 (goto-char (point-max))
 426                 (when nndoc-file-end
 427                   (and (re-search-backward nndoc-file-end nil t)
 428                        (beginning-of-line)))))
 429           (setq body-end (point))
 430           (push (list (incf i) head-begin head-end body-begin body-end
 431                       (count-lines body-begin body-end))
 432                 nndoc-dissection-alist))))))
 433
 434 (defun nndoc-prepare-digest-body ()
 435   "Unquote quoted non-separators in digests."
 436   (while (re-search-forward "^- -"nil t)
 437     (replace-match "-" t t)))
 438
 439 (defun nndoc-digest-body-end ()
 440   (and (re-search-forward nndoc-article-begin nil t)
 441        (goto-char (match-beginning 0))))
 442
 443 (defun nndoc-mbox-body-end ()
 444   (let ((beg (point))
 445         len end)
 446     (when
 447         (save-excursion
 448           (and (re-search-backward nndoc-article-begin nil t)
 449                (setq end (point))
 450                (search-forward "\n\n" beg t)
 451                (re-search-backward "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
 452                (setq len (string-to-int (match-string 1)))
 453                (search-forward "\n\n" beg t)
 454                (or (= (setq len (+ (point) len)) (point-max))
 455                    (and (< len (point-max))
 456                         (goto-char len)
 457                         (looking-at nndoc-article-begin)))))
 458       (goto-char len))))
 459
 460 (defun nndoc-rnews-body-end ()
 461   (save-excursion
 462     (and (re-search-backward nndoc-article-begin nil t)
 463          (goto-char (+ (point) (string-to-int (match-string 1)))))))
 464
 465 (defun nndoc-transform-clari-briefs (article)
 466   (goto-char (point-min))
 467   (when (looking-at " *\\*\\(.*\\)\n")
 468     (replace-match "" t t))
 469   (nndoc-generate-clari-briefs-head article))
 470
 471 (defun nndoc-generate-clari-briefs-head (article)
 472   (let ((entry (cdr (assq article nndoc-dissection-alist)))
 473         subject from)
 474     (save-excursion
 475       (set-buffer nndoc-current-buffer)
 476       (save-restriction
 477         (narrow-to-region (car entry) (nth 3 entry))
 478         (goto-char (point-min))
 479         (when (looking-at " *\\*\\(.*\\)$")
 480           (setq subject (match-string 1)))
 481         (when
 482             (let ((case-fold-search nil))
 483               (re-search-forward
 484                "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
 485           (setq from (match-string 1)))))
 486     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
 487             "\nSubject: " (or subject "(no subject)") "\n")))
 488
 489 (provide 'nndoc)
 490
 491 ;;; nndoc.el ends here