X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnndoc.el;h=c1ac47dd59454d654c13bc12cb994df8cff7de8c;hb=cb1472a3d69d4e24415010ee79c375b5ebff14fd;hp=a109f5472a173d92b1800e7701089edbfbc02887;hpb=80b1b5678cd36bcd6d0a90ae94fec6538c983b5e;p=gnus diff --git a/lisp/nndoc.el b/lisp/nndoc.el index a109f5472..c1ac47dd5 100644 --- a/lisp/nndoc.el +++ b/lisp/nndoc.el @@ -29,135 +29,209 @@ (require 'rmail) (require 'nnmail) +(defvar nndoc-article-type 'mbox + "*Type of the file. +One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', +`forward', `mime-digest', `standard-digest', `slack-digest', or +`guess'.") + +(defvar nndoc-type-alist + `((mmdf + (article-begin . "^\^A\^A\^A\^A\n") + (body-end . "^\^A\^A\^A\^A\n")) + (news + (article-begin . "^Path:")) + (rnews + (article-begin . "^#! *rnews +\\([0-9]\\)+ *\n") + (body-end-function . nndoc-rnews-body-end)) + (mbox + (article-begin . + ,(let ((delim (concat "^" rmail-unix-mail-delimiter))) + (if (string-match "\n\\'" delim) + (substring delim 0 (match-beginning 0)) + delim))) + (body-end-function . nndoc-mbox-body-end)) + (babyl + (article-begin . "\^_\^L *\n") + (body-end . "\^_") + (head-begin . "^[0-9].*\n")) + (forward + (article-begin . "^-+ Start of forwarded message -+\n+") + (body-end . "^-+ End of forwarded message -+\n")) + (slack-digest + (article-begin . "^------------------------------*[\n \t]+") + (head-end . "^ ?$") + (body-begin . "^ ?$") + (file-end . "^End of") + (prepare-body . nndoc-prepare-digest-body)) + (mime-digest + (article-begin . "") + (body-end . "") + (file-end . "")) + (standard-digest + (first-article . ,(concat "^" (make-string 70 ?-) "\n\n")) + (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n")) + (prepare-body . nndoc-prepare-digest-body) + (body-end-function . nndoc-digest-body-end) + (file-end . "^End of .* Digest")) + (guess + (guess . nndoc-guess-type)) + (digest + (guess . nndoc-guess-digest-type)) + )) + -(defconst nndoc-version "nndoc 0.1" +(defvar nndoc-file-begin nil) +(defvar nndoc-first-article nil) +(defvar nndoc-article-end nil) +(defvar nndoc-article-begin nil) +(defvar nndoc-head-begin nil) +(defvar nndoc-head-end nil) +(defvar nndoc-file-end nil) +(defvar nndoc-body-begin nil) +(defvar nndoc-body-end-function nil) +(defvar nndoc-body-end nil) +(defvar nndoc-dissection-alist nil) +(defvar nndoc-prepare-body nil) + +(defvar nndoc-current-server nil) +(defvar nndoc-server-alist nil) +(defvar nndoc-server-variables + (list + (list 'nndoc-article-type nndoc-article-type) + '(nndoc-article-begin nil) + '(nndoc-article-end nil) + '(nndoc-head-begin nil) + '(nndoc-head-end nil) + '(nndoc-first-article nil) + '(nndoc-current-buffer nil) + '(nndoc-group-alist nil) + '(nndoc-end-of-file nil) + '(nndoc-body-begin nil) + '(nndoc-address nil))) + +(defconst nndoc-version "nndoc 1.0" "nndoc version.") (defvar nndoc-current-buffer nil "Current nndoc news buffer.") +(defvar nndoc-address nil) + + + (defvar nndoc-status-string "") (defvar nndoc-group-alist nil) ;;; Interface functions -(defun nndoc-retrieve-headers (sequence &optional newsgroup server) - "Retrieve the headers for the articles in SEQUENCE. -Newsgroup must be selected before calling this function." - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((file nil) - (number (length sequence)) - (count 0) - beg article art-string start stop lines) - (nndoc-possibly-change-buffer newsgroup server) - (while sequence - (setq article (car sequence)) - (set-buffer nndoc-current-buffer) - (if (nndoc-search-for-article article) - (progn - (setq start - (save-excursion - (or - (re-search-backward - (concat "^" rmail-unix-mail-delimiter) nil t) - (point-min)))) - (search-forward "\n\n" nil t) - (setq lines (count-lines - (point) - (or - (save-excursion - (re-search-forward - (concat "^" rmail-unix-mail-delimiter) nil t)) - (point-max)))) - (setq stop (1- (point))) - (set-buffer nntp-server-buffer) - (insert (format "221 %d Article retrieved.\n" article)) - (setq beg (point)) - (insert-buffer-substring nndoc-current-buffer start stop) - (goto-char (point-max)) - (insert (format "Lines: %d\n" lines)) - (insert ".\n"))) - (setq sequence (cdr sequence))) - - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - 'headers))) - -(defun nndoc-open-server (host &optional service) - "Open mbox backend." - (setq nndoc-status-string "") - (setq nndoc-group-alist nil) - (nnheader-init-server-buffer)) +(defun nndoc-retrieve-headers (articles &optional newsgroup server fetch-old) + (when (nndoc-possibly-change-buffer newsgroup server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (article entry) + (if (stringp (car articles)) + 'headers + (while articles + (setq entry (cdr (assq (setq article (pop articles)) + nndoc-dissection-alist))) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring + nndoc-current-buffer (car entry) (nth 1 entry)) + (goto-char (point-max)) + (or (= (char-after (1- (point))) ?\n) (insert "\n")) + (insert (format "Lines: %d\n" (nth 4 entry))) + (insert ".\n")) + + ;; Fold continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) + (replace-match " " t t)) + 'headers))))) + +(defun nndoc-open-server (server &optional defs) + (nnheader-init-server-buffer) + (if (equal server nndoc-current-server) + t + (if nndoc-current-server + (setq nndoc-server-alist + (cons (list nndoc-current-server + (nnheader-save-variables nndoc-server-variables)) + nndoc-server-alist))) + (let ((state (assoc server nndoc-server-alist))) + (if state + (progn + (nnheader-restore-variables (nth 1 state)) + (setq nndoc-server-alist (delq state nndoc-server-alist))) + (nnheader-set-init-variables nndoc-server-variables defs))) + (setq nndoc-current-server server) + t)) (defun nndoc-close-server (&optional server) - "Close news server." t) (defun nndoc-server-opened (&optional server) - "Return server process status." - (and nntp-server-buffer - (get-buffer nntp-server-buffer))) + (and (equal server nndoc-current-server) + nntp-server-buffer + (buffer-name nntp-server-buffer))) (defun nndoc-status-message (&optional server) - "Return server status response as string." nndoc-status-string) (defun nndoc-request-article (article &optional newsgroup server buffer) - "Select ARTICLE by number." (nndoc-possibly-change-buffer newsgroup server) - (if (stringp article) - nil - (save-excursion - (set-buffer nndoc-current-buffer) - (if (nndoc-search-for-article article) - (let (start stop) - (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t) - (forward-line 1) - (setq start (point)) - (or (and (re-search-forward - (concat "^" rmail-unix-mail-delimiter) nil t) - (forward-line -1)) - (goto-char (point-max))) - (setq stop (point)) - (let ((nntp-server-buffer (or buffer nntp-server-buffer))) - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring nndoc-current-buffer start stop) - t)))))) + (save-excursion + (let ((buffer (or buffer nntp-server-buffer)) + (entry (cdr (assq article nndoc-dissection-alist))) + beg) + (set-buffer buffer) + (erase-buffer) + (if (stringp article) + nil + (insert-buffer-substring + nndoc-current-buffer (car entry) (nth 1 entry)) + (insert "\n") + (setq beg (point)) + (insert-buffer-substring + nndoc-current-buffer (nth 2 entry) (nth 3 entry)) + (goto-char beg) + (when nndoc-prepare-body + (funcall nndoc-prepare-body)) + t)))) (defun nndoc-request-group (group &optional server dont-check) "Select news GROUP." (save-excursion (if (not (nndoc-possibly-change-buffer group server)) (progn - (setq nndoc-status-string "No such file") + (setq nndoc-status-string "No such file or buffer") nil) (if dont-check t (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) - (let ((number (nndoc-number-of-articles))) + (let ((number (length nndoc-dissection-alist))) (if (zerop number) (progn (nndoc-close-group group) nil) - (insert (format "211 %d %d %d %s\n" - number 1 number group)) + (insert (format "211 %d %d %d %s\n" number 1 number group)) t))))))) (defun nndoc-close-group (group &optional server) (nndoc-possibly-change-buffer group server) - (kill-buffer nndoc-current-buffer) + (and nndoc-current-buffer + (buffer-name nndoc-current-buffer) + (kill-buffer nndoc-current-buffer)) (setq nndoc-group-alist (delq (assoc group nndoc-group-alist) nndoc-group-alist)) (setq nndoc-current-buffer nil) + (setq nndoc-current-server nil) + (setq nndoc-dissection-alist nil) t) (defun nndoc-request-list (&optional server) @@ -169,59 +243,191 @@ Newsgroup must be selected before calling this function." (defun nndoc-request-list-newsgroups (&optional server) nil) -(defun nndoc-request-post (&optional server) - (mail-send-and-exit nil)) - -(fset 'nndoc-request-post-buffer 'nnmail-request-post-buffer) +(defalias 'nndoc-request-post 'nnmail-request-post) ;;; Internal functions. -(defun nndoc-possibly-change-buffer (group file) +(defun nndoc-possibly-change-buffer (group source) (let (buf) - (or (and nndoc-current-buffer - (eq nndoc-current-buffer - (setq buf (cdr (assoc group nndoc-group-alist))))) - (if buf - (setq nndoc-current-buffer buf) - (if (or (not (file-exists-p file)) - (file-directory-p file)) - () - (setq nndoc-group-alist - (cons (cons group (setq nndoc-current-buffer - (get-buffer-create - (concat " *nndoc " group "*")))) - nndoc-group-alist)) - (save-excursion - (set-buffer nndoc-current-buffer) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-file-contents file) - t)))))) - -(defun nndoc-number-of-articles () - (save-excursion - (set-buffer nndoc-current-buffer) - (goto-char (point-min)) - (let ((num 0) - (delim (concat "^" rmail-unix-mail-delimiter))) - (while (re-search-forward delim nil t) - (setq num (1+ num))) - num))) - -(defun nndoc-search-for-article (article) - (let ((obuf (current-buffer))) - (set-buffer nndoc-current-buffer) + (cond + ;; The current buffer is this group's buffer. + ((and nndoc-current-buffer + (eq nndoc-current-buffer + (setq buf (cdr (assoc group nndoc-group-alist)))))) + ;; We change buffers by taking an old from the group alist. + ;; `source' is either a string (a file name) or a buffer object. + (buf + (setq nndoc-current-buffer buf)) + ;; It's a totally new group. + ((or (and (bufferp nndoc-address) + (buffer-name nndoc-address)) + (and (stringp nndoc-address) + (file-exists-p nndoc-address) + (not (file-directory-p nndoc-address)))) + (setq nndoc-group-alist + (cons (cons group (setq nndoc-current-buffer + (get-buffer-create + (concat " *nndoc " group "*")))) + nndoc-group-alist)) + (save-excursion + (set-buffer nndoc-current-buffer) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (if (stringp nndoc-address) + (insert-file-contents nndoc-address) + (insert-buffer-substring nndoc-address))))) + (when nndoc-current-buffer + (save-excursion + (set-buffer nndoc-current-buffer) + (nndoc-set-delims) + (nndoc-dissect-buffer)) + t))) + +;; MIME (RFC 1341) digest hack by Ulrik Dickow . +(defun nndoc-guess-digest-type () + (let ((case-fold-search t) ; We match a bit too much, keep it simple. + boundary-id b-delimiter entry) (goto-char (point-min)) - (let ((delim (concat "^" rmail-unix-mail-delimiter))) - (while (and (re-search-forward delim nil t) - (not (zerop (setq article (1- article)))))) - (set-buffer obuf) - (if (zerop article) - (progn - (forward-line 1) - t) - nil)))) + (cond + ;; MIME digest. + ((and + (re-search-forward + (concat "\n\n\\|^Content-Type: *multipart/digest;[ \t\n]*[ \t]" + "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"") + nil t) + (match-beginning 1)) + (setq boundary-id (match-string 1) + b-delimiter (concat "\n--" boundary-id "[\n \t]+")) + (setq entry (assq 'mime-digest nndoc-type-alist)) + (setcdr entry + (list + (cons 'article-begin b-delimiter) + (cons 'body-end + (concat "\n--" boundary-id "\\(--\\)?[\n \t]+")) + (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$")))) + 'mime-digest) + ((and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t) + (re-search-forward + (concat "\n\n" (make-string 30 ?-) "\n\n") nil t)) + 'standard-digest) + ;; Stupid digest. + (t + 'slack-digest)))) + +(defun nndoc-guess-type () + "Guess what document type is in the current buffer." + (goto-char (point-min)) + (cond + ((looking-at rmail-unix-mail-delimiter) + 'mbox) + ((looking-at "\^A\^A\^A\^A$") + 'mmdf) + ((looking-at "^Path:.*\n") + 'rnews) + ((save-excursion + (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t) + (not (re-search-forward "^Subject:.*digest" nil t)))) + 'forward) + ((re-search-forward "\^_\^L *\n" nil t) + 'babyl) + ((re-search-forward "^Path: .*!" nil t) + 'news) + (t + 'digest))) + +(defun nndoc-set-delims () + (let ((vars '(nndoc-file-begin + nndoc-first-article + nndoc-article-end nndoc-head-begin nndoc-head-end + nndoc-file-end nndoc-article-begin + nndoc-body-begin nndoc-body-end-function nndoc-body-end + nndoc-prepare-body))) + (while vars + (set (pop vars) nil))) + (let* (defs guess) + ;; Guess away until we find the real file type. + (while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist)) + guess (assq 'guess defs)) + (setq nndoc-article-type (funcall (cdr guess)))) + (while defs + (set (intern (format "nndoc-%s" (car (car defs)))) + (cdr (pop defs)))))) + +(defun nndoc-search (regexp) + (prog1 + (re-search-forward regexp nil t) + (beginning-of-line))) + +(defun nndoc-dissect-buffer () + (let ((i 0) + (first t) + head-begin head-end body-begin body-end) + (setq nndoc-dissection-alist nil) + (save-excursion + (set-buffer nndoc-current-buffer) + (goto-char (point-min)) + ;; Find the beginning of the file. + (when nndoc-file-begin + (nndoc-search nndoc-file-begin)) + ;; Go through the file. + (while (if (and first nndoc-first-article) + (nndoc-search nndoc-first-article) + (nndoc-search nndoc-article-begin)) + (setq first nil) + (when nndoc-head-begin + (nndoc-search nndoc-head-begin)) + (setq head-begin (point)) + (nndoc-search (or nndoc-head-end "^$")) + (setq head-end (point)) + (nndoc-search (or nndoc-body-begin "^\n")) + (setq body-begin (point)) + (or (and nndoc-body-end-function + (funcall nndoc-body-end-function)) + (and nndoc-body-end + (nndoc-search nndoc-body-end)) + (nndoc-search nndoc-article-begin) + (progn + (goto-char (point-max)) + (when nndoc-file-end + (and (re-search-backward nndoc-file-end nil t) + (beginning-of-line))))) + (setq body-end (point)) + (push (list (incf i) head-begin head-end body-begin body-end + (count-lines body-begin body-end)) + nndoc-dissection-alist) + )))) + +(defun nndoc-prepare-digest-body () + "Unquote quoted non-separators in digests." + (while (re-search-forward "^- -"nil t) + (replace-match "-" t t))) + +(defun nndoc-digest-body-end () + (and (re-search-forward nndoc-article-begin nil t) + (goto-char (match-beginning 0)))) + +(defun nndoc-mbox-body-end () + (let ((beg (point)) + len end) + (when + (save-excursion + (and (re-search-backward nndoc-article-begin nil t) + (setq end (point)) + (search-forward "\n\n" beg t) + (re-search-backward "^Content-Length: \\([0-9]+\\) *$" end t) + (setq len (string-to-int (match-string 1))) + (search-forward "\n\n" beg t) + (or (= (setq len (+ (point) len)) (point-max)) + (and (< len (point-max)) + (goto-char len) + (looking-at nndoc-article-begin))))) + (goto-char len)))) + +(defun nndoc-rnews-body-end () + (save-excursion + (and (re-search-backward nndoc-article-begin nil t) + (goto-char (+ (point) (string-to-int (match-string 1))))))) (provide 'nndoc)