X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=45b2dd8bb05951b5dba1cf88df218816ee906dcc;hb=c3e1fa9581a5bfd59386b25a438fbb6650441f79;hp=03b017a229132f645941f9c6193f56c02b826d62;hpb=216dd310a007e96604475319ea3087bf9e9970c7;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el
index 03b017a..45b2dd8 100644
--- a/lisp/gnus-util.el
+++ b/lisp/gnus-util.el
@@ -1,5 +1,5 @@
 ;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
@@ -291,7 +291,7 @@
 
 (defun gnus-dd-mmm (messy-date)
   "Return a string like DD-MMM from a big messy string."
-  (format-time-string "%2d-%b" (date-to-time messy-date)))
+  (format-time-string "%d-%b" (safe-date-to-time messy-date)))
 
 (defmacro gnus-date-get-time (date)
   "Convert DATE string to Emacs time.
@@ -302,7 +302,7 @@ Cache the result as a text property stored in DATE."
 	 '(0 0)
        (or (get-text-property 0 'gnus-time d)
 	   ;; or compute the value...
-	   (let ((time (date-to-time d)))
+	   (let ((time (safe-date-to-time d)))
 	     ;; and store it back in the string.
 	     (put-text-property 0 1 'gnus-time time d)
 	     time)))))
@@ -386,7 +386,7 @@ jabbering all the time."
 	    ids))
     (nreverse ids)))
 
-(defun gnus-parent-id (references &optional n)
+(defsubst gnus-parent-id (references &optional n)
   "Return the last Message-ID in REFERENCES.
 If N, return the Nth ancestor instead."
   (when references
@@ -478,21 +478,40 @@ If N, return the Nth ancestor instead."
 (defun gnus-make-sort-function (funs)
   "Return a composite sort condition based on the functions in FUNC."
   (cond
-   ((not (listp funs)) funs)
+   ;; Just a simple function.
+   ((gnus-functionp funs) funs)
+   ;; No functions at all.
    ((null funs) funs)
-   ((cdr funs)
+   ;; A list of functions.
+   ((or (cdr funs)
+	(listp (car funs)))
     `(lambda (t1 t2)
        ,(gnus-make-sort-function-1 (reverse funs))))
+   ;; A list containing just one function.
    (t
     (car funs))))
 
 (defun gnus-make-sort-function-1 (funs)
   "Return a composite sort condition based on the functions in FUNC."
-  (if (cdr funs)
-      `(or (,(car funs) t1 t2)
-	   (and (not (,(car funs) t2 t1))
-		,(gnus-make-sort-function-1 (cdr funs))))
-    `(,(car funs) t1 t2)))
+  (let ((function (car funs))
+	(first 't1)
+	(last 't2))
+    (when (consp function)
+      (cond
+       ;; Reversed spec.
+       ((eq (car function) 'not)
+	(setq function (cadr function)
+	      first 't2
+	      last 't1))
+       ((gnus-functionp function)
+	)
+       (t
+	(error "Invalid sort spec: %s" function))))
+    (if (cdr funs)
+	`(or (,function ,first ,last)
+	     (and (not (,function ,last ,first))
+		  ,(gnus-make-sort-function-1 (cdr funs))))
+      `(,function ,first ,last))))
 
 (defun gnus-turn-off-edit-menu (type)
   "Turn off edit menu in `gnus-TYPE-mode-map'."
@@ -539,7 +558,7 @@ Bind `print-quoted' and `print-readably' to t while printing."
     (setq string (replace-match "" t t string)))
   string)
 
-(defun gnus-put-text-property-excluding-newlines (beg end prop val)
+(defsubst gnus-put-text-property-excluding-newlines (beg end prop val)
   "The same as `put-text-property', but don't put this prop on any newlines in the region."
   (save-match-data
     (save-excursion
@@ -561,7 +580,7 @@ Bind `print-quoted' and `print-readably' to t while printing."
 	(gnus-put-text-property
 	 b (setq b (next-single-property-change b 'gnus-face nil end))
 	 prop val)))))
-  
+
 ;;; Protected and atomic operations.  dmoore@ucsd.edu 21.11.1996
 ;;; The primary idea here is to try to protect internal datastructures
 ;;; from becoming corrupted when the user hits C-g, or if a hook or
@@ -639,11 +658,66 @@ with potentially long computations."
 
 ;;; Functions for saving to babyl/mail files.
 
+(defvar rmail-default-rmail-file)
+(defun gnus-output-to-rmail (filename &optional ask)
+  "Append the current article to an Rmail file named FILENAME."
+  (require 'rmail)
+  ;; Most of these codes are borrowed from rmailout.el.
+  (setq filename (expand-file-name filename))
+  (setq rmail-default-rmail-file filename)
+  (let ((artbuf (current-buffer))
+	(tmpbuf (get-buffer-create " *Gnus-output*")))
+    (save-excursion
+      (or (get-file-buffer filename)
+	  (file-exists-p filename)
+	  (if (or (not ask)
+		  (gnus-yes-or-no-p
+		   (concat "\"" filename "\" does not exist, create it? ")))
+	      (let ((file-buffer (create-file-buffer filename)))
+		(save-excursion
+		  (set-buffer file-buffer)
+		  (rmail-insert-rmail-file-header)
+		  (let ((require-final-newline nil))
+		    (gnus-write-buffer filename)))
+		(kill-buffer file-buffer))
+	    (error "Output file does not exist")))
+      (set-buffer tmpbuf)
+      (erase-buffer)
+      (insert-buffer-substring artbuf)
+      (gnus-convert-article-to-rmail)
+      ;; Decide whether to append to a file or to an Emacs buffer.
+      (let ((outbuf (get-file-buffer filename)))
+	(if (not outbuf)
+	    (append-to-file (point-min) (point-max) filename)
+	  ;; File has been visited, in buffer OUTBUF.
+	  (set-buffer outbuf)
+	  (let ((buffer-read-only nil)
+		(msg (and (boundp 'rmail-current-message)
+			  (symbol-value 'rmail-current-message))))
+	    ;; If MSG is non-nil, buffer is in RMAIL mode.
+	    (when msg
+	      (widen)
+	      (narrow-to-region (point-max) (point-max)))
+	    (insert-buffer-substring tmpbuf)
+	    (when msg
+	      (goto-char (point-min))
+	      (widen)
+ 	      (search-backward "\n\^_")
+ 	      (narrow-to-region (point) (point-max))
+ 	      (rmail-count-new-messages t)
+ 	      (when (rmail-summary-exists)
+		(rmail-select-summary
+		 (rmail-update-summary)))
+	      (rmail-count-new-messages t)
+	      (rmail-show-message msg))
+	    (save-buffer)))))
+    (kill-buffer tmpbuf)))
+
 (defun gnus-output-to-mail (filename &optional ask)
   "Append the current article to a mail file named FILENAME."
   (setq filename (expand-file-name filename))
   (let ((artbuf (current-buffer))
-	(tmpbuf (gnus-get-buffer-create " *Gnus-output*")))
+	(tmpbuf (get-buffer-create " *Gnus-output*")))
     (save-excursion
       ;; Create the file, if it doesn't exist.
       (when (and (not (get-file-buffer filename))
@@ -718,78 +792,60 @@ ARG is passed to the first function."
     (unwind-protect
 	(apply 'run-hooks funcs)
       (set-buffer buf))))
-  
+
 ;;;
 ;;; .netrc and .authinforc parsing
 ;;;
 
-(defvar gnus-netrc-syntax-table
-  (let ((table (copy-syntax-table text-mode-syntax-table)))
-    (modify-syntax-entry ?@ "w" table)
-    (modify-syntax-entry ?- "w" table)
-    (modify-syntax-entry ?_ "w" table)
-    (modify-syntax-entry ?! "w" table)
-    (modify-syntax-entry ?. "w" table)
-    (modify-syntax-entry ?, "w" table)
-    (modify-syntax-entry ?: "w" table)
-    (modify-syntax-entry ?\; "w" table)
-    (modify-syntax-entry ?% "w" table)
-    (modify-syntax-entry ?) "w" table)
-    (modify-syntax-entry ?( "w" table)
-    table)
-  "Syntax table when parsing .netrc files.")
-
 (defun gnus-parse-netrc (file)
   "Parse FILE and return an list of all entries in the file."
-  (if (not (file-exists-p file))
-      ()
-    (save-excursion
+  (when (file-exists-p file)
+    (with-temp-buffer
       (let ((tokens '("machine" "default" "login"
 		      "password" "account" "macdef" "force"))
 	    alist elem result pair)
-	(nnheader-set-temp-buffer " *netrc*")
-	(unwind-protect
-	    (progn
-	      (set-syntax-table gnus-netrc-syntax-table)
-	      (insert-file-contents file)
-	      (goto-char (point-min))
-	      ;; Go through the file, line by line.
-	      (while (not (eobp))
-		(narrow-to-region (point) (gnus-point-at-eol))
-		;; For each line, get the tokens and values.
-		(while (not (eobp))
-		  (skip-chars-forward "\t ")
-		  (unless (eobp)
-		    (setq elem (buffer-substring
-				(point) (progn (forward-sexp 1) (point))))
-		    (cond
-		     ((equal elem "macdef")
-		      ;; We skip past the macro definition.
-		      (widen)
-		      (while (and (zerop (forward-line 1))
-				  (looking-at "$")))
-		      (narrow-to-region (point) (point)))
-		     ((member elem tokens)
-		      ;; Tokens that don't have a following value are ignored,
-		      ;; except "default".
-		      (when (and pair (or (cdr pair)
-					  (equal (car pair) "default")))
-			(push pair alist))
-		      (setq pair (list elem)))
-		     (t
-		      ;; Values that haven't got a preceding token are ignored.
-		      (when pair
-			(setcdr pair elem)
-			(push pair alist)
-			(setq pair nil))))))
-		(if alist
-		    (push (nreverse alist) result))
-		(setq alist nil
-		      pair nil)
-		(widen)
-		(forward-line 1))
-	      (nreverse result))
-	  (kill-buffer " *netrc*"))))))
+	(insert-file-contents file)
+	(goto-char (point-min))
+	;; Go through the file, line by line.
+	(while (not (eobp))
+	  (narrow-to-region (point) (gnus-point-at-eol))
+	  ;; For each line, get the tokens and values.
+	  (while (not (eobp))
+	    (skip-chars-forward "\t ")
+	    ;; Skip lines that begin with a "#".
+	    (if (eq (char-after) ?#)
+		(goto-char (point-max))
+	      (unless (eobp)
+		(setq elem (buffer-substring
+			    (point) (progn (skip-chars-forward "^\t ")
+					   (point))))
+		(cond
+		 ((equal elem "macdef")
+		  ;; We skip past the macro definition.
+		  (widen)
+		  (while (and (zerop (forward-line 1))
+			      (looking-at "$")))
+		  (narrow-to-region (point) (point)))
+		 ((member elem tokens)
+		  ;; Tokens that don't have a following value are ignored,
+		  ;; except "default".
+		  (when (and pair (or (cdr pair)
+				      (equal (car pair) "default")))
+		    (push pair alist))
+		  (setq pair (list elem)))
+		 (t
+		  ;; Values that haven't got a preceding token are ignored.
+		  (when pair
+		    (setcdr pair elem)
+		    (push pair alist)
+		    (setq pair nil)))))))
+	  (when alist
+	    (push (nreverse alist) result))
+	  (setq alist nil
+		pair nil)
+	  (widen)
+	  (forward-line 1))
+	(nreverse result)))))
 
 (defun gnus-netrc-machine (list machine)
   "Return the netrc values from LIST for MACHINE or for the default entry."
@@ -808,7 +864,7 @@ ARG is passed to the first function."
 
 ;;; Various
 
-(defvar gnus-group-buffer) ; Compiler directive
+(defvar gnus-group-buffer)		; Compiler directive
 (defun gnus-alive-p ()
   "Say whether Gnus is running or not."
   (and (boundp 'gnus-group-buffer)
@@ -841,11 +897,12 @@ ARG is passed to the first function."
       (setq alist (delq entry alist)))
     alist))
 
-(defmacro gnus-pull (key alist)
+(defmacro gnus-pull (key alist &optional assoc-p)
   "Modify ALIST to be without KEY."
   (unless (symbolp alist)
     (error "Not a symbol: %s" alist))
-  `(setq ,alist (delq (assq ,key ,alist) ,alist)))
+  (let ((fun (if assoc-p 'assoc 'assq)))
+    `(setq ,alist (delq (,fun ,key ,alist) ,alist))))
 
 (defun gnus-globalify-regexp (re)
   "Returns a regexp that matches a whole line, iff RE matches a part of it."
@@ -853,6 +910,44 @@ ARG is passed to the first function."
 	  re
 	  (unless (string-match "\\$$" re) ".*$")))
 
+(defun gnus-set-window-start (&optional point)
+  "Set the window start to POINT, or (point) if nil."
+  (let ((win (get-buffer-window (current-buffer) t)))
+    (when win
+      (set-window-start win (or point (point))))))
+
+(defun gnus-annotation-in-region-p (b e)
+  (if (= b e)
+      (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
+    (text-property-any b e 'gnus-undeletable t)))
+
+(defun gnus-or (&rest elems)
+  "Return non-nil if any of the elements are non-nil."
+  (catch 'found
+    (while elems
+      (when (pop elems)
+	(throw 'found t)))))
+
+(defun gnus-and (&rest elems)
+  "Return non-nil if all of the elements are non-nil."
+  (catch 'found
+    (while elems
+      (unless (pop elems)
+	(throw 'found nil)))
+    t))
+
+(defun gnus-write-active-file (file hashtb)
+  (with-temp-file file
+    (mapatoms
+     (lambda (sym)
+       (when (and sym
+		  (boundp sym)
+		  (symbol-value sym))
+	 (insert (format "%s %d %d y\n"
+			 (symbol-name sym) (cdr (symbol-value sym))
+			 (car (symbol-value sym))))))
+     hashtb)))
+
 (provide 'gnus-util)
 
 ;;; gnus-util.el ends here