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