From 15bca14d69bdc8f35f4ddfc5bd4881872661889c Mon Sep 17 00:00:00 2001 From: yamaoka Date: Tue, 29 May 2001 11:31:02 +0000 Subject: [PATCH] * nnshimbun.el (nnshimbun-retrieve-headers-with-nov): Don't use `last'. (nnshimbun-make-shimbun-header): Use the following macros. (nnshimbun-mail-header-from): New macro whose definition will be changed statically for Gnus or gnus. (nnshimbun-mail-header-subject): Ditto. (TopLevel): Don't require `gnus-clfns'. * gnus.el: Add autoload for `find-cl-run-time-functions'. * gnus-clfns.el (find-cl-run-time-functions): New command for the developers. (cl-run-time-functions): New variable. (TopLevel): Don't require `cl' at run-time. --- ChangeLog | 17 ++++++ lisp/gnus-clfns.el | 158 +++++++++++++++++++++++++++++++++++++++++++++++++++- lisp/gnus.el | 3 + lisp/nnshimbun.el | 80 ++++++++++++++++---------- 4 files changed, 227 insertions(+), 31 deletions(-) diff --git a/ChangeLog b/ChangeLog index a34d97e..25534bc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2001-05-29 Katsumi Yamaoka + + * lisp/nnshimbun.el (nnshimbun-retrieve-headers-with-nov): Don't + use `last'. + (nnshimbun-make-shimbun-header): Use the following macros. + (nnshimbun-mail-header-from): New macro whose definition will be + changed statically for Gnus or gnus. + (nnshimbun-mail-header-subject): Ditto. + (TopLevel): Don't require `gnus-clfns'. + + * lisp/gnus.el: Add autoload for `find-cl-run-time-functions'. + + * lisp/gnus-clfns.el (find-cl-run-time-functions): New command for + the developers. + (cl-run-time-functions): New variable. + (TopLevel): Don't require `cl' at run-time. + 2001-05-28 TSUCHIYA Masatoshi * texi/gnus-ja.texi (Web Newspaper): Updated. diff --git a/lisp/gnus-clfns.el b/lisp/gnus-clfns.el index c9257cd..cbd342b 100644 --- a/lisp/gnus-clfns.el +++ b/lisp/gnus-clfns.el @@ -31,7 +31,7 @@ (if (featurep 'xemacs) nil - (require 'cl) + (eval-when-compile (require 'cl)) (require 'pym) (define-compiler-macro butlast (&whole form x &optional n) @@ -176,6 +176,162 @@ res))))))))) ) +;; A tool for the developers. + +(defvar cl-run-time-functions + '(Values + Values-list acons assoc-if assoc-if-not build-klist butlast ceiling* + coerce common-lisp-indent-function compiler-macroexpand concatenate + copy-list count count-if count-if-not delete* delete-duplicates delete-if + delete-if-not duplicate-symbols-p elt-satisfies-test-p equalp evenp every + extract-from-klist fill find find-if find-if-not floatp-safe floor* gcd + gensym gentemp get-setf-method getf hash-table-count hash-table-p + intersection isqrt keyword-argument-supplied-p keyword-of keywordp last + lcm ldiff lisp-indent-259 lisp-indent-do lisp-indent-function-lambda-hack + lisp-indent-report-bad-format lisp-indent-tagbody list-length + make-hash-table make-random-state map mapc mapcan mapcar* mapcon mapl + maplist member-if member-if-not merge mismatch mod* nbutlast nintersection + notany notevery nreconc nset-difference nset-exclusive-or nsublis nsubst + nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not + nunion oddp pair-with-newsyms pairlis position position-if position-if-not + proclaim random* random-state-p rassoc* rassoc-if rassoc-if-not + reassemble-argslists reduce rem* remove remove* remove-duplicates + remove-if remove-if-not remq replace revappend round* safe-idiv search + set-difference set-exclusive-or setelt setnth setnthcdr signum some sort* + stable-sort sublis subseq subsetp subst subst-if subst-if-not substitute + substitute-if substitute-if-not tailp tree-equal truncate* union + unzip-lists zip-lists) + "A list of CL run-time functions. Some functions were built-in, nowadays.") + +;;;###autoload +(defun find-cl-run-time-functions (file-or-directory in-this-emacs) + "Find CL run-time functions in the FILE-OR-DIRECTORY. If the optional +IN-THIS-EMACS is non-nil, the built-in functions in this emacs will +not be reported." + (interactive (list (read-file-name "Find CL run-time functions in: " + nil default-directory t) + current-prefix-arg)) + (unless (interactive-p) + (error "You should invoke `M-x find-cl-run-time-functions' interactively")) + (let (files clfns working file forms fns pt lines form fn buffer + buffer-file-format format-alist + insert-file-contents-post-hook insert-file-contents-pre-hook + jam-zcat-filename-list jka-compr-compression-info-list) + (cond ((file-directory-p file-or-directory) + (prog1 + (setq files (directory-files file-or-directory t "\\.el$")) + (unless files + (message "No files found in: %s" file-or-directory)))) + ((file-exists-p file-or-directory) + (setq files (list file-or-directory))) + (t + (message "No such file or directory: %s" file-or-directory))) + (if files + (progn + (if in-this-emacs + (dolist (fn cl-run-time-functions) + (unless (and (fboundp fn) + (subrp (symbol-function fn))) + (push fn clfns))) + (setq clfns cl-run-time-functions)) + (set-buffer (setq working + (get-buffer-create + " *Searching for CL run-time functions*"))) + (let (emacs-lisp-mode-hook) + (emacs-lisp-mode)) + (while files + (setq file (pop files) + lines (list nil 1)) + (message "Searching for CL run-time functions in: %s..." + (file-name-nondirectory file)) + (insert-file-contents file nil nil nil t) + ;; Why is the following needed for FSF Emacsen??? + (goto-char (point-min)) + ;; + (while (setq forms (condition-case nil + (list (read working)) + (error))) + (setq fns nil + pt (point) + lines (list (cadr lines) (count-lines (point-min) pt))) + (condition-case nil + (progn + (forward-list -1) + (setcar lines (+ (count-lines (point-min) (point)) + (if (bolp) 1 0)))) + (error)) + (goto-char pt) + (while forms + (setq form (pop forms) + fn (pop form)) + (cond ((eq fn 'define-compiler-macro) + (setq form nil)) + ((memq fn '(let let*)) + (setq form (append + (delq nil + (mapcar + (lambda (element) + (when (and (consp element) + (consp (cadr element))) + (cadr element))) + (car form))) + (cdr form)))) + ((memq fn '(defadvice + defmacro defsubst defun defmacro-maybe + defmacro-maybe-cond defsubst-maybe + defun-maybe defun-maybe-cond)) + (setq form (cddr form))) + ((eq fn 'lambda) + (setq form (cdr form))) + ((memq fn '(\` backquote quote)) + (setq form (when (consp (car form)) + (car form)))) + ((and (memq fn clfns) + (listp form)) + (push fn fns))) + (when (and (consp form) + (condition-case nil + ;; Ignore a case `(a b .c)'. + (length form) + (error nil))) + (setq forms (append (delq nil + (mapcar + (lambda (element) + (when (consp element) + element)) + form)) + forms)))) + (when fns + (if buffer + (set-buffer buffer) + (display-buffer + (setq buffer (get-buffer-create + (concat "*CL run-time functions in: " + file-or-directory "*")))) + (set-buffer buffer) + (erase-buffer)) + (when file + (insert file "\n") + (setq file nil)) + (insert (format "%5d - %5d: %s" + (car lines) (cadr lines) + (mapconcat 'symbol-name + (nreverse fns) " "))) + (while (> (current-column) 78) + (skip-chars-backward "^ ") + (backward-char 1) + (insert "\n ") + (end-of-line)) + (insert "\n") + (sit-for 0) + (set-buffer working)))) + (kill-buffer working) + (if buffer + (message "Done") + (message "No CL run-time functions found in: %s" + file-or-directory))) + (message "No files found")))) + (provide 'gnus-clfns) ;;; gnus-clfns.el ends here diff --git a/lisp/gnus.el b/lisp/gnus.el index 7e2ed03..4995820 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -2123,6 +2123,9 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.") (subrp (symbol-function 'base64-encode-string))) (require 'base64)) +;; A tool for the developers. +(autoload 'find-cl-run-time-functions "gnus-clfns" nil t) + ;;; gnus-sum.el thingies diff --git a/lisp/nnshimbun.el b/lisp/nnshimbun.el index bcd2a78..1102691 100644 --- a/lisp/nnshimbun.el +++ b/lisp/nnshimbun.el @@ -27,14 +27,30 @@ ;;; Commentary: -;; Gnus backend to read newspapers on WEB. +;; Gnus (or gnus) backend to read newspapers on the World Wide Web. +;; This module requires the Emacs-W3M and the external command W3M. +;; Visit the following pages for more information. +;; +;; http://namazu.org/~tsuchiya/emacs-w3m/ +;; http://ei5nazha.yz.yamagata-u.ac.jp/~aito/w3m/ + +;; If you would like to use this module in Gnus (not T-gnus), put this +;; file into the lisp/ directory in the Gnus source tree and run +;; `make install'. And then, copy the function definition of +;; `gnus-group-make-shimbun-group' from the file gnus-group.el of +;; T-gnus to somewhere else, for example .gnus file as follows: +;; +;;(eval-after-load "gnus-group" +;; '(if (not (fboundp 'gnus-group-make-shimbun-group)) +;; (defun gnus-group-make-shimbun-group () +;; "Create a nnshimbun group." +;; [...a function definition...]))) ;;; Definitions: (gnus-declare-backend "nnshimbun" 'address) (eval-when-compile (require 'cl)) -(eval-when-compile (require 'gnus-clfns)) (require 'nnheader) (require 'nnmail) @@ -149,33 +165,37 @@ x)) (eval-and-compile - (if (fboundp 'mime-entity-fetch-field) - ;; For Semi-Gnus. - (defun nnshimbun-make-shimbun-header (header) - (shimbun-make-header - (mail-header-number header) - (mime-entity-fetch-field header 'Subject) - (mime-entity-fetch-field header 'From) - (mail-header-date header) - (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header))) - (mail-header-id header)) - (mail-header-references header) - (mail-header-chars header) - (mail-header-lines header) - (nnshimbun-header-xref header))) - ;; For pure Gnus. - (defun nnshimbun-make-shimbun-header (header) - (shimbun-make-header - (mail-header-number header) - (mail-header-subject header) - (mail-header-from header) - (mail-header-date header) - (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header))) - (mail-header-id header)) - (mail-header-references header) - (mail-header-chars header) - (mail-header-lines header) - (nnshimbun-header-xref header))))) + (let ((Gnus-p + (eval-when-compile + (let ((gnus (locate-library "gnus")) + ;; Gnus has mailcap.el in the same directory of gnus.el. + (mailcap (locate-library "mailcap"))) + (and gnus mailcap + (string-equal (file-name-directory gnus) + (file-name-directory mailcap))))))) + (if Gnus-p + (progn + (defmacro nnshimbun-mail-header-subject (header) + `(mail-header-subject ,header)) + (defmacro nnshimbun-mail-header-from (header) + `(mail-header-from ,header))) + (defmacro nnshimbun-mail-header-subject (header) + `(mime-entity-fetch-field ,header 'Subject)) + (defmacro nnshimbun-mail-header-from (header) + `(mime-entity-fetch-field ,header 'From))))) + +(defun nnshimbun-make-shimbun-header (header) + (shimbun-make-header + (mail-header-number header) + (nnshimbun-mail-header-subject header) + (nnshimbun-mail-header-from header) + (mail-header-date header) + (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header))) + (mail-header-id header)) + (mail-header-references header) + (mail-header-chars header) + (mail-header-lines header) + (nnshimbun-header-xref header))) (defsubst nnshimbun-check-header (group header) (let (flag) @@ -321,7 +341,7 @@ (nnheader-nov-delete-outside-range (if fetch-old (max 1 (- (car articles) fetch-old)) (car articles)) - (car (last articles))) + (and articles (nth (1- (length articles)) articles))) t)))))) -- 1.7.10.4