From: yamaoka <yamaoka>
Date: Tue, 29 May 2001 11:31:02 +0000 (+0000)
Subject: * nnshimbun.el (nnshimbun-retrieve-headers-with-nov): Don't use `last'.
X-Git-Tag: t-gnus-6_15_4-02-quimby~45
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=15bca14d69bdc8f35f4ddfc5bd4881872661889c;p=elisp%2Fgnus.git-

* 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.
---

diff --git a/ChangeLog b/ChangeLog
index a34d97e..25534bc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2001-05-29  Katsumi Yamaoka <yamaoka@jpl.org>
+
+	* 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  <tsuchiya@pine.kuee.kyoto-u.ac.jp>
 
 	* 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))))))