nntp.el (nntp-record-command):
[gnus] / lisp / gnus-util.el
index 129e1e6..7155c7f 100644 (file)
@@ -1,7 +1,6 @@
 ;;; gnus-util.el --- utility functions for Gnus
 
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
 
 ;;; 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))
+
+(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)
 (defvar nnmail-active-file-coding-system)
 (defvar gnus-original-article-buffer)
 (defvar gnus-user-agent)
 
-(require 'time-date)
-(require 'netrc)
-
-(autoload 'message-fetch-field "message")
 (autoload 'gnus-get-buffer-window "gnus-win")
-(autoload 'rmail-insert-rmail-file-header "rmail")
-(autoload 'rmail-count-new-messages "rmail")
-(autoload 'rmail-show-message "rmail")
 (autoload 'nnheader-narrow-to-headers "nnheader")
 (autoload 'nnheader-replace-chars-in-string "nnheader")
+(autoload 'mail-header-remove-comments "mail-parse")
 
 (eval-and-compile
   (cond
@@ -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.
-(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."
@@ -202,8 +226,11 @@ Uses `gnus-extract-address-components'."
 Uses `gnus-extract-address-components'."
   (nth 1 (gnus-extract-address-components from)))
 
+(declare-function message-fetch-field "message" (header &optional not-all))
+
 (defun gnus-fetch-field (field)
   "Return the value of the header FIELD of current article."
+  (require 'message)
   (save-excursion
     (save-restriction
       (let ((inhibit-point-motion-hooks t))
@@ -224,13 +251,14 @@ Uses `gnus-extract-address-components'."
                   (point)))))
 
 (declare-function gnus-find-method-for-group "gnus" (group &optional info))
-(autoload 'gnus-group-name-decode "gnus-group")
+(declare-function gnus-group-name-decode "gnus-group" (string charset))
 (declare-function gnus-group-name-charset "gnus-group" (method group))
 ;; gnus-group requires gnus-int which requires message.
 (declare-function message-tokenize-header "message"
                   (header &optional separator))
 
 (defun gnus-decode-newsgroups (newsgroups group &optional method)
+  (require 'gnus-group)
   (let ((method (or method (gnus-find-method-for-group group))))
     (mapconcat (lambda (group)
                 (gnus-group-name-decode group (gnus-group-name-charset
@@ -250,6 +278,24 @@ Uses `gnus-extract-address-components'."
       (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))
@@ -287,6 +333,17 @@ Symbols are also allowed; their print names are used instead."
        (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
+  (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."
+      (time-to-seconds (or time (current-time))))))
+
 ;;; Keymap macros.
 
 (defmacro gnus-local-set-keys (&rest plist)
@@ -331,16 +388,6 @@ Symbols are also allowed; their print names are used instead."
          (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.
 ;;
@@ -416,57 +463,6 @@ Symbols are also allowed; their print names are used instead."
     (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
        (* (- (string-to-number days) 1) 3600 24))))
 
-(defvar gnus-user-date-format-alist
-  '(((gnus-seconds-today) . "%k:%M")
-    (604800 . "%a %k:%M")                   ;;that's one week
-    ((gnus-seconds-month) . "%a %d")
-    ((gnus-seconds-year) . "%b %d")
-    (t . "%b %d '%y"))                      ;;this one is used when no
-                                           ;;other does match
-  "Specifies date format depending on age of article.
-This is an alist of items (AGE . FORMAT).  AGE can be a number (of
-seconds) or a Lisp expression evaluating to a number.  When the age of
-the article is less than this number, then use `format-time-string'
-with the corresponding FORMAT for displaying the date of the article.
-If AGE is not a number or a Lisp expression evaluating to a
-non-number, then the corresponding FORMAT is used as a default value.
-
-Note that the list is processed from the beginning, so it should be
-sorted by ascending AGE.  Also note that items following the first
-non-number AGE will be ignored.
-
-You can use the functions `gnus-seconds-today', `gnus-seconds-month'
-and `gnus-seconds-year' in the AGE spec.  They return the number of
-seconds passed since the start of today, of this month, of this year,
-respectively.")
-
-(defun gnus-user-date (messy-date)
-  "Format the messy-date according to gnus-user-date-format-alist.
-Returns \"  ?  \" if there's bad input or if an other error occurs.
-Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
-  (condition-case ()
-      (let* ((messy-date (time-to-seconds (safe-date-to-time messy-date)))
-            (now (time-to-seconds (current-time)))
-            ;;If we don't find something suitable we'll use this one
-            (my-format "%b %d '%y"))
-       (let* ((difference (- now messy-date))
-              (templist gnus-user-date-format-alist)
-              (top (eval (caar templist))))
-         (while (if (numberp top) (< top difference) (not top))
-           (progn
-             (setq templist (cdr templist))
-             (setq top (eval (caar templist)))))
-         (if (stringp (cdr (car templist)))
-             (setq my-format (cdr (car templist)))))
-       (format-time-string (eval my-format) (seconds-to-time messy-date)))
-    (error "  ?   ")))
-
-(defun gnus-dd-mmm (messy-date)
-  "Return a string like DD-MMM from a big messy string."
-  (condition-case ()
-      (format-time-string "%d-%b" (safe-date-to-time messy-date))
-    (error "  -   ")))
-
 (defmacro gnus-date-get-time (date)
   "Convert DATE string to Emacs time.
 Cache the result as a text property stored in DATE."
@@ -481,6 +477,12 @@ Cache the result as a text property stored in DATE."
             (put-text-property 0 1 'gnus-time time d)
             time)))))
 
+(defun gnus-dd-mmm (messy-date)
+  "Return a string like DD-MMM from a big messy string."
+  (condition-case ()
+      (format-time-string "%d-%b" (gnus-date-get-time messy-date))
+    (error "  -   ")))
+
 (defsubst gnus-time-iso8601 (time)
   "Return a string of TIME in YYYYMMDDTHHMMSS format."
   (format-time-string "%Y%m%dT%H%M%S" time))
@@ -538,8 +540,7 @@ but also to the ones displayed in the echo area."
 
 (eval-when-compile
   (defmacro gnus-message-with-timestamp-1 (format-string args)
-    (let ((timestamp '((format-time-string "%Y%m%dT%H%M%S" time)
-                      "." (format "%03d" (/ (nth 2 time) 1000)) "> ")))
+    (let ((timestamp '(format-time-string "%Y%m%dT%H%M%S.%3N> " time)))
       (if (featurep 'xemacs)
          `(let (str time)
             (if (or (and (null ,format-string) (null ,args))
@@ -552,10 +553,10 @@ but also to the ones displayed in the echo area."
               (cond ((eq gnus-add-timestamp-to-message 'log)
                      (setq time (current-time))
                      (display-message 'no-log str)
-                     (log-message 'message (concat ,@timestamp str)))
+                     (log-message 'message (concat ,timestamp str)))
                     (gnus-add-timestamp-to-message
                      (setq time (current-time))
-                     (display-message 'message (concat ,@timestamp str)))
+                     (display-message 'message (concat ,timestamp str)))
                     (t
                      (display-message 'message str))))
             str)
@@ -569,7 +570,7 @@ but also to the ones displayed in the echo area."
                    (setq time (current-time))
                    (with-current-buffer (get-buffer-create "*Messages*")
                      (goto-char (point-max))
-                     (insert ,@timestamp str "\n")
+                     (insert ,timestamp str "\n")
                      (forward-line (- message-log-max))
                      (delete-region (point-min) (point))
                      (goto-char (point-max))))
@@ -583,11 +584,13 @@ but also to the ones displayed in the echo area."
                          (and ,format-string str)
                        (message nil))
                    (setq time (current-time))
-                   (message "%s" (concat ,@timestamp str))
+                   (message "%s" (concat ,timestamp str))
                    str))
                 (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
@@ -602,14 +605,26 @@ Guideline for numbers:
 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)))
 
+(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'."
@@ -625,7 +640,7 @@ ARGS are passed to `message'."
 (defun gnus-split-references (references)
   "Return a list of Message-IDs in REFERENCES."
   (let ((beg 0)
-       (references (or references ""))
+       (references (mail-header-remove-comments (or references "")))
        ids)
     (while (string-match "<[^<]+[^< \t]" references beg)
       (push (substring references (match-beginning 0) (setq beg (match-end 0)))
@@ -652,14 +667,13 @@ If N, return the Nth ancestor instead."
          (while (nthcdr n ids)
            (setq ids (cdr ids)))
          (car ids))
-      (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
-       (match-string 1 references)))))
+      (let ((references (mail-header-remove-comments references)))
+       (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
+         (match-string 1 references))))))
 
-(defun gnus-buffer-live-p (buffer)
+(defsubst gnus-buffer-live-p (buffer)
   "Say whether BUFFER is alive or not."
-  (and buffer
-       (get-buffer buffer)
-       (buffer-name (get-buffer buffer))))
+  (and buffer (buffer-live-p (get-buffer buffer))))
 
 (defun gnus-horizontal-recenter ()
   "Recenter the current buffer horizontally."
@@ -842,6 +856,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."
+  (require 'nnmail)
   (let ((file-name-coding-system nnmail-pathname-coding-system))
     ;; Make sure the directory exists.
     (gnus-make-directory (file-name-directory file))
@@ -853,6 +868,15 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and
   (when (file-exists-p file)
     (delete-file file)))
 
+(defun gnus-delete-duplicates (list)
+  "Remove duplicate entries from LIST."
+  (let ((result nil))
+    (while list
+      (unless (member (car list) result)
+       (push (car list) result))
+      (pop list))
+    (nreverse result)))
+
 (defun gnus-delete-directory (directory)
   "Delete files in DIRECTORY.  Subdirectories remain.
 If there's no subdirectory, delete DIRECTORY as well."
@@ -955,6 +979,29 @@ If there's no subdirectory, delete DIRECTORY as well."
                          (overlay-get overlay 'face))
                        (overlays-at pos)))))))
 
+(if (fboundp 'invisible-p)
+    (defalias 'gnus-invisible-p 'invisible-p)
+  ;; for Emacs < 22.2, and XEmacs.
+  (defun gnus-invisible-p (pos)
+    "Return non-nil if the character after POS is currently invisible."
+    (let ((prop (get-char-property pos 'invisible)))
+      (if (eq buffer-invisibility-spec t)
+         prop
+       (or (memq prop buffer-invisibility-spec)
+           (assq prop buffer-invisibility-spec))))))
+
+;; Note: the optional 2nd argument has a different meaning between
+;; Emacs and XEmacs.
+;; (next-char-property-change POSITION &optional LIMIT)
+;; (next-extent-change        POS      &optional OBJECT)
+(defalias 'gnus-next-char-property-change
+  (if (fboundp 'next-extent-change)
+      'next-extent-change 'next-char-property-change))
+
+(defalias 'gnus-previous-char-property-change
+  (if (fboundp 'previous-extent-change)
+      'previous-extent-change 'previous-char-property-change))
+
 ;;; 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
@@ -1033,49 +1080,55 @@ with potentially long computations."
 ;;; Functions for saving to babyl/mail files.
 
 (eval-when-compile
-  (condition-case nil
-      (progn
-       (require 'rmail)
-       (autoload 'rmail-update-summary "rmailsum"))
-    (error
-     (define-compiler-macro rmail-select-summary (&rest body)
-       ;; Rmail of the XEmacs version is supplied by the package, and
-       ;; requires tm and apel packages.  However, there may be those
-       ;; who haven't installed those packages.  This macro helps such
-       ;; people even if they install those packages later.
-       `(eval '(rmail-select-summary ,@body)))
-     ;; If there's rmail but there's no tm (or there's apel of the
-     ;; mainstream, not the XEmacs version), loading rmail of the XEmacs
-     ;; version fails halfway, however it provides the rmail-select-summary
-     ;; macro which uses the following functions:
-     (autoload 'rmail-summary-displayed "rmail")
-     (autoload 'rmail-maybe-display-summary "rmail"))))
-
-(defvar rmail-default-rmail-file)
+  (if (featurep 'xemacs)
+      ;; Don't load tm and apel XEmacs packages that provide some
+      ;; Emacs emulating functions and variables.
+      (let ((features features))
+       (provide 'tm-view)
+       (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore))
+       (require 'rmail)) ;; It requires tm-view that loads apel.
+    (require 'rmail))
+  (autoload 'rmail-update-summary "rmailsum"))
+
 (defvar mm-text-coding-system)
 
 (declare-function mm-append-to-file "mm-util"
                   (start end filename &optional codesys inhibit))
 
 (defun gnus-output-to-rmail (filename &optional ask)
-  "Append the current article to an Rmail file named FILENAME."
+  "Append the current article to an Rmail file named FILENAME.
+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)
-  ;; Most of these codes are borrowed from rmailout.el.
+  (require 'nnmail)
+  ;; Some of this codes is borrowed from rmailout.el.
   (setq filename (expand-file-name filename))
-  (setq rmail-default-rmail-file filename)
+  ;; FIXME should we really be messing with this defcustom?
+  ;; It is not needed for the operation of this function.
+  (if (boundp 'rmail-default-rmail-file)
+      (setq rmail-default-rmail-file filename) ; 22
+    (setq rmail-default-file filename))        ; 23
   (let ((artbuf (current-buffer))
-       (tmpbuf (get-buffer-create " *Gnus-output*")))
+       (tmpbuf (get-buffer-create " *Gnus-output*"))
+        ;; Babyl rmail.el defines this, mbox does not.
+        (babyl (fboundp 'rmail-insert-rmail-file-header)))
     (save-excursion
-      (or (get-file-buffer filename)
-         (file-exists-p filename)
+      ;; Note that we ignore the possibility of visiting a Babyl
+      ;; format buffer in Emacs 23, since Rmail no longer supports that.
+     (or (get-file-buffer filename)
+         (progn
+           ;; In case someone wants to write to a Babyl file from Emacs 23.
+           (when (file-exists-p filename)
+             (setq babyl (mail-file-babyl-p filename))
+             t))
          (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)
+               (with-current-buffer file-buffer
+                  (if (fboundp 'rmail-insert-rmail-file-header)
+                      (rmail-insert-rmail-file-header))
                  (let ((require-final-newline nil)
                        (coding-system-for-write mm-text-coding-system))
                    (gnus-write-buffer filename)))
@@ -1084,38 +1137,63 @@ with potentially long computations."
       (set-buffer tmpbuf)
       (erase-buffer)
       (insert-buffer-substring artbuf)
-      (gnus-convert-article-to-rmail)
+      (if babyl
+          (gnus-convert-article-to-rmail)
+        ;; Non-Babyl case copied from gnus-output-to-mail.
+        (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 ((file-name-coding-system nnmail-pathname-coding-system))
-             (mm-append-to-file (point-min) (point-max) filename))
+            (progn
+              (unless babyl             ; from gnus-output-to-mail
+                (let ((buffer-read-only nil))
+                  (goto-char (point-max))
+                  (forward-char -2)
+                  (unless (looking-at "\n\n")
+                    (goto-char (point-max))
+                    (unless (bolp)
+                      (insert "\n"))
+                    (insert "\n"))))
+              (let ((file-name-coding-system nnmail-pathname-coding-system))
+                (mm-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.
+            ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23.
            (when msg
-             (widen)
-             (narrow-to-region (point-max) (point-max)))
+              (unless babyl
+                (rmail-swap-buffers-maybe)
+                (rmail-maybe-set-message-counters))
+              (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))
+              (when babyl
+                (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."
+  (require 'nnmail)
   (setq filename (expand-file-name filename))
   (let ((artbuf (current-buffer))
        (tmpbuf (get-buffer-create " *Gnus-output*")))
@@ -1127,8 +1205,7 @@ with potentially long computations."
                (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)))
@@ -1193,6 +1270,11 @@ ARG is passed to the first function."
   (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."
@@ -1207,17 +1289,43 @@ This function saves the current 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))))
 
-(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)
-    (while list
-      (unless (funcall predicate (car list))
-       (push (car list) out))
-      (setq list (cdr list)))
+    (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)
+    (if hash-table-p
+       (mapatoms (lambda (symbol)
+                   (when (funcall predicate symbol)
+                     (push symbol out)))
+                 sequence)
+      (unless (listp sequence)
+       (setq sequence (append sequence nil)))
+      (while sequence
+       (when (funcall predicate (car sequence))
+         (push (car sequence) out))
+       (setq sequence (cdr sequence))))
     (nreverse out)))
 
 (if (fboundp 'assq-delete-all)
@@ -1230,7 +1338,15 @@ Return the modified alist."
        (setq alist (delq entry alist)))
       alist)))
 
-(defmacro gnus-pull (key alist &optional assoc-p)
+(defun gnus-grep-in-list (word list)
+  "Find if a WORD matches any regular expression in the given LIST."
+  (when (and word list)
+    (catch 'found
+      (dolist (r list)
+       (when (string-match r word)
+         (throw 'found r))))))
+
+(defmacro gnus-alist-pull (key alist &optional assoc-p)
   "Modify ALIST to be without KEY."
   (unless (symbolp alist)
     (error "Not a symbol: %s" alist))
@@ -1488,28 +1604,65 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
        `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec)))
       (error "Invalid predicate specifier: %s" spec)))))
 
-(defun gnus-completing-read (prompt table &optional predicate require-match
-                                   history)
-  (when (and history
-            (not (boundp history)))
-    (set history nil))
-  (completing-read
-   (if (symbol-value history)
-       (concat prompt " (" (car (symbol-value history)) "): ")
-     (concat prompt ": "))
-   table
-   predicate
-   require-match
-   nil
-   history
-   (car (symbol-value history))))
+(defun gnus-completing-read (prompt collection &optional require-match
+                                    initial-input history def)
+  "Call `gnus-completing-read-function'."
+  (funcall gnus-completing-read-function
+           (concat prompt (when def
+                            (concat " (default " def ")"))
+                   ": ")
+           collection require-match initial-input history def))
+
+(defun gnus-emacs-completing-read (prompt collection &optional require-match
+                                          initial-input history def)
+  "Call standard `completing-read-function'."
+  (let ((completion-styles gnus-completion-styles))
+    (completing-read prompt
+                     ;; Old XEmacs (at least 21.4) expect an alist for
+                     ;; collection.
+                     (mapcar 'list collection)
+                     nil require-match initial-input history def)))
+
+(autoload 'ido-completing-read "ido")
+(defun gnus-ido-completing-read (prompt collection &optional require-match
+                                        initial-input history def)
+  "Call `ido-completing-read-function'."
+  (ido-completing-read prompt collection nil require-match
+                      initial-input history def))
+
+
+(declare-function iswitchb-read-buffer "iswitchb"
+                 (prompt &optional default require-match start matches-set))
+(defvar iswitchb-temp-buflist)
+
+(defun gnus-iswitchb-completing-read (prompt collection &optional require-match
+                                            initial-input history def)
+  "`iswitchb' based completing-read function."
+  ;; Make sure iswitchb is loaded before we let-bind its variables.
+  ;; If it is loaded inside the let, variables can become unbound afterwards.
+  (require 'iswitchb)
+  (let ((iswitchb-make-buflist-hook
+         (lambda ()
+           (setq iswitchb-temp-buflist
+                 (let ((choices (append
+                                 (when initial-input (list initial-input))
+                                 (symbol-value history) collection))
+                       filtered-choices)
+                   (dolist (x choices)
+                     (setq filtered-choices (adjoin x filtered-choices)))
+                   (nreverse filtered-choices))))))
+    (unwind-protect
+        (progn
+          (or iswitchb-mode
+             (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
+          (iswitchb-read-buffer prompt def require-match))
+      (or iswitchb-mode
+         (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)))))
 
 (defun gnus-graphic-display-p ()
-  (or (and (fboundp 'display-graphic-p)
-          (display-graphic-p))
-      ;;;!!!This is bogus.  Fixme!
-      (and (featurep 'xemacs)
-          t)))
+  (if (featurep 'xemacs)
+      (device-on-window-system-p)
+    (display-graphic-p)))
 
 (put 'gnus-parse-without-error 'lisp-indent-function 0)
 (put 'gnus-parse-without-error 'edebug-form-spec '(body))
@@ -1591,30 +1744,16 @@ CHOICE is a list of the choice char and help message at IDX."
        (kill-buffer buf))
     tchar))
 
-(declare-function x-focus-frame "xfns.c" (frame))
-(declare-function w32-focus-frame "../term/w32-win" (frame))
-
-(defun gnus-select-frame-set-input-focus (frame)
-  "Select FRAME, raise it, and set input focus, if possible."
-  (cond ((featurep 'xemacs)
-        (if (fboundp 'select-frame-set-input-focus)
-            (select-frame-set-input-focus frame)
-          (raise-frame frame)
-          (select-frame frame)
-          (focus-frame frame)))
-       ;; `select-frame-set-input-focus' defined in Emacs 21 will not
-       ;; set the input focus.
-       ((>= emacs-major-version 22)
-        (select-frame-set-input-focus frame))
-       (t
-        (raise-frame frame)
-        (select-frame frame)
-        (cond ((memq window-system '(x ns mac))
-               (x-focus-frame frame))
-              ((eq window-system 'w32)
-               (w32-focus-frame frame)))
-        (when focus-follows-mouse
-          (set-mouse-position frame (1- (frame-width frame)) 0)))))
+(if (featurep 'emacs)
+    (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus)
+  (if (fboundp 'select-frame-set-input-focus)
+      (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus)
+    ;; XEmacs 21.4, SXEmacs
+    (defun gnus-select-frame-set-input-focus (frame)
+      "Select FRAME, raise it, and set input focus, if possible."
+      (raise-frame frame)
+      (select-frame frame)
+      (focus-frame frame))))
 
 (defun gnus-frame-or-window-display-name (object)
   "Given a frame or window, return the associated display name.
@@ -1779,25 +1918,6 @@ empty directories from OLD-PATH."
   (defalias 'gnus-set-process-query-on-exit-flag
     'process-kill-without-query))
 
-(if (fboundp 'with-local-quit)
-    (defalias 'gnus-with-local-quit 'with-local-quit)
-  (defmacro gnus-with-local-quit (&rest body)
-    "Execute BODY, allowing quits to terminate BODY but not escape further.
-When a quit terminates BODY, `gnus-with-local-quit' returns nil but
-requests another quit.  That quit will be processed as soon as quitting
-is allowed once again.  (Immediately, if `inhibit-quit' is nil.)"
-    ;;(declare (debug t) (indent 0))
-    `(condition-case nil
-        (let ((inhibit-quit nil))
-          ,@body)
-       (quit (setq quit-flag t)
-            ;; This call is to give a chance to handle quit-flag
-            ;; in case inhibit-quit is nil.
-            ;; Without this, it will not be handled until the next function
-            ;; call, and that might allow it to exit thru a condition-case
-            ;; that intends to handle the quit signal next time.
-            (eval '(ignore nil))))))
-
 (defalias 'gnus-read-shell-command
   (if (fboundp 'read-shell-command) 'read-shell-command 'read-string))
 
@@ -1822,7 +1942,85 @@ is allowed once again.  (Immediately, if `inhibit-quit' is nil.)"
             (get-char-table ,character ,display-table)))
     `(aref ,display-table ,character)))
 
+(defun gnus-rescale-image (image size)
+  "Rescale IMAGE to SIZE if possible.
+SIZE is in format (WIDTH . HEIGHT). Return a new image.
+Sizes are in pixels."
+  (if (or (not (fboundp 'imagemagick-types))
+         (not (get-buffer-window (current-buffer))))
+      image
+    (let ((new-width (car size))
+          (new-height (cdr size)))
+      (when (> (cdr (image-size image t)) new-height)
+        (setq image (or (create-image (plist-get (cdr image) :data) 'imagemagick t
+                                      :height new-height)
+                        image)))
+      (when (> (car (image-size image t)) new-width)
+        (setq image (or
+                   (create-image (plist-get (cdr image) :data) 'imagemagick t
+                                 :width new-width)
+                   image)))
+      image)))
+
+(defun gnus-list-memq-of-list (elements list)
+  "Return non-nil if any of the members of ELEMENTS are in LIST."
+  (let ((found nil))
+    (dolist (elem elements)
+      (setq found (or found
+                     (memq elem list))))
+    found))
+
+(eval-and-compile
+  (cond
+   ((fboundp 'match-substitute-replacement)
+    (defalias 'gnus-match-substitute-replacement 'match-substitute-replacement))
+   (t
+    (defun gnus-match-substitute-replacement (replacement &optional fixedcase literal string subexp)
+      "Return REPLACEMENT as it will be inserted by `replace-match'.
+In other words, all back-references in the form `\\&' and `\\N'
+are substituted with actual strings matched by the last search.
+Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same
+meaning as for `replace-match'.
+
+This is the definition of match-substitute-replacement in subr.el from GNU Emacs."
+      (let ((match (match-string 0 string)))
+       (save-match-data
+         (set-match-data (mapcar (lambda (x)
+                                   (if (numberp x)
+                                       (- x (match-beginning 0))
+                                     x))
+                                 (match-data t)))
+         (replace-match replacement fixedcase literal match subexp)))))))
+
+(if (fboundp 'string-match-p)
+    (defalias 'gnus-string-match-p 'string-match-p)
+  (defsubst gnus-string-match-p (regexp string &optional start)
+    "\
+Same as `string-match' except this function does not change the match data."
+    (save-match-data
+      (string-match regexp string start))))
+
+(eval-and-compile
+  (if (fboundp 'macroexpand-all)
+      (defalias 'gnus-macroexpand-all 'macroexpand-all)
+    (defun gnus-macroexpand-all (form &optional environment)
+      "Return result of expanding macros at all levels in FORM.
+If no macros are expanded, FORM is returned unchanged.
+The second optional arg ENVIRONMENT specifies an environment of macro
+definitions to shadow the loaded ones for use in file byte-compilation."
+      (if (consp form)
+         (let ((idx 1)
+               (len (length (setq form (copy-sequence form))))
+               expanded)
+           (while (< idx len)
+             (setcar (nthcdr idx form) (gnus-macroexpand-all (nth idx form)
+                                                             environment))
+             (setq idx (1+ idx)))
+           (if (eq (setq expanded (macroexpand form environment)) form)
+               form
+             (gnus-macroexpand-all expanded environment)))
+       form))))
+
 (provide 'gnus-util)
 
-;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
 ;;; gnus-util.el ends here