X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=0c22d4180b4737db9d515bbe39418b590fb4a8f4;hb=5b8ecce52d86ed7352e6e5b5d768c34321a4c58d;hp=6841dd9788eae1dc5b2ffed242fce98fd9a7cd32;hpb=db39c509e334f98f7d595a5f1f922c88c988af86;p=gnus

diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el
index 6841dd978..0c22d4180 100644
--- a/lisp/gnus-util.el
+++ b/lisp/gnus-util.el
@@ -1,7 +1,7 @@
 ;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
 
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.
@@ -30,26 +30,39 @@
 
 ;;; Code:
 
-(require 'cl)
+(require 'custom)
+(eval-when-compile (require 'cl))
 (require 'nnheader)
-(require 'timezone)
 (require 'message)
+(require 'time-date)
+
+(eval-and-compile
+  (autoload 'rmail-insert-rmail-file-header "rmail")
+  (autoload 'rmail-count-new-messages "rmail")
+  (autoload 'rmail-show-message "rmail"))
+
+(defun gnus-boundp (variable)
+  "Return non-nil if VARIABLE is bound and non-nil."
+  (and (boundp variable)
+       (symbol-value variable)))
 
 (defmacro gnus-eval-in-buffer-window (buffer &rest forms)
   "Pop to BUFFER, evaluate FORMS, and then return to the original window."
   (let ((tempvar (make-symbol "GnusStartBufferWindow"))
-	(w (make-symbol "w"))
-	(buf (make-symbol "buf")))
+        (w (make-symbol "w"))
+        (buf (make-symbol "buf")))
     `(let* ((,tempvar (selected-window))
-	    (,buf ,buffer)
-	    (,w (get-buffer-window ,buf 'visible)))
+            (,buf ,buffer)
+            (,w (get-buffer-window ,buf 'visible)))
        (unwind-protect
-	   (progn
-	     (if ,w
-		 (select-window ,w)
-	       (pop-to-buffer ,buf))
-	     ,@forms)
-	 (select-window ,tempvar)))))
+           (progn
+             (if ,w
+                 (progn
+                   (select-window ,w)
+                   (set-buffer (window-buffer ,w)))
+               (pop-to-buffer ,buf))
+             ,@forms)
+         (select-window ,tempvar)))))
 
 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
@@ -61,12 +74,6 @@
 	 (set symbol nil))
      symbol))
 
-;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;;   function `substring' might cut on a middle of multi-octet
-;;   character.
-(defun gnus-truncate-string (str width)
-  (substring str 0 width))
-
 ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>.  A safe way
 ;; to limit the length of a string.  This function is necessary since
 ;; `(substr "abc" 0 30)' pukes with "Args out of range".
@@ -78,7 +85,8 @@
 (defsubst gnus-functionp (form)
   "Return non-nil if FORM is funcallable."
   (or (and (symbolp form) (fboundp form))
-      (and (listp form) (eq (car form) 'lambda))))
+      (and (listp form) (eq (car form) 'lambda))
+      (byte-code-function-p form)))
 
 (defsubst gnus-goto-char (point)
   (and point (goto-char point)))
@@ -94,21 +102,15 @@
      (when (gnus-buffer-exists-p buf)
        (kill-buffer buf))))
 
-(defsubst gnus-point-at-bol ()
-  "Return point at the beginning of the line."
-  (let ((p (point)))
-    (beginning-of-line)
-    (prog1
-	(point)
-      (goto-char p))))
-
-(defsubst gnus-point-at-eol ()
-  "Return point at the end of the line."
-  (let ((p (point)))
-    (end-of-line)
-    (prog1
-	(point)
-      (goto-char p))))
+(fset 'gnus-point-at-bol
+      (if (fboundp 'point-at-bol)
+	  'point-at-bol
+	'line-beginning-position))
+
+(fset 'gnus-point-at-eol
+      (if (fboundp 'point-at-eol)
+	  'point-at-eol
+	'line-end-position))
 
 (defun gnus-delete-first (elt list)
   "Delete by side effect the first occurrence of ELT as a member of LIST."
@@ -129,7 +131,7 @@
 
 (defun gnus-byte-code (func)
   "Return a form that can be `eval'ed based on FUNC."
-  (let ((fval (symbol-function func)))
+  (let ((fval (indirect-function func)))
     (if (byte-code-function-p fval)
 	(let ((flist (append fval nil)))
 	  (setcar flist 'byte-code)
@@ -145,7 +147,6 @@
       (setq address (substring from (match-beginning 0) (match-end 0))))
     ;; Then we check whether the "name <address>" format is used.
     (and address
-	 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>
 	 ;; Linear white space is not required.
 	 (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
 	 (and (setq name (substring from 0 (match-beginning 0)))
@@ -159,7 +160,6 @@
 				   (1- (match-end 0)))))
 	(and (string-match "()" from)
 	     (setq name address))
-	;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>.
 	;; XOVER might not support folded From headers.
 	(and (string-match "(.*" from)
 	     (setq name (substring from (1+ (match-beginning 0))
@@ -217,42 +217,6 @@
 
 ;;; Time functions.
 
-(defun gnus-days-between (date1 date2)
-  ;; Return the number of days between date1 and date2.
-  (- (gnus-day-number date1) (gnus-day-number date2)))
-
-(defun gnus-day-number (date)
-  (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) )
-		     (timezone-parse-date date))))
-    (timezone-absolute-from-gregorian
-     (nth 1 dat) (nth 2 dat) (car dat))))
-
-(defun gnus-time-to-day (time)
-  "Convert TIME to day number."
-  (let ((tim (decode-time time)))
-    (timezone-absolute-from-gregorian
-     (nth 4 tim) (nth 3 tim) (nth 5 tim))))
-
-(defun gnus-encode-date (date)
-  "Convert DATE to internal time."
-  (let* ((parse (timezone-parse-date date))
-	 (date (mapcar (lambda (d) (and d (string-to-int d))) parse))
-	 (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3)))))
-    (encode-time (caddr time) (cadr time) (car time)
-		 (caddr date) (cadr date) (car date) (nth 4 date))))
-
-(defun gnus-time-minus (t1 t2)
-  "Subtract two internal times."
-  (let ((borrow (< (cadr t1) (cadr t2))))
-    (list (- (car t1) (car t2) (if borrow 1 0))
-	  (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
-
-(defun gnus-time-less (t1 t2)
-  "Say whether time T1 is less than time T2."
-  (or (< (car t1) (car t2))
-      (and (= (car t1) (car t2))
-	   (< (nth 1 t1) (nth 1 t2)))))
-
 (defun gnus-file-newer-than (file date)
   (let ((fdate (nth 5 (file-attributes file))))
     (or (> (car fdate) (car date))
@@ -305,7 +269,7 @@
 
 (defun gnus-completing-read (default prompt &rest args)
   ;; Like `completing-read', except that DEFAULT is the default argument.
-  (let* ((prompt (if default 
+  (let* ((prompt (if default
 		     (concat prompt " (default " default ") ")
 		   (concat prompt " ")))
 	 (answer (apply 'completing-read prompt args)))
@@ -325,23 +289,9 @@
       (yes-or-no-p prompt)
     (message "")))
 
-;; I suspect there's a better way, but I haven't taken the time to do
-;; it yet.  -erik selberg@cs.washington.edu
 (defun gnus-dd-mmm (messy-date)
-  "Return a string like DD-MMM from a big messy string"
-  (let ((datevec (ignore-errors (timezone-parse-date messy-date))))
-    (if (not datevec)
-	"??-???"
-      (format "%2s-%s"
-	      (condition-case ()
-		  ;; Make sure leading zeroes are stripped.
-		  (number-to-string (string-to-number (aref datevec 2)))
-		(error "??"))
-	      (capitalize
-	       (or (car
-		    (nth (1- (string-to-number (aref datevec 1)))
-			 timezone-months-assoc))
-		   "???"))))))
+  "Return a string like DD-MMM from a big messy string."
+  (format-time-string "%d-%b" (safe-date-to-time messy-date)))
 
 (defmacro gnus-date-get-time (date)
   "Convert DATE string to Emacs time.
@@ -352,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 (nnmail-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)))))
@@ -360,11 +310,11 @@ Cache the result as a text property stored in DATE."
 (defsubst gnus-time-iso8601 (time)
   "Return a string of TIME in YYMMDDTHHMMSS format."
   (format-time-string "%Y%m%dT%H%M%S" time))
-  
-(defun gnus-date-iso8601 (header)
-  "Convert the date field in HEADER to YYMMDDTHHMMSS"
+
+(defun gnus-date-iso8601 (date)
+  "Convert the DATE to YYMMDDTHHMMSS."
   (condition-case ()
-      (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header)))
+      (gnus-time-iso8601 (gnus-date-get-time date))
     (error "")))
 
 (defun gnus-mode-string-quote (string)
@@ -377,25 +327,31 @@ Cache the result as a text property stored in DATE."
       (insert "%"))
     (buffer-string)))
 
-;; Make a hash table (default and minimum size is 255).
+;; Make a hash table (default and minimum size is 256).
 ;; Optional argument HASHSIZE specifies the table size.
 (defun gnus-make-hashtable (&optional hashsize)
-  (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 255) 255) 0))
-
-;; Make a number that is suitable for hashing; bigger than MIN and one
-;; less than 2^x.
+  (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0))
+
+;; Make a number that is suitable for hashing; bigger than MIN and
+;; equal to some 2^x.  Many machines (such as sparcs) do not have a
+;; hardware modulo operation, so they implement it in software.  On
+;; many sparcs over 50% of the time to intern is spent in the modulo.
+;; Yes, it's slower than actually computing the hash from the string!
+;; So we use powers of 2 so people can optimize the modulo to a mask.
 (defun gnus-create-hash-size (min)
   (let ((i 1))
     (while (< i min)
       (setq i (* 2 i)))
-    (1- i)))
+    i))
 
-(defvar gnus-verbose 7
+(defcustom gnus-verbose 7
   "*Integer that says how verbose Gnus should be.
 The higher the number, the more messages Gnus will flash to say what
 it's doing.  At zero, Gnus will be totally mute; at five, Gnus will
 display most important messages; and at ten, Gnus will keep on
-jabbering all the time.")
+jabbering all the time."
+  :group 'gnus-start
+  :type 'integer)
 
 ;; Show message if message has a lower level than `gnus-verbose'.
 ;; Guideline for numbers:
@@ -421,13 +377,6 @@ jabbering all the time.")
 	(sit-for duration))))
   nil)
 
-(defun gnus-parent-id (references &optional n)
-  "Return the last Message-ID in REFERENCES.
-If N, return the Nth ancestor instead."
-  (when references
-    (let ((ids (gnus-split-references references)))
-      (car (last ids (or n 1))))))
-
 (defun gnus-split-references (references)
   "Return a list of Message-IDs in REFERENCES."
   (let ((beg 0)
@@ -437,7 +386,16 @@ If N, return the Nth ancestor instead."
 	    ids))
     (nreverse ids)))
 
-(defun gnus-buffer-live-p (buffer)
+(defsubst gnus-parent-id (references &optional n)
+  "Return the last Message-ID in REFERENCES.
+If N, return the Nth ancestor instead."
+  (when references
+    (let ((ids (inline (gnus-split-references references))))
+      (while (nthcdr (or n 1) ids)
+	(setq ids (cdr ids)))
+      (car ids))))
+
+(defsubst gnus-buffer-live-p (buffer)
   "Say whether BUFFER is alive or not."
   (and buffer
        (get-buffer buffer)
@@ -450,44 +408,34 @@ If N, return the Nth ancestor instead."
     (let* ((orig (point))
 	   (end (window-end (get-buffer-window (current-buffer) t)))
 	   (max 0))
-      ;; Find the longest line currently displayed in the window.
-      (goto-char (window-start))
-      (while (and (not (eobp))
-		  (< (point) end))
-	(end-of-line)
-	(setq max (max max (current-column)))
-	(forward-line 1))
-      (goto-char orig)
-      ;; Scroll horizontally to center (sort of) the point.
-      (if (> max (window-width))
-	  (set-window-hscroll 
-	   (get-buffer-window (current-buffer) t)
-	   (min (- (current-column) (/ (window-width) 3))
-		(+ 2 (- max (window-width)))))
-	(set-window-hscroll (get-buffer-window (current-buffer) t) 0))
-      max)))
+      (when end
+	;; Find the longest line currently displayed in the window.
+	(goto-char (window-start))
+	(while (and (not (eobp))
+		    (< (point) end))
+	  (end-of-line)
+	  (setq max (max max (current-column)))
+	  (forward-line 1))
+	(goto-char orig)
+	;; Scroll horizontally to center (sort of) the point.
+	(if (> max (window-width))
+	    (set-window-hscroll
+	     (get-buffer-window (current-buffer) t)
+	     (min (- (current-column) (/ (window-width) 3))
+		  (+ 2 (- max (window-width)))))
+	  (set-window-hscroll (get-buffer-window (current-buffer) t) 0))
+	max))))
 
 (defun gnus-read-event-char ()
   "Get the next event."
   (let ((event (read-event)))
+    ;; should be gnus-characterp, but this can't be called in XEmacs anyway
     (cons (and (numberp event) event) event)))
 
 (defun gnus-sortable-date (date)
-  "Make sortable string by string-lessp from DATE.
-Timezone package is used."
-  (condition-case ()
-      (progn
-	(setq date (inline (timezone-fix-time 
-			    date nil 
-			    (aref (inline (timezone-parse-date date)) 4))))
-	(inline
-	  (timezone-make-sortable-date
-	   (aref date 0) (aref date 1) (aref date 2)
-	   (inline
-	     (timezone-make-time-string
-	      (aref date 3) (aref date 4) (aref date 5))))))
-    (error "")))
-  
+  "Make string suitable for sorting from DATE."
+  (gnus-time-iso8601 (date-to-time date)))
+
 (defun gnus-copy-file (file &optional to)
   "Copy FILE to TO."
   (interactive
@@ -502,12 +450,11 @@ Timezone package is used."
 
 (defun gnus-kill-all-overlays ()
   "Delete all overlays in the current buffer."
-  (when (fboundp 'overlay-lists)
-    (let* ((overlayss (overlay-lists))
-	   (buffer-read-only nil)
-	   (overlays (nconc (car overlayss) (cdr overlayss))))
-      (while overlays
-	(delete-overlay (pop overlays))))))
+  (let* ((overlayss (overlay-lists))
+	 (buffer-read-only nil)
+	 (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
+    (while overlays
+      (delete-overlay (pop overlays)))))
 
 (defvar gnus-work-buffer " *gnus work*")
 
@@ -517,9 +464,9 @@ Timezone package is used."
       (progn
 	(set-buffer gnus-work-buffer)
 	(erase-buffer))
-    (set-buffer (get-buffer-create gnus-work-buffer))
+    (set-buffer (gnus-get-buffer-create gnus-work-buffer))
     (kill-all-local-variables)
-    (buffer-disable-undo (current-buffer))))
+    (mm-enable-multibyte)))
 
 (defmacro gnus-group-real-name (group)
   "Find the real name of a foreign newsgroup."
@@ -530,41 +477,66 @@ Timezone package is used."
 
 (defun gnus-make-sort-function (funs)
   "Return a composite sort condition based on the functions in FUNC."
-  (cond 
-   ((not (listp funs)) funs)
+  (cond
+   ;; 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 meny in `gnus-TYPE-mode-map'."
+  "Turn off edit menu in `gnus-TYPE-mode-map'."
   (define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
     [menu-bar edit] 'undefined))
 
 (defun gnus-prin1 (form)
   "Use `prin1' on FORM in the current buffer.
-Bind `print-quoted' to t while printing."
-  (let ((print-quoted t))
+Bind `print-quoted' and `print-readably' to t while printing."
+  (let ((print-quoted t)
+	(print-readably t)
+	(print-escape-multibyte nil)
+	print-level print-length)
     (prin1 form (current-buffer))))
 
 (defun gnus-prin1-to-string (form)
-  "The same as `prin1', but but `print-quoted' to t."
-  (prin1-to-string form))
+  "The same as `prin1', but bind `print-quoted' and `print-readably' to t."
+  (let ((print-quoted t)
+	(print-readably t))
+    (prin1-to-string form)))
 
 (defun gnus-make-directory (directory)
   "Make DIRECTORY (and all its parents) if it doesn't exist."
-  (when (not (file-exists-p directory))
+  (when (and directory
+	     (not (file-exists-p directory)))
     (make-directory directory t))
   t)
 
@@ -575,19 +547,395 @@ Bind `print-quoted' to t while printing."
   ;; Write the buffer.
   (write-region (point-min) (point-max) file nil 'quietly))
 
-(defmacro gnus-delete-assq (key list)
-  `(let ((listval (eval ,list)))
-     (setq ,list (delq (assq ,key listval) listval))))
-
-(defmacro gnus-delete-assoc (key list)
-  `(let ((listval ,list))
-     (setq ,list (delq (assoc ,key listval) listval))))
-
 (defun gnus-delete-file (file)
   "Delete FILE if it exists."
   (when (file-exists-p file)
     (delete-file file)))
 
+(defun gnus-strip-whitespace (string)
+  "Return STRING stripped of all whitespace."
+  (while (string-match "[\r\n\t ]+" string)
+    (setq string (replace-match "" t t string)))
+  string)
+
+(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
+      (save-restriction
+	(goto-char beg)
+	(while (re-search-forward "[ \t]*\n" end 'move)
+	  (gnus-put-text-property beg (match-beginning 0) prop val)
+	  (setq beg (point)))
+	(gnus-put-text-property beg (point) prop val)))))
+
+(defun gnus-put-text-property-excluding-characters-with-faces (beg end
+								   prop val)
+  "The same as `put-text-property', but don't put props on characters with the `gnus-face' property."
+  (let ((b beg))
+    (while (/= b end)
+      (when (get-text-property b 'gnus-face)
+	(setq b (next-single-property-change b 'gnus-face nil end)))
+      (when (/= b end)
+	(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
+;;; similar blows up.  Often in Gnus multiple tables/lists need to be
+;;; updated at the same time, or information can be lost.
+
+(defvar gnus-atomic-be-safe t
+  "If t, certain operations will be protected from interruption by C-g.")
+
+(defmacro gnus-atomic-progn (&rest forms)
+  "Evaluate FORMS atomically, which means to protect the evaluation
+from being interrupted by the user.  An error from the forms themselves
+will return without finishing the operation.  Since interrupts from
+the user are disabled, it is recommended that only the most minimal
+operations are performed by FORMS.  If you wish to assign many
+complicated values atomically, compute the results into temporary
+variables and then do only the assignment atomically."
+  `(let ((inhibit-quit gnus-atomic-be-safe))
+     ,@forms))
+
+(put 'gnus-atomic-progn 'lisp-indent-function 0)
+
+(defmacro gnus-atomic-progn-assign (protect &rest forms)
+  "Evaluate FORMS, but insure that the variables listed in PROTECT
+are not changed if anything in FORMS signals an error or otherwise
+non-locally exits.  The variables listed in PROTECT are updated atomically.
+It is safe to use gnus-atomic-progn-assign with long computations.
+
+Note that if any of the symbols in PROTECT were unbound, they will be
+set to nil on a sucessful assignment.  In case of an error or other
+non-local exit, it will still be unbound."
+  (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol
+						  (concat (symbol-name x)
+							  "-tmp"))
+						 x))
+			       protect))
+	 (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x)))
+			       temp-sym-map))
+	 (temp-sym-let (mapcar (lambda (x) (list (car x)
+						 `(and (boundp ',(cadr x))
+						       ,(cadr x))))
+			       temp-sym-map))
+	 (sym-temp-let sym-temp-map)
+	 (temp-sym-assign (apply 'append temp-sym-map))
+	 (sym-temp-assign (apply 'append sym-temp-map))
+	 (result (make-symbol "result-tmp")))
+    `(let (,@temp-sym-let
+	   ,result)
+       (let ,sym-temp-let
+	 (setq ,result (progn ,@forms))
+	 (setq ,@temp-sym-assign))
+       (let ((inhibit-quit gnus-atomic-be-safe))
+	 (setq ,@sym-temp-assign))
+       ,result)))
+
+(put 'gnus-atomic-progn-assign 'lisp-indent-function 1)
+;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body))
+
+(defmacro gnus-atomic-setq (&rest pairs)
+  "Similar to setq, except that the real symbols are only assigned when
+there are no errors.  And when the real symbols are assigned, they are
+done so atomically.  If other variables might be changed via side-effect,
+see gnus-atomic-progn-assign.  It is safe to use gnus-atomic-setq
+with potentially long computations."
+  (let ((tpairs pairs)
+	syms)
+    (while tpairs
+      (push (car tpairs) syms)
+      (setq tpairs (cddr tpairs)))
+    `(gnus-atomic-progn-assign ,syms
+       (setq ,@pairs))))
+
+;(put 'gnus-atomic-setq 'edebug-form-spec '(body))
+
+
+;;; 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 (get-buffer-create " *Gnus-output*")))
+    (save-excursion
+      ;; Create the file, if it doesn't exist.
+      (when (and (not (get-file-buffer filename))
+		 (not (file-exists-p filename)))
+	(if (or (not ask)
+		(gnus-y-or-n-p
+		 (concat "\"" filename "\" does not exist, create it? ")))
+	    (let ((file-buffer (create-file-buffer filename)))
+	      (save-excursion
+		(set-buffer file-buffer)
+		(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)
+      (goto-char (point-min))
+      (if (looking-at "From ")
+	  (forward-line 1)
+	(insert "From nobody " (current-time-string) "\n"))
+      (let (case-fold-search)
+	(while (re-search-forward "^From " nil t)
+	  (beginning-of-line)
+	  (insert ">")))
+      ;; Decide whether to append to a file or to an Emacs buffer.
+      (let ((outbuf (get-file-buffer filename)))
+	(if (not outbuf)
+	    (let ((buffer-read-only nil))
+	      (save-excursion
+		(goto-char (point-max))
+		(forward-char -2)
+		(unless (looking-at "\n\n")
+		  (goto-char (point-max))
+		  (unless (bolp)
+		    (insert "\n"))
+		  (insert "\n"))
+		(goto-char (point-max))
+		(append-to-file (point-min) (point-max) filename)))
+	  ;; File has been visited, in buffer OUTBUF.
+	  (set-buffer outbuf)
+	  (let ((buffer-read-only nil))
+	    (goto-char (point-max))
+	    (unless (eobp)
+	      (insert "\n"))
+	    (insert "\n")
+	    (insert-buffer-substring tmpbuf)))))
+    (kill-buffer tmpbuf)))
+
+(defun gnus-convert-article-to-rmail ()
+  "Convert article in current buffer to Rmail message format."
+  (let ((buffer-read-only nil))
+    ;; Convert article directly into Babyl format.
+    (goto-char (point-min))
+    (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+    (while (search-forward "\n\^_" nil t) ;single char
+      (replace-match "\n^_" t t))	;2 chars: "^" and "_"
+    (goto-char (point-max))
+    (insert "\^_")))
+
+(defun gnus-map-function (funs arg)
+  "Applies the result of the first function in FUNS to the second, and so on.
+ARG is passed to the first function."
+  (let ((myfuns funs))
+    (while myfuns
+      (setq arg (funcall (pop myfuns) arg)))
+    arg))
+
+(defun gnus-run-hooks (&rest funcs)
+  "Does the same as `run-hooks', but saves excursion."
+  (let ((buf (current-buffer)))
+    (unwind-protect
+	(apply 'run-hooks funcs)
+      (set-buffer buf))))
+
+;;;
+;;; .netrc and .authinforc parsing
+;;;
+
+(defun gnus-parse-netrc (file)
+  "Parse FILE and return an list of all entries in the file."
+  (when (file-exists-p file)
+    (with-temp-buffer
+      (let ((tokens '("machine" "default" "login"
+		      "password" "account" "macdef" "force"))
+	    alist elem result pair)
+	(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."
+  (let ((rest list))
+    (while (and list
+		(not (equal (cdr (assoc "machine" (car list))) machine)))
+      (pop list))
+    (car (or list
+	     (progn (while (and rest (not (assoc "default" (car rest))))
+		      (pop rest))
+		    rest)))))
+
+(defun gnus-netrc-get (alist type)
+  "Return the value of token TYPE from ALIST."
+  (cdr (assoc type alist)))
+
+;;; Various
+
+(defvar gnus-group-buffer)		; Compiler directive
+(defun gnus-alive-p ()
+  "Say whether Gnus is running or not."
+  (and (boundp 'gnus-group-buffer)
+       (get-buffer gnus-group-buffer)
+       (save-excursion
+	 (set-buffer gnus-group-buffer)
+	 (eq major-mode 'gnus-group-mode))))
+
+(defun gnus-remove-duplicates (list)
+  (let (new (tail list))
+    (while tail
+      (or (member (car tail) new)
+	  (setq new (cons (car tail) new)))
+      (setq tail (cdr tail)))
+    (nreverse new)))
+
+(defun gnus-delete-if (predicate list)
+  "Delete elements from LIST that satisfy PREDICATE."
+  (let (out)
+    (while list
+      (unless (funcall predicate (car list))
+	(push (car list) out))
+      (pop list))
+    (nreverse out)))
+
+(defun gnus-delete-alist (key alist)
+  "Delete all entries in ALIST that have a key eq to KEY."
+  (let (entry)
+    (while (setq entry (assq key alist))
+      (setq alist (delq entry alist)))
+    alist))
+
+(defmacro gnus-pull (key alist &optional assoc-p)
+  "Modify ALIST to be without KEY."
+  (unless (symbolp alist)
+    (error "Not a symbol: %s" 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."
+  (concat (unless (string-match "^\\^" re) "^.*")
+	  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))
+
 (provide 'gnus-util)
 
 ;;; gnus-util.el ends here