(article-transform-date): Fix infinite recursion.

[gnus] / lisp / gnus-util.el

diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el
index 417cf6c..d298c71 100644 (file)
--- a/lisp/gnus-util.el
+++ b/lisp/gnus-util.el
@@ -1,7 +1,6 @@
 ;;; gnus-util.el --- utility functions for Gnus
 
 ;;; gnus-util.el --- utility functions for Gnus
 

-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news


@@ -33,16 +32,43 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.

 (eval-and-compile
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 (eval-when-compile
   (require 'cl))
 
 (eval-and-compile
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 (eval-when-compile
   (require 'cl))
 

-(eval-when-compile
-  (unless (fboundp 'with-no-warnings)
-    (defmacro with-no-warnings (&rest body)
-      `(progn ,@body))))
+(require 'time-date)
+
+(defcustom gnus-completing-read-function 'gnus-emacs-completing-read
+  "Function use to do completing read."
+  :version "24.1"
+  :group 'gnus-meta
+  :type `(radio (function-item
+                 :doc "Use Emacs standard `completing-read' function."
+                 gnus-emacs-completing-read)
+               ;; iswitchb.el is very old and ido.el is unavailable
+               ;; in XEmacs, so we exclude those function items.
+               ,@(unless (featurep 'xemacs)
+                   '((function-item
+                      :doc "Use `ido-completing-read' function."
+                      gnus-ido-completing-read)
+                     (function-item
+                      :doc "Use iswitchb based completing-read function."
+                      gnus-iswitchb-completing-read)))))
+
+(defcustom gnus-completion-styles
+  (if (and (boundp 'completion-styles-alist)
+           (boundp 'completion-styles))
+      (append (when (and (assq 'substring completion-styles-alist)
+                         (not (memq 'substring completion-styles)))
+                (list 'substring))
+              completion-styles)
+    nil)
+  "Value of `completion-styles' to use when completing."
+  :version "24.1"
+  :group 'gnus-meta
+  :type 'list)

 
 ;; Fixme: this should be a gnus variable, not nnmail-.
 (defvar nnmail-pathname-coding-system)
 
 ;; Fixme: this should be a gnus variable, not nnmail-.
 (defvar nnmail-pathname-coding-system)


@@ -122,11 +148,9 @@ This is a compatibility function for different Emacsen."
 ;; XEmacs.  In Emacs we don't need to call `make-local-hook' first.
 ;; It's harmless, though, so the main purpose of this alias is to shut
 ;; up the byte compiler.
 ;; XEmacs.  In Emacs we don't need to call `make-local-hook' first.
 ;; It's harmless, though, so the main purpose of this alias is to shut
 ;; up the byte compiler.

-(defalias 'gnus-make-local-hook
-  (if (eq (get 'make-local-hook 'byte-compile)
-         'byte-compile-obsolete)
-      'ignore                          ; Emacs
-    'make-local-hook))                 ; XEmacs
+(defalias 'gnus-make-local-hook (if (featurep 'xemacs)
+                                    'make-local-hook
+                                  'ignore))

 
 (defun gnus-delete-first (elt list)
   "Delete by side effect the first occurrence of ELT as a member of LIST."
 
 (defun gnus-delete-first (elt list)
   "Delete by side effect the first occurrence of ELT as a member of LIST."


@@ -254,6 +278,24 @@ Uses `gnus-extract-address-components'."
       (setq start (when end
                    (next-single-property-change start prop))))))
 
       (setq start (when end
                    (next-single-property-change start prop))))))
 

+(defun gnus-find-text-property-region (start end prop)
+  "Return a list of text property regions that has property PROP."
+  (let (regions value)
+    (unless (get-text-property start prop)
+      (setq start (next-single-property-change start prop)))
+    (while start
+      (setq value (get-text-property start prop)
+           end (text-property-not-all start (point-max) prop value))
+      (if (not end)
+         (setq start nil)
+       (when value
+         (push (list (set-marker (make-marker) start)
+                     (set-marker (make-marker) end)
+                     value)
+               regions))
+       (setq start (next-single-property-change start prop))))
+    (nreverse regions)))
+

 (defun gnus-newsgroup-directory-form (newsgroup)
   "Make hierarchical directory name from NEWSGROUP name."
   (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
 (defun gnus-newsgroup-directory-form (newsgroup)
   "Make hierarchical directory name from NEWSGROUP name."
   (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))


@@ -291,14 +333,16 @@ Symbols are also allowed; their print names are used instead."
        (and (= (car fdate) (car date))
             (> (nth 1 fdate) (nth 1 date))))))
 
        (and (= (car fdate) (car date))
             (> (nth 1 fdate) (nth 1 date))))))
 

+;; Every version of Emacs Gnus supports has built-in float-time.
+;; The featurep test silences an irritating compiler warning.

 (eval-and-compile
 (eval-and-compile

-  (if (and (fboundp 'float-time)
-          (subrp (symbol-function 'float-time)))
+  (if (or (featurep 'emacs)
+         (fboundp 'float-time))

       (defalias 'gnus-float-time 'float-time)
     (defun gnus-float-time (&optional time)
       "Convert time value TIME to a floating point number.
 TIME defaults to the current time."
       (defalias 'gnus-float-time 'float-time)
     (defun gnus-float-time (&optional time)
       "Convert time value TIME to a floating point number.
 TIME defaults to the current time."

-      (with-no-warnings (time-to-seconds (or time (current-time)))))))
+      (time-to-seconds (or time (current-time))))))

 
 ;;; Keymap macros.
 
 
 ;;; Keymap macros.
 


@@ -344,16 +388,6 @@ TIME defaults to the current time."
          (define-key keymap key (pop plist))
        (pop plist)))))
 
          (define-key keymap key (pop plist))
        (pop plist)))))
 

-(defun gnus-completing-read-with-default (default prompt &rest args)
-  ;; Like `completing-read', except that DEFAULT is the default argument.
-  (let* ((prompt (if default
-                    (concat prompt " (default " default "): ")
-                  (concat prompt ": ")))
-        (answer (apply 'completing-read prompt args)))
-    (if (or (null answer) (zerop (length answer)))
-       default
-      answer)))
-

 ;; Two silly functions to ensure that all `y-or-n-p' questions clear
 ;; the echo area.
 ;;
 ;; Two silly functions to ensure that all `y-or-n-p' questions clear
 ;; the echo area.
 ;;


@@ -601,6 +635,8 @@ but also to the ones displayed in the echo area."
                 (t
                  (apply 'message ,format-string ,args))))))))
 
                 (t
                  (apply 'message ,format-string ,args))))))))
 

+(defvar gnus-action-message-log nil)
+

 (defun gnus-message-with-timestamp (format-string &rest args)
   "Display message with timestamp.  Arguments are the same as `message'.
 The `gnus-add-timestamp-to-message' variable controls how to add
 (defun gnus-message-with-timestamp (format-string &rest args)
   "Display message with timestamp.  Arguments are the same as `message'.
 The `gnus-add-timestamp-to-message' variable controls how to add


@@ -615,14 +651,26 @@ Guideline for numbers:
 that take a long time, 7 - not very important messages on stuff, 9 - messages
 inside loops."
   (if (<= level gnus-verbose)
 that take a long time, 7 - not very important messages on stuff, 9 - messages
 inside loops."
   (if (<= level gnus-verbose)

-      (if gnus-add-timestamp-to-message
-         (apply 'gnus-message-with-timestamp args)
-       (apply 'message args))
+      (let ((message
+            (if gnus-add-timestamp-to-message
+                (apply 'gnus-message-with-timestamp args)
+              (apply 'message args))))
+       (when (and (consp gnus-action-message-log)
+                  (<= level 3))
+         (push message gnus-action-message-log))
+       message)

     ;; We have to do this format thingy here even if the result isn't
     ;; shown - the return value has to be the same as the return value
     ;; from `message'.
     (apply 'format args)))
 
     ;; We have to do this format thingy here even if the result isn't
     ;; shown - the return value has to be the same as the return value
     ;; from `message'.
     (apply 'format args)))
 

+(defun gnus-final-warning ()
+  (when (and (consp gnus-action-message-log)
+            (setq gnus-action-message-log
+                  (delete nil gnus-action-message-log)))
+    (message "Warning: %s"
+            (mapconcat #'identity gnus-action-message-log "; "))))
+

 (defun gnus-error (level &rest args)
   "Beep an error if LEVEL is equal to or less than `gnus-verbose'.
 ARGS are passed to `message'."
 (defun gnus-error (level &rest args)
   "Beep an error if LEVEL is equal to or less than `gnus-verbose'.
 ARGS are passed to `message'."


@@ -856,6 +904,7 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and
 
 (defun gnus-write-buffer (file)
   "Write the current buffer's contents to FILE."
 
 (defun gnus-write-buffer (file)
   "Write the current buffer's contents to FILE."

+  (require 'nnmail)

   (let ((file-name-coding-system nnmail-pathname-coding-system))
     ;; Make sure the directory exists.
     (gnus-make-directory (file-name-directory file))
   (let ((file-name-coding-system nnmail-pathname-coding-system))
     ;; Make sure the directory exists.
     (gnus-make-directory (file-name-directory file))


@@ -1091,6 +1140,7 @@ In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
 FILENAME exists and is Babyl format."
   (require 'rmail)
   (require 'mm-util)
 FILENAME exists and is Babyl format."
   (require 'rmail)
   (require 'mm-util)

+  (require 'nnmail)

   ;; Some of this codes is borrowed from rmailout.el.
   (setq filename (expand-file-name filename))
   ;; FIXME should we really be messing with this defcustom?
   ;; Some of this codes is borrowed from rmailout.el.
   (setq filename (expand-file-name filename))
   ;; FIXME should we really be messing with this defcustom?


@@ -1115,8 +1165,7 @@ FILENAME exists and is Babyl format."
                  (gnus-yes-or-no-p
                   (concat "\"" filename "\" does not exist, create it? ")))
              (let ((file-buffer (create-file-buffer filename)))
                  (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)
+               (with-current-buffer file-buffer

                   (if (fboundp 'rmail-insert-rmail-file-header)
                       (rmail-insert-rmail-file-header))
                  (let ((require-final-newline nil)
                   (if (fboundp 'rmail-insert-rmail-file-header)
                       (rmail-insert-rmail-file-header))
                  (let ((require-final-newline nil)


@@ -1183,6 +1232,7 @@ FILENAME exists and is Babyl format."
 
 (defun gnus-output-to-mail (filename &optional ask)
   "Append the current article to a mail file named FILENAME."
 
 (defun gnus-output-to-mail (filename &optional ask)
   "Append the current article to a mail file named FILENAME."

+  (require 'nnmail)

   (setq filename (expand-file-name filename))
   (let ((artbuf (current-buffer))
        (tmpbuf (get-buffer-create " *Gnus-output*")))
   (setq filename (expand-file-name filename))
   (let ((artbuf (current-buffer))
        (tmpbuf (get-buffer-create " *Gnus-output*")))


@@ -1194,8 +1244,7 @@ FILENAME exists and is Babyl format."
                (gnus-y-or-n-p
                 (concat "\"" filename "\" does not exist, create it? ")))
            (let ((file-buffer (create-file-buffer filename)))
                (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)
+             (with-current-buffer file-buffer

                (let ((require-final-newline nil)
                      (coding-system-for-write mm-text-coding-system))
                  (gnus-write-buffer filename)))
                (let ((require-final-newline nil)
                      (coding-system-for-write mm-text-coding-system))
                  (gnus-write-buffer filename)))


@@ -1260,6 +1309,11 @@ ARG is passed to the first function."
   (save-current-buffer
     (apply 'run-hooks funcs)))
 
   (save-current-buffer
     (apply 'run-hooks funcs)))
 

+(defun gnus-run-hook-with-args (hook &rest args)
+  "Does the same as `run-hook-with-args', but saves the current buffer."
+  (save-current-buffer
+    (apply 'run-hook-with-args hook args)))
+

 (defun gnus-run-mode-hooks (&rest funcs)
   "Run `run-mode-hooks' if it is available, otherwise `run-hooks'.
 This function saves the current buffer."
 (defun gnus-run-mode-hooks (&rest funcs)
   "Run `run-mode-hooks' if it is available, otherwise `run-hooks'.
 This function saves the current buffer."


@@ -1274,17 +1328,43 @@ This function saves the current buffer."
   "Say whether Gnus is running or not."
   (and (boundp 'gnus-group-buffer)
        (get-buffer gnus-group-buffer)
   "Say whether Gnus is running or not."
   (and (boundp 'gnus-group-buffer)
        (get-buffer gnus-group-buffer)

-       (save-excursion
-        (set-buffer gnus-group-buffer)
+       (with-current-buffer gnus-group-buffer

         (eq major-mode 'gnus-group-mode))))
 
         (eq major-mode 'gnus-group-mode))))
 

-(defun gnus-remove-if (predicate list)
-  "Return a copy of LIST with all items satisfying PREDICATE removed."
+(defun gnus-remove-if (predicate sequence &optional hash-table-p)
+  "Return a copy of SEQUENCE with all items satisfying PREDICATE removed.
+SEQUENCE should be a list, a vector, or a string.  Returns always a list.
+If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
+  (let (out)
+    (if hash-table-p
+       (mapatoms (lambda (symbol)
+                   (unless (funcall predicate symbol)
+                     (push symbol out)))
+                 sequence)
+      (unless (listp sequence)
+       (setq sequence (append sequence nil)))
+      (while sequence
+       (unless (funcall predicate (car sequence))
+         (push (car sequence) out))
+       (setq sequence (cdr sequence))))
+    (nreverse out)))
+
+(defun gnus-remove-if-not (predicate sequence &optional hash-table-p)
+  "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed.
+SEQUENCE should be a list, a vector, or a string.  Returns always a list.
+If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."

   (let (out)
   (let (out)

-    (while list
-      (unless (funcall predicate (car list))
-       (push (car list) out))
-      (setq list (cdr list)))
+    (if hash-table-p
+ &