cgit.sxemacs.org Git - gnus/blob - lisp/gnus-util.el

   1 ;;; gnus-util.el --- utility functions for Gnus
   2
   3 ;; Copyright (C) 1996-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Nothing in this file depends on any other parts of Gnus -- all
  26 ;; functions and macros in this file are utility functions that are
  27 ;; used by Gnus and may be used by any other package without loading
  28 ;; Gnus first.
  29
  30 ;; [Unfortunately, it does depend on other parts of Gnus, e.g. the
  31 ;; autoloads and defvars below...]
  32
  33 ;;; Code:
  34
  35 (eval-when-compile
  36   (require 'cl))
  37
  38 (require 'time-date)
  39
  40 (defcustom gnus-completing-read-function 'gnus-emacs-completing-read
  41   "Function use to do completing read."
  42   :version "24.1"
  43   :group 'gnus-meta
  44   :type `(radio (function-item
  45                  :doc "Use Emacs standard `completing-read' function."
  46                  gnus-emacs-completing-read)
  47                 ;; iswitchb.el is very old and ido.el is unavailable
  48                 ;; in XEmacs, so we exclude those function items.
  49                 ,@(unless (featurep 'xemacs)
  50                     '((function-item
  51                        :doc "Use `ido-completing-read' function."
  52                        gnus-ido-completing-read)
  53                       (function-item
  54                        :doc "Use iswitchb based completing-read function."
  55                        gnus-iswitchb-completing-read)))))
  56
  57 (defcustom gnus-completion-styles
  58   (if (and (boundp 'completion-styles-alist)
  59            (boundp 'completion-styles))
  60       (append (when (and (assq 'substring completion-styles-alist)
  61                          (not (memq 'substring completion-styles)))
  62                 (list 'substring))
  63               completion-styles)
  64     nil)
  65   "Value of `completion-styles' to use when completing."
  66   :version "24.1"
  67   :group 'gnus-meta
  68   :type '(repeat symbol))
  69
  70 ;; Fixme: this should be a gnus variable, not nnmail-.
  71 (defvar nnmail-pathname-coding-system)
  72 (defvar nnmail-active-file-coding-system)
  73
  74 ;; Inappropriate references to other parts of Gnus.
  75 (defvar gnus-emphasize-whitespace-regexp)
  76 (defvar gnus-original-article-buffer)
  77 (defvar gnus-user-agent)
  78
  79 (autoload 'gnus-get-buffer-window "gnus-win")
  80 (autoload 'nnheader-narrow-to-headers "nnheader")
  81 (autoload 'nnheader-replace-chars-in-string "nnheader")
  82 (autoload 'mail-header-remove-comments "mail-parse")
  83
  84 (eval-and-compile
  85   (cond
  86    ;; Prefer `replace-regexp-in-string' (present in Emacs, XEmacs 21.5,
  87    ;; SXEmacs 22.1.4) over `replace-in-string'.  The latter leads to inf-loops
  88    ;; on empty matches:
  89    ;;   (replace-in-string "foo" "/*$" "/")
  90    ;;   (replace-in-string "xe" "\\(x\\)?" "")
  91    ((fboundp 'replace-regexp-in-string)
  92     (defun gnus-replace-in-string  (string regexp newtext &optional literal)
  93       "Replace all matches for REGEXP with NEWTEXT in STRING.
  94 If LITERAL is non-nil, insert NEWTEXT literally.  Return a new
  95 string containing the replacements.
  96
  97 This is a compatibility function for different Emacsen."
  98       (replace-regexp-in-string regexp newtext string nil literal)))
  99    ((fboundp 'replace-in-string)
 100     (defalias 'gnus-replace-in-string 'replace-in-string))))
 101
 102 (defun gnus-boundp (variable)
 103   "Return non-nil if VARIABLE is bound and non-nil."
 104   (and (boundp variable)
 105        (symbol-value variable)))
 106
 107 (defmacro gnus-eval-in-buffer-window (buffer &rest forms)
 108   "Pop to BUFFER, evaluate FORMS, and then return to the original window."
 109   (let ((tempvar (make-symbol "GnusStartBufferWindow"))
 110         (w (make-symbol "w"))
 111         (buf (make-symbol "buf")))
 112     `(let* ((,tempvar (selected-window))
 113             (,buf ,buffer)
 114             (,w (gnus-get-buffer-window ,buf 'visible)))
 115        (unwind-protect
 116            (progn
 117              (if ,w
 118                  (progn
 119                    (select-window ,w)
 120                    (set-buffer (window-buffer ,w)))
 121                (pop-to-buffer ,buf))
 122              ,@forms)
 123          (select-window ,tempvar)))))
 124
 125 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
 126 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
 127
 128 (defmacro gnus-intern-safe (string hashtable)
 129   "Get hash value.  Arguments are STRING and HASHTABLE."
 130   `(let ((symbol (intern ,string ,hashtable)))
 131      (or (boundp symbol)
 132          (set symbol nil))
 133      symbol))
 134
 135 (defsubst gnus-goto-char (point)
 136   (and point (goto-char point)))
 137
 138 (defmacro gnus-buffer-exists-p (buffer)
 139   `(let ((buffer ,buffer))
 140      (when buffer
 141        (funcall (if (stringp buffer) 'get-buffer 'buffer-name)
 142                 buffer))))
 143
 144 ;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and
 145 ;; XEmacs.  In Emacs we don't need to call `make-local-hook' first.
 146 ;; It's harmless, though, so the main purpose of this alias is to shut
 147 ;; up the byte compiler.
 148 (defalias 'gnus-make-local-hook (if (featurep 'xemacs)
 149                                     'make-local-hook
 150                                   'ignore))
 151
 152 (defun gnus-delete-first (elt list)
 153   "Delete by side effect the first occurrence of ELT as a member of LIST."
 154   (if (equal (car list) elt)
 155       (cdr list)
 156     (let ((total list))
 157       (while (and (cdr list)
 158                   (not (equal (cadr list) elt)))
 159         (setq list (cdr list)))
 160       (when (cdr list)
 161         (setcdr list (cddr list)))
 162       total)))
 163
 164 ;; Delete the current line (and the next N lines).
 165 (defmacro gnus-delete-line (&optional n)
 166   `(delete-region (point-at-bol)
 167                   (progn (forward-line ,(or n 1)) (point))))
 168
 169 (defun gnus-extract-address-components (from)
 170   "Extract address components from a From header.
 171 Given an RFC-822 address FROM, extract full name and canonical address.
 172 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).  Much more simple
 173 solution than `mail-extract-address-components', which works much better, but
 174 is slower."
 175   (let (name address)
 176     ;; First find the address - the thing with the @ in it.  This may
 177     ;; not be accurate in mail addresses, but does the trick most of
 178     ;; the time in news messages.
 179     (cond (;; Check ``<foo@bar>'' first in order to handle the quite common
 180            ;; form ``"abc@xyz" <foo@bar>'' (i.e. ``@'' as part of a comment)
 181            ;; correctly.
 182            (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" from)
 183            (setq address (substring from (match-beginning 1) (match-end 1))))
 184           ((string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
 185            (setq address (substring from (match-beginning 0) (match-end 0)))))
 186     ;; Then we check whether the "name <address>" format is used.
 187     (and address
 188          ;; Linear white space is not required.
 189          (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
 190          (and (setq name (substring from 0 (match-beginning 0)))
 191               ;; Strip any quotes from the name.
 192               (string-match "^\".*\"$" name)
 193               (setq name (substring name 1 (1- (match-end 0))))))
 194     ;; If not, then "address (name)" is used.
 195     (or name
 196         (and (string-match "(.+)" from)
 197              (setq name (substring from (1+ (match-beginning 0))
 198                                    (1- (match-end 0)))))
 199         (and (string-match "()" from)
 200              (setq name address))
 201         ;; XOVER might not support folded From headers.
 202         (and (string-match "(.*" from)
 203              (setq name (substring from (1+ (match-beginning 0))
 204                                    (match-end 0)))))
 205     (list (if (string= name "") nil name) (or address from))))
 206
 207 (declare-function message-fetch-field "message" (header &optional not-all))
 208
 209 (defun gnus-fetch-field (field)
 210   "Return the value of the header FIELD of current article."
 211   (require 'message)
 212   (save-excursion
 213     (save-restriction
 214       (let ((inhibit-point-motion-hooks t))
 215         (nnheader-narrow-to-headers)
 216         (message-fetch-field field)))))
 217
 218 (defun gnus-fetch-original-field (field)
 219   "Fetch FIELD from the original version of the current article."
 220   (with-current-buffer gnus-original-article-buffer
 221     (gnus-fetch-field field)))
 222
 223
 224 (defun gnus-goto-colon ()
 225   (move-beginning-of-line 1)
 226   (let ((eol (point-at-eol)))
 227     (goto-char (or (text-property-any (point) eol 'gnus-position t)
 228                    (search-forward ":" eol t)
 229                    (point)))))
 230
 231 (declare-function gnus-find-method-for-group "gnus" (group &optional info))
 232 (declare-function gnus-group-name-decode "gnus-group" (string charset))
 233 (declare-function gnus-group-name-charset "gnus-group" (method group))
 234 ;; gnus-group requires gnus-int which requires message.
 235 (declare-function message-tokenize-header "message"
 236                   (header &optional separator))
 237
 238 (defun gnus-decode-newsgroups (newsgroups group &optional method)
 239   (require 'gnus-group)
 240   (let ((method (or method (gnus-find-method-for-group group))))
 241     (mapconcat (lambda (group)
 242                  (gnus-group-name-decode group (gnus-group-name-charset
 243                                                 method group)))
 244                (message-tokenize-header newsgroups)
 245                ",")))
 246
 247 (defun gnus-remove-text-with-property (prop)
 248   "Delete all text in the current buffer with text property PROP."
 249   (let ((start (point-min))
 250         end)
 251     (unless (get-text-property start prop)
 252       (setq start (next-single-property-change start prop)))
 253     (while start
 254       (setq end (text-property-any start (point-max) prop nil))
 255       (delete-region start (or end (point-max)))
 256       (setq start (when end
 257                     (next-single-property-change start prop))))))
 258
 259 (defun gnus-find-text-property-region (start end prop)
 260   "Return a list of text property regions that has property PROP."
 261   (let (regions value)
 262     (unless (get-text-property start prop)
 263       (setq start (next-single-property-change start prop)))
 264     (while start
 265       (setq value (get-text-property start prop)
 266             end (text-property-not-all start (point-max) prop value))
 267       (if (not end)
 268           (setq start nil)
 269         (when value
 270           (push (list (set-marker (make-marker) start)
 271                       (set-marker (make-marker) end)
 272                       value)
 273                 regions))
 274         (setq start (next-single-property-change start prop))))
 275     (nreverse regions)))
 276
 277 (defun gnus-newsgroup-directory-form (newsgroup)
 278   "Make hierarchical directory name from NEWSGROUP name."
 279   (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
 280          (idx (string-match ":" newsgroup)))
 281     (concat
 282      (if idx (substring newsgroup 0 idx))
 283      (if idx "/")
 284      (nnheader-replace-chars-in-string
 285       (if idx (substring newsgroup (1+ idx)) newsgroup)
 286       ?. ?/))))
 287
 288 (defun gnus-newsgroup-savable-name (group)
 289   ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
 290   ;; with dots.
 291   (nnheader-replace-chars-in-string group ?/ ?.))
 292
 293 (defun gnus-string> (s1 s2)
 294   (not (or (string< s1 s2)
 295            (string= s1 s2))))
 296
 297 (defun gnus-string< (s1 s2)
 298   "Return t if first arg string is less than second in lexicographic order.
 299 Case is significant if and only if `case-fold-search' is nil.
 300 Symbols are also allowed; their print names are used instead."
 301   (if case-fold-search
 302       (string-lessp (downcase (if (symbolp s1) (symbol-name s1) s1))
 303                     (downcase (if (symbolp s2) (symbol-name s2) s2)))
 304     (string-lessp s1 s2)))
 305
 306 ;;; Time functions.
 307
 308 (defun gnus-file-newer-than (file date)
 309   (let ((fdate (nth 5 (file-attributes file))))
 310     (or (> (car fdate) (car date))
 311         (and (= (car fdate) (car date))
 312              (> (nth 1 fdate) (nth 1 date))))))
 313
 314 ;; Every version of Emacs Gnus supports has built-in float-time.
 315 ;; The featurep test silences an irritating compiler warning.
 316 (defalias 'gnus-float-time
 317   (if (or (featurep 'emacs)
 318           (fboundp 'float-time))
 319       'float-time 'time-to-seconds)
 320   "Convert time value TIME to a floating point number.
 321 TIME defaults to the current time.")
 322
 323 ;;; Keymap macros.
 324
 325 (defmacro gnus-local-set-keys (&rest plist)
 326   "Set the keys in PLIST in the current keymap."
 327   `(gnus-define-keys-1 (current-local-map) ',plist))
 328
 329 (defmacro gnus-define-keys (keymap &rest plist)
 330   "Define all keys in PLIST in KEYMAP."
 331   ;; Convert the key [?\S-\ ] to [(shift space)] for XEmacs.
 332   (when (featurep 'xemacs)
 333     (let ((bindings plist))
 334       (while bindings
 335         (when (equal (car bindings) [?\S-\ ])
 336           (setcar bindings [(shift space)]))
 337         (setq bindings (cddr bindings)))))
 338   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist)))
 339
 340 (defmacro gnus-define-keys-safe (keymap &rest plist)
 341   "Define all keys in PLIST in KEYMAP without overwriting previous definitions."
 342   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
 343
 344 (put 'gnus-define-keys 'lisp-indent-function 1)
 345 (put 'gnus-define-keys-safe 'lisp-indent-function 1)
 346 (put 'gnus-local-set-keys 'lisp-indent-function 1)
 347
 348 (defmacro gnus-define-keymap (keymap &rest plist)
 349   "Define all keys in PLIST in KEYMAP."
 350   `(gnus-define-keys-1 ,keymap (quote ,plist)))
 351
 352 (put 'gnus-define-keymap 'lisp-indent-function 1)
 353
 354 (defun gnus-define-keys-1 (keymap plist &optional safe)
 355   (when (null keymap)
 356     (error "Can't set keys in a null keymap"))
 357   (cond ((symbolp keymap)
 358          (setq keymap (symbol-value keymap)))
 359         ((keymapp keymap))
 360         ((listp keymap)
 361          (set (car keymap) nil)
 362          (define-prefix-command (car keymap))
 363          (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap))
 364          (setq keymap (symbol-value (car keymap)))))
 365   (let (key)
 366     (while plist
 367       (when (symbolp (setq key (pop plist)))
 368         (setq key (symbol-value key)))
 369       (if (or (not safe)
 370               (eq (lookup-key keymap key) 'undefined))
 371           (define-key keymap key (pop plist))
 372         (pop plist)))))
 373
 374 (defun gnus-y-or-n-p (prompt)
 375   (prog1
 376       (y-or-n-p prompt)
 377     (message "")))
 378 (defun gnus-yes-or-no-p (prompt)
 379   (prog1
 380       (yes-or-no-p prompt)
 381     (message "")))
 382
 383 ;; By Frank Schmitt <ich@Frank-Schmitt.net>. Allows to have
 384 ;; age-depending date representations. (e.g. just the time if it's
 385 ;; from today, the day of the week if it's within the last 7 days and
 386 ;; the full date if it's older)
 387
 388 (defun gnus-seconds-today ()
 389   "Return the number of seconds passed today."
 390   (let ((now (decode-time)))
 391     (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600))))
 392
 393 (defun gnus-seconds-month ()
 394   "Return the number of seconds passed this month."
 395   (let ((now (decode-time)))
 396     (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
 397        (* (- (car (nthcdr 3 now)) 1) 3600 24))))
 398
 399 (defun gnus-seconds-year ()
 400   "Return the number of seconds passed this year."
 401   (let* ((current (current-time))
 402          (now (decode-time current))
 403          (days (format-time-string "%j" current)))
 404     (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
 405        (* (- (string-to-number days) 1) 3600 24))))
 406
 407 (defmacro gnus-date-get-time (date)
 408   "Convert DATE string to Emacs time.
 409 Cache the result as a text property stored in DATE."
 410   ;; Either return the cached value...
 411   `(let ((d ,date))
 412      (if (equal "" d)
 413          '(0 0)
 414        (or (get-text-property 0 'gnus-time d)
 415            ;; or compute the value...
 416            (let ((time (safe-date-to-time d)))
 417              ;; and store it back in the string.
 418              (put-text-property 0 1 'gnus-time time d)
 419              time)))))
 420
 421 (defun gnus-dd-mmm (messy-date)
 422   "Return a string like DD-MMM from a big messy string."
 423   (condition-case ()
 424       (format-time-string "%d-%b" (gnus-date-get-time messy-date))
 425     (error "  -   ")))
 426
 427 (defsubst gnus-time-iso8601 (time)
 428   "Return a string of TIME in YYYYMMDDTHHMMSS format."
 429   (format-time-string "%Y%m%dT%H%M%S" time))
 430
 431 (defun gnus-date-iso8601 (date)
 432   "Convert the DATE to YYYYMMDDTHHMMSS."
 433   (condition-case ()
 434       (gnus-time-iso8601 (gnus-date-get-time date))
 435     (error "")))
 436
 437 (defun gnus-mode-string-quote (string)
 438   "Quote all \"%\"'s in STRING."
 439   (gnus-replace-in-string string "%" "%%"))
 440
 441 ;; Make a hash table (default and minimum size is 256).
 442 ;; Optional argument HASHSIZE specifies the table size.
 443 (defun gnus-make-hashtable (&optional hashsize)
 444   (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0))
 445
 446 ;; Make a number that is suitable for hashing; bigger than MIN and
 447 ;; equal to some 2^x.  Many machines (such as sparcs) do not have a
 448 ;; hardware modulo operation, so they implement it in software.  On
 449 ;; many sparcs over 50% of the time to intern is spent in the modulo.
 450 ;; Yes, it's slower than actually computing the hash from the string!
 451 ;; So we use powers of 2 so people can optimize the modulo to a mask.
 452 (defun gnus-create-hash-size (min)
 453   (let ((i 1))
 454     (while (< i min)
 455       (setq i (* 2 i)))
 456     i))
 457
 458 (defcustom gnus-verbose 6
 459   "*Integer that says how verbose Gnus should be.
 460 The higher the number, the more messages Gnus will flash to say what
 461 it's doing.  At zero, Gnus will be totally mute; at five, Gnus will
 462 display most important messages; and at ten, Gnus will keep on
 463 jabbering all the time."
 464   :version "24.1"
 465   :group 'gnus-start
 466   :type 'integer)
 467
 468 (defcustom gnus-add-timestamp-to-message nil
 469   "Non-nil means add timestamps to messages that Gnus issues.
 470 If it is `log', add timestamps to only the messages that go into the
 471 \"*Messages*\" buffer (in XEmacs, it is the \" *Message-Log*\" buffer).
 472 If it is neither nil nor `log', add timestamps not only to log messages
 473 but also to the ones displayed in the echo area."
 474   :version "23.1" ;; No Gnus
 475   :group  'gnus-various
 476   :type '(choice :format "%{%t%}:\n %[Value Menu%] %v"
 477                  (const :tag "Logged messages only" log)
 478                  (sexp :tag "All messages"
 479                        :match (lambda (widget value) value)
 480                        :value t)
 481                  (const :tag "No timestamp" nil)))
 482
 483 (eval-when-compile
 484   (defmacro gnus-message-with-timestamp-1 (format-string args)
 485     (let ((timestamp '(format-time-string "%Y%m%dT%H%M%S.%3N> " time)))
 486       (if (featurep 'xemacs)
 487           `(let (str time)
 488              (if (or (and (null ,format-string) (null ,args))
 489                      (progn
 490                        (setq str (apply 'format ,format-string ,args))
 491                        (zerop (length str))))
 492                  (prog1
 493                      (and ,format-string str)
 494                    (clear-message nil))
 495                (cond ((eq gnus-add-timestamp-to-message 'log)
 496                       (setq time (current-time))
 497                       (display-message 'no-log str)
 498                       (log-message 'message (concat ,timestamp str)))
 499                      (gnus-add-timestamp-to-message
 500                       (setq time (current-time))
 501                       (display-message 'message (concat ,timestamp str)))
 502                      (t
 503                       (display-message 'message str))))
 504              str)
 505         `(let (str time)
 506            (cond ((eq gnus-add-timestamp-to-message 'log)
 507                   (setq str (let (message-log-max)
 508                               (apply 'message ,format-string ,args)))
 509                   (when (and message-log-max
 510                              (> message-log-max 0)
 511                              (/= (length str) 0))
 512                     (setq time (current-time))
 513                     (with-current-buffer (if (fboundp 'messages-buffer)
 514                                              (messages-buffer)
 515                                            (get-buffer-create "*Messages*"))
 516                       (goto-char (point-max))
 517                       (let ((inhibit-read-only t))
 518                         (insert ,timestamp str "\n")
 519                         (forward-line (- message-log-max))
 520                         (delete-region (point-min) (point)))
 521                       (goto-char (point-max))))
 522                   str)
 523                  (gnus-add-timestamp-to-message
 524                   (if (or (and (null ,format-string) (null ,args))
 525                           (progn
 526                             (setq str (apply 'format ,format-string ,args))
 527                             (zerop (length str))))
 528                       (prog1
 529                           (and ,format-string str)
 530                         (message nil))
 531                     (setq time (current-time))
 532                     (message "%s" (concat ,timestamp str))
 533                     str))
 534                  (t
 535                   (apply 'message ,format-string ,args))))))))
 536
 537 (defvar gnus-action-message-log nil)
 538
 539 (defun gnus-message-with-timestamp (format-string &rest args)
 540   "Display message with timestamp.  Arguments are the same as `message'.
 541 The `gnus-add-timestamp-to-message' variable controls how to add
 542 timestamp to message."
 543   (gnus-message-with-timestamp-1 format-string args))
 544
 545 (defun gnus-message (level &rest args)
 546   "If LEVEL is lower than `gnus-verbose' print ARGS using `message'.
 547
 548 Guideline for numbers:
 549 1 - error messages, 3 - non-serious error messages, 5 - messages for things
 550 that take a long time, 7 - not very important messages on stuff, 9 - messages
 551 inside loops."
 552   (if (<= level gnus-verbose)
 553       (let ((message
 554              (if gnus-add-timestamp-to-message
 555                  (apply 'gnus-message-with-timestamp args)
 556                (apply 'message args))))
 557         (when (and (consp gnus-action-message-log)
 558                    (<= level 3))
 559           (push message gnus-action-message-log))
 560         message)
 561     ;; We have to do this format thingy here even if the result isn't
 562     ;; shown - the return value has to be the same as the return value
 563     ;; from `message'.
 564     (apply 'format args)))
 565
 566 (defun gnus-final-warning ()
 567   (when (and (consp gnus-action-message-log)
 568              (setq gnus-action-message-log
 569                    (delete nil gnus-action-message-log)))
 570     (message "Warning: %s"
 571              (mapconcat #'identity gnus-action-message-log "; "))))
 572
 573 (defun gnus-error (level &rest args)
 574   "Beep an error if LEVEL is equal to or less than `gnus-verbose'.
 575 ARGS are passed to `message'."
 576   (when (<= (floor level) gnus-verbose)
 577     (apply 'message args)
 578     (ding)
 579     (let (duration)
 580       (when (and (floatp level)
 581                  (not (zerop (setq duration (* 10 (- level (floor level)))))))
 582         (sit-for duration))))
 583   nil)
 584
 585 (defun gnus-split-references (references)
 586   "Return a list of Message-IDs in REFERENCES."
 587   (let ((beg 0)
 588         (references (mail-header-remove-comments (or references "")))
 589         ids)
 590     (while (string-match "<[^<]+[^< \t]" references beg)
 591       (push (substring references (match-beginning 0) (setq beg (match-end 0)))
 592             ids))
 593     (nreverse ids)))
 594
 595 (defun gnus-extract-references (references)
 596   "Return a list of Message-IDs in REFERENCES (in In-Reply-To
 597   format), trimmed to only contain the Message-IDs."
 598   (let ((ids (gnus-split-references references))
 599         refs)
 600     (dolist (id ids)
 601       (when (string-match "<[^<>]+>" id)
 602         (push (match-string 0 id) refs)))
 603     refs))
 604
 605 (defsubst gnus-parent-id (references &optional n)
 606   "Return the last Message-ID in REFERENCES.
 607 If N, return the Nth ancestor instead."
 608   (when (and references
 609              (not (zerop (length references))))
 610     (if n
 611         (let ((ids (inline (gnus-split-references references))))
 612           (while (nthcdr n ids)
 613             (setq ids (cdr ids)))
 614           (car ids))
 615       (let ((references (mail-header-remove-comments references)))
 616         (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
 617           (match-string 1 references))))))
 618
 619 (defsubst gnus-buffer-live-p (buffer)
 620   "Say whether BUFFER is alive or not."
 621   (and buffer (buffer-live-p (get-buffer buffer))))
 622
 623 (defun gnus-horizontal-recenter ()
 624   "Recenter the current buffer horizontally."
 625   (if (< (current-column) (/ (window-width) 2))
 626       (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0)
 627     (let* ((orig (point))
 628            (end (window-end (gnus-get-buffer-window (current-buffer) t)))
 629            (max 0))
 630       (when end
 631         ;; Find the longest line currently displayed in the window.
 632         (goto-char (window-start))
 633         (while (and (not (eobp))
 634                     (< (point) end))
 635           (end-of-line)
 636           (setq max (max max (current-column)))
 637           (forward-line 1))
 638         (goto-char orig)
 639         ;; Scroll horizontally to center (sort of) the point.
 640         (if (> max (window-width))
 641             (set-window-hscroll
 642              (gnus-get-buffer-window (current-buffer) t)
 643              (min (- (current-column) (/ (window-width) 3))
 644                   (+ 2 (- max (window-width)))))
 645           (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0))
 646         max))))
 647
 648 (defun gnus-read-event-char (&optional prompt)
 649   "Get the next event."
 650   (let ((event (read-event prompt)))
 651     ;; should be gnus-characterp, but this can't be called in XEmacs anyway
 652     (cons (and (numberp event) event) event)))
 653
 654 (defun gnus-copy-file (file &optional to)
 655   "Copy FILE to TO."
 656   (interactive
 657    (list (read-file-name "Copy file: " default-directory)
 658          (read-file-name "Copy file to: " default-directory)))
 659   (unless to
 660     (setq to (read-file-name "Copy file to: " default-directory)))
 661   (when (file-directory-p to)
 662     (setq to (concat (file-name-as-directory to)
 663                      (file-name-nondirectory file))))
 664   (copy-file file to))
 665
 666 (defvar gnus-work-buffer " *gnus work*")
 667
 668 (declare-function gnus-get-buffer-create "gnus" (name))
 669 ;; gnus.el requires mm-util.
 670 (declare-function mm-enable-multibyte "mm-util")
 671
 672 (defun gnus-set-work-buffer ()
 673   "Put point in the empty Gnus work buffer."
 674   (if (get-buffer gnus-work-buffer)
 675       (progn
 676         (set-buffer gnus-work-buffer)
 677         (erase-buffer))
 678     (set-buffer (gnus-get-buffer-create gnus-work-buffer))
 679     (kill-all-local-variables)
 680     (mm-enable-multibyte)))
 681
 682 (defmacro gnus-group-real-name (group)
 683   "Find the real name of a foreign newsgroup."
 684   `(let ((gname ,group))
 685      (if (string-match "^[^:]+:" gname)
 686          (substring gname (match-end 0))
 687        gname)))
 688
 689 (defmacro gnus-group-server (group)
 690   "Find the server name of a foreign newsgroup.
 691 For example, (gnus-group-server \"nnimap+yxa:INBOX.foo\") would
 692 yield \"nnimap:yxa\"."
 693   `(let ((gname ,group))
 694      (if (string-match "^\\([^:+]+\\)\\(?:\\+\\([^:]*\\)\\)?:" gname)
 695          (format "%s:%s" (match-string 1 gname) (or
 696                                                  (match-string 2 gname)
 697                                                  ""))
 698        (format "%s:%s" (car gnus-select-method) (cadr gnus-select-method)))))
 699
 700 (defun gnus-make-sort-function (funs)
 701   "Return a composite sort condition based on the functions in FUNS."
 702   (cond
 703    ;; Just a simple function.
 704    ((functionp funs) funs)
 705    ;; No functions at all.
 706    ((null funs) funs)
 707    ;; A list of functions.
 708    ((or (cdr funs)
 709         (listp (car funs)))
 710     (gnus-byte-compile
 711      `(lambda (t1 t2)
 712         ,(gnus-make-sort-function-1 (reverse funs)))))
 713    ;; A list containing just one function.
 714    (t
 715     (car funs))))
 716
 717 (defun gnus-make-sort-function-1 (funs)
 718   "Return a composite sort condition based on the functions in FUNS."
 719   (let ((function (car funs))
 720         (first 't1)
 721         (last 't2))
 722     (when (consp function)
 723       (cond
 724        ;; Reversed spec.
 725        ((eq (car function) 'not)
 726         (setq function (cadr function)
 727               first 't2
 728               last 't1))
 729        ((functionp function)
 730         ;; Do nothing.
 731         )
 732        (t
 733         (error "Invalid sort spec: %s" function))))
 734     (if (cdr funs)
 735         `(or (,function ,first ,last)
 736              (and (not (,function ,last ,first))
 737                   ,(gnus-make-sort-function-1 (cdr funs))))
 738       `(,function ,first ,last))))
 739
 740 (defun gnus-turn-off-edit-menu (type)
 741   "Turn off edit menu in `gnus-TYPE-mode-map'."
 742   (define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
 743     [menu-bar edit] 'undefined))
 744
 745 (defmacro gnus-bind-print-variables (&rest forms)
 746   "Bind print-* variables and evaluate FORMS.
 747 This macro is used with `prin1', `pp', etc. in order to ensure printed
 748 Lisp objects are loadable.  Bind `print-quoted' and `print-readably'
 749 to t, and `print-escape-multibyte', `print-escape-newlines',
 750 `print-escape-nonascii', `print-length', `print-level' and
 751 `print-string-length' to nil."
 752   `(let ((print-quoted t)
 753          (print-readably t)
 754          ;;print-circle
 755          ;;print-continuous-numbering
 756          print-escape-multibyte
 757          print-escape-newlines
 758          print-escape-nonascii
 759          ;;print-gensym
 760          print-length
 761          print-level
 762          print-string-length)
 763      ,@forms))
 764
 765 (defun gnus-prin1 (form)
 766   "Use `prin1' on FORM in the current buffer.
 767 Bind `print-quoted' and `print-readably' to t, and `print-length' and
 768 `print-level' to nil.  See also `gnus-bind-print-variables'."
 769   (gnus-bind-print-variables (prin1 form (current-buffer))))
 770
 771 (defun gnus-prin1-to-string (form)
 772   "The same as `prin1'.
 773 Bind `print-quoted' and `print-readably' to t, and `print-length' and
 774 `print-level' to nil.  See also `gnus-bind-print-variables'."
 775   (gnus-bind-print-variables (prin1-to-string form)))
 776
 777 (defun gnus-pp (form &optional stream)
 778   "Use `pp' on FORM in the current buffer.
 779 Bind `print-quoted' and `print-readably' to t, and `print-length' and
 780 `print-level' to nil.  See also `gnus-bind-print-variables'."
 781   (gnus-bind-print-variables (pp form (or stream (current-buffer)))))
 782
 783 (defun gnus-pp-to-string (form)
 784   "The same as `pp-to-string'.
 785 Bind `print-quoted' and `print-readably' to t, and `print-length' and
 786 `print-level' to nil.  See also `gnus-bind-print-variables'."
 787   (gnus-bind-print-variables (pp-to-string form)))
 788
 789 (defun gnus-make-directory (directory)
 790   "Make DIRECTORY (and all its parents) if it doesn't exist."
 791   (require 'nnmail)
 792   (let ((file-name-coding-system nnmail-pathname-coding-system))
 793     (when (and directory
 794                (not (file-exists-p directory)))
 795       (make-directory directory t)))
 796   t)
 797
 798 (defun gnus-write-buffer (file)
 799   "Write the current buffer's contents to FILE."
 800   (require 'nnmail)
 801   (let ((file-name-coding-system nnmail-pathname-coding-system))
 802     ;; Make sure the directory exists.
 803     (gnus-make-directory (file-name-directory file))
 804     ;; Write the buffer.
 805     (write-region (point-min) (point-max) file nil 'quietly)))
 806
 807 (defun gnus-delete-file (file)
 808   "Delete FILE if it exists."
 809   (when (file-exists-p file)
 810     (delete-file file)))
 811
 812 (defun gnus-delete-duplicates (list)
 813   "Remove duplicate entries from LIST."
 814   (let ((result nil))
 815     (while list
 816       (unless (member (car list) result)
 817         (push (car list) result))
 818       (pop list))
 819     (nreverse result)))
 820
 821 (defun gnus-delete-directory (directory)
 822   "Delete files in DIRECTORY.  Subdirectories remain.
 823 If there's no subdirectory, delete DIRECTORY as well."
 824   (when (file-directory-p directory)
 825     (let ((files (directory-files
 826                   directory t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))
 827           file dir)
 828       (while files
 829         (setq file (pop files))
 830         (if (eq t (car (file-attributes file)))
 831             ;; `file' is a subdirectory.
 832             (setq dir t)
 833           ;; `file' is a file or a symlink.
 834           (delete-file file)))
 835       (unless dir
 836         (delete-directory directory)))))
 837
 838 (defun gnus-strip-whitespace (string)
 839   "Return STRING stripped of all whitespace."
 840   (while (string-match "[\r\n\t ]+" string)
 841     (setq string (replace-match "" t t string)))
 842   string)
 843
 844 (declare-function gnus-put-text-property "gnus"
 845                   (start end property value &optional object))
 846
 847 (defsubst gnus-put-text-property-excluding-newlines (beg end prop val)
 848   "The same as `put-text-property', but don't put this prop on any newlines in the region."
 849   (save-match-data
 850     (save-excursion
 851       (save-restriction
 852         (goto-char beg)
 853         (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
 854           (gnus-put-text-property beg (match-beginning 0) prop val)
 855           (setq beg (point)))
 856         (gnus-put-text-property beg (point) prop val)))))
 857
 858 (declare-function gnus-overlay-put  "gnus" (overlay prop value))
 859 (declare-function gnus-make-overlay "gnus"
 860                   (beg end &optional buffer front-advance rear-advance))
 861
 862 (defsubst gnus-put-overlay-excluding-newlines (beg end prop val)
 863   "The same as `put-text-property', but don't put this prop on any newlines in the region."
 864   (save-match-data
 865     (save-excursion
 866       (save-restriction
 867         (goto-char beg)
 868         (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
 869           (gnus-overlay-put
 870            (gnus-make-overlay beg (match-beginning 0))
 871            prop val)
 872           (setq beg (point)))
 873         (gnus-overlay-put (gnus-make-overlay beg (point)) prop val)))))
 874
 875 (defun gnus-put-text-property-excluding-characters-with-faces (beg end prop val)
 876   "The same as `put-text-property', except where `gnus-face' is set.
 877 If so, and PROP is `face', set the second element of its value to VAL.
 878 Otherwise, do nothing."
 879   (while (< beg end)
 880     ;; Property values are compared with `eq'.
 881     (let ((stop (next-single-property-change beg 'face nil end)))
 882       (if (get-text-property beg 'gnus-face)
 883           (when (eq prop 'face)
 884             (setcar (cdr (get-text-property beg 'face)) (or val 'default)))
 885         (inline
 886           (gnus-put-text-property beg stop prop val)))
 887       (setq beg stop))))
 888
 889 (defun gnus-get-text-property-excluding-characters-with-faces (pos prop)
 890   "The same as `get-text-property', except where `gnus-face' is set.
 891 If so, and PROP is `face', return the second element of its value.
 892 Otherwise, return the value."
 893   (let ((val (get-text-property pos prop)))
 894     (if (and (get-text-property pos 'gnus-face)
 895              (eq prop 'face))
 896         (cadr val)
 897       (get-text-property pos prop))))
 898
 899 (defmacro gnus-faces-at (position)
 900   "Return a list of faces at POSITION."
 901   (if (featurep 'xemacs)
 902       `(let ((pos ,position))
 903          (mapcar-extents 'extent-face
 904                          nil (current-buffer) pos pos nil 'face))
 905     `(let ((pos ,position))
 906        (delq nil (cons (get-text-property pos 'face)
 907                        (mapcar
 908                         (lambda (overlay)
 909                           (overlay-get overlay 'face))
 910                         (overlays-at pos)))))))
 911
 912 (if (fboundp 'invisible-p)
 913     (defalias 'gnus-invisible-p 'invisible-p)
 914   ;; for Emacs < 22.2, and XEmacs.
 915   (defun gnus-invisible-p (pos)
 916     "Return non-nil if the character after POS is currently invisible."
 917     (let ((prop (get-char-property pos 'invisible)))
 918       (if (eq buffer-invisibility-spec t)
 919           prop
 920         (or (memq prop buffer-invisibility-spec)
 921             (assq prop buffer-invisibility-spec))))))
 922
 923 ;; Note: the optional 2nd argument has a different meaning between
 924 ;; Emacs and XEmacs.
 925 ;; (next-char-property-change POSITION &optional LIMIT)
 926 ;; (next-extent-change        POS      &optional OBJECT)
 927 (defalias 'gnus-next-char-property-change
 928   (if (fboundp 'next-extent-change)
 929       'next-extent-change 'next-char-property-change))
 930
 931 (defalias 'gnus-previous-char-property-change
 932   (if (fboundp 'previous-extent-change)
 933       'previous-extent-change 'previous-char-property-change))
 934
 935 ;;; Protected and atomic operations.  dmoore@ucsd.edu 21.11.1996
 936 ;; The primary idea here is to try to protect internal data structures
 937 ;; from becoming corrupted when the user hits C-g, or if a hook or
 938 ;; similar blows up.  Often in Gnus multiple tables/lists need to be
 939 ;; updated at the same time, or information can be lost.
 940
 941 (defvar gnus-atomic-be-safe t
 942   "If t, certain operations will be protected from interruption by C-g.")
 943
 944 (defmacro gnus-atomic-progn (&rest forms)
 945   "Evaluate FORMS atomically, which means to protect the evaluation
 946 from being interrupted by the user.  An error from the forms themselves
 947 will return without finishing the operation.  Since interrupts from
 948 the user are disabled, it is recommended that only the most minimal
 949 operations are performed by FORMS.  If you wish to assign many
 950 complicated values atomically, compute the results into temporary
 951 variables and then do only the assignment atomically."
 952   `(let ((inhibit-quit gnus-atomic-be-safe))
 953      ,@forms))
 954
 955 (put 'gnus-atomic-progn 'lisp-indent-function 0)
 956
 957 (defmacro gnus-atomic-progn-assign (protect &rest forms)
 958   "Evaluate FORMS, but ensure that the variables listed in PROTECT
 959 are not changed if anything in FORMS signals an error or otherwise
 960 non-locally exits.  The variables listed in PROTECT are updated atomically.
 961 It is safe to use gnus-atomic-progn-assign with long computations.
 962
 963 Note that if any of the symbols in PROTECT were unbound, they will be
 964 set to nil on a successful assignment.  In case of an error or other
 965 non-local exit, it will still be unbound."
 966   (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol
 967                                                   (concat (symbol-name x)
 968                                                           "-tmp"))
 969                                                  x))
 970                                protect))
 971          (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x)))
 972                                temp-sym-map))
 973          (temp-sym-let (mapcar (lambda (x) (list (car x)
 974                                                  `(and (boundp ',(cadr x))
 975                                                        ,(cadr x))))
 976                                temp-sym-map))
 977          (sym-temp-let sym-temp-map)
 978          (temp-sym-assign (apply 'append temp-sym-map))
 979          (sym-temp-assign (apply 'append sym-temp-map))
 980          (result (make-symbol "result-tmp")))
 981     `(let (,@temp-sym-let
 982            ,result)
 983        (let ,sym-temp-let
 984          (setq ,result (progn ,@forms))
 985          (setq ,@temp-sym-assign))
 986        (let ((inhibit-quit gnus-atomic-be-safe))
 987          (setq ,@sym-temp-assign))
 988        ,result)))
 989
 990 (put 'gnus-atomic-progn-assign 'lisp-indent-function 1)
 991 ;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body))
 992
 993 (defmacro gnus-atomic-setq (&rest pairs)
 994   "Similar to setq, except that the real symbols are only assigned when
 995 there are no errors.  And when the real symbols are assigned, they are
 996 done so atomically.  If other variables might be changed via side-effect,
 997 see gnus-atomic-progn-assign.  It is safe to use gnus-atomic-setq
 998 with potentially long computations."
 999   (let ((tpairs pairs)
1000         syms)
1001     (while tpairs
1002       (push (car tpairs) syms)
1003       (setq tpairs (cddr tpairs)))
1004     `(gnus-atomic-progn-assign ,syms
1005        (setq ,@pairs))))
1006
1007 ;(put 'gnus-atomic-setq 'edebug-form-spec '(body))
1008
1009
1010 ;;; Functions for saving to babyl/mail files.
1011
1012 (eval-when-compile
1013   (if (featurep 'xemacs)
1014       ;; Don't load tm and apel XEmacs packages that provide some
1015       ;; Emacs emulating functions and variables.
1016       (let ((features features))
1017         (provide 'tm-view)
1018         (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore))
1019         (require 'rmail)) ;; It requires tm-view that loads apel.
1020     (require 'rmail))
1021   (autoload 'rmail-update-summary "rmailsum"))
1022
1023 (defvar mm-text-coding-system)
1024
1025 (declare-function mm-append-to-file "mm-util"
1026                   (start end filename &optional codesys inhibit))
1027 (declare-function rmail-swap-buffers-maybe "rmail" ())
1028 (declare-function rmail-maybe-set-message-counters "rmail" ())
1029 (declare-function rmail-count-new-messages "rmail" (&optional nomsg))
1030 (declare-function rmail-summary-exists "rmail" ())
1031 (declare-function rmail-show-message "rmail" (&optional n no-summary))
1032 ;; Macroexpansion of rmail-select-summary:
1033 (declare-function rmail-summary-displayed "rmail" ())
1034 (declare-function rmail-pop-to-buffer "rmail" (&rest args))
1035 (declare-function rmail-maybe-display-summary "rmail" ())
1036
1037 (defun gnus-output-to-rmail (filename &optional ask)
1038   "Append the current article to an Rmail file named FILENAME.
1039 In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
1040 FILENAME exists and is Babyl format."
1041   (require 'rmail)
1042   (require 'mm-util)
1043   (require 'nnmail)
1044   ;; Some of this codes is borrowed from rmailout.el.
1045   (setq filename (expand-file-name filename))
1046   ;; FIXME should we really be messing with this defcustom?
1047   ;; It is not needed for the operation of this function.
1048   (if (boundp 'rmail-default-rmail-file)
1049       (setq rmail-default-rmail-file filename) ; 22
1050     (setq rmail-default-file filename))        ; 23
1051   (let ((artbuf (current-buffer))
1052         (tmpbuf (get-buffer-create " *Gnus-output*"))
1053         ;; Babyl rmail.el defines this, mbox does not.
1054         (babyl (fboundp 'rmail-insert-rmail-file-header)))
1055     (save-excursion
1056       ;; Note that we ignore the possibility of visiting a Babyl
1057       ;; format buffer in Emacs 23, since Rmail no longer supports that.
1058      (or (get-file-buffer filename)
1059          (progn
1060            ;; In case someone wants to write to a Babyl file from Emacs 23.
1061            (when (file-exists-p filename)
1062              (setq babyl (mail-file-babyl-p filename))
1063              t))
1064           (if (or (not ask)
1065                   (gnus-yes-or-no-p
1066                    (concat "\"" filename "\" does not exist, create it? ")))
1067               (let ((file-buffer (create-file-buffer filename)))
1068                 (with-current-buffer file-buffer
1069                   (if (fboundp 'rmail-insert-rmail-file-header)
1070                       (rmail-insert-rmail-file-header))
1071                   (let ((require-final-newline nil)
1072                         (coding-system-for-write mm-text-coding-system))
1073                     (gnus-write-buffer filename)))
1074                 (kill-buffer file-buffer))
1075             (error "Output file does not exist")))
1076       (set-buffer tmpbuf)
1077       (erase-buffer)
1078       (insert-buffer-substring artbuf)
1079       (if babyl
1080           (gnus-convert-article-to-rmail)
1081         ;; Non-Babyl case copied from gnus-output-to-mail.
1082         (goto-char (point-min))
1083         (if (looking-at "From ")
1084             (forward-line 1)
1085           (insert "From nobody " (current-time-string) "\n"))
1086         (let (case-fold-search)
1087           (while (re-search-forward "^From " nil t)
1088             (beginning-of-line)
1089             (insert ">"))))
1090       ;; Decide whether to append to a file or to an Emacs buffer.
1091       (let ((outbuf (get-file-buffer filename)))
1092         (if (not outbuf)
1093             (progn
1094               (unless babyl             ; from gnus-output-to-mail
1095                 (let ((buffer-read-only nil))
1096                   (goto-char (point-max))
1097                   (forward-char -2)
1098                   (unless (looking-at "\n\n")
1099                     (goto-char (point-max))
1100                     (unless (bolp)
1101                       (insert "\n"))
1102                     (insert "\n"))))
1103               (let ((file-name-coding-system nnmail-pathname-coding-system))
1104                 (mm-append-to-file (point-min) (point-max) filename)))
1105           ;; File has been visited, in buffer OUTBUF.
1106           (set-buffer outbuf)
1107           (let ((buffer-read-only nil)
1108                 (msg (and (boundp 'rmail-current-message)
1109                           (symbol-value 'rmail-current-message))))
1110             ;; If MSG is non-nil, buffer is in RMAIL mode.
1111             ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23.
1112             (when msg
1113               (unless babyl
1114                 (rmail-swap-buffers-maybe)
1115                 (rmail-maybe-set-message-counters))
1116               (widen)
1117               (narrow-to-region (point-max) (point-max)))
1118             (insert-buffer-substring tmpbuf)
1119             (when msg
1120               (when babyl
1121                 (goto-char (point-min))
1122                 (widen)
1123                 (search-backward "\n\^_")
1124                 (narrow-to-region (point) (point-max)))
1125               (rmail-count-new-messages t)
1126               (when (rmail-summary-exists)
1127                 (rmail-select-summary
1128                  (rmail-update-summary)))
1129               (rmail-show-message msg))
1130             (save-buffer)))))
1131     (kill-buffer tmpbuf)))
1132
1133 (defun gnus-output-to-mail (filename &optional ask)
1134   "Append the current article to a mail file named FILENAME."
1135   (require 'nnmail)
1136   (setq filename (expand-file-name filename))
1137   (let ((artbuf (current-buffer))
1138         (tmpbuf (get-buffer-create " *Gnus-output*")))
1139     (save-excursion
1140       ;; Create the file, if it doesn't exist.
1141       (when (and (not (get-file-buffer filename))
1142                  (not (file-exists-p filename)))
1143         (if (or (not ask)
1144                 (gnus-y-or-n-p
1145                  (concat "\"" filename "\" does not exist, create it? ")))
1146             (let ((file-buffer (create-file-buffer filename)))
1147               (with-current-buffer file-buffer
1148                 (let ((require-final-newline nil)
1149                       (coding-system-for-write mm-text-coding-system))
1150                   (gnus-write-buffer filename)))
1151               (kill-buffer file-buffer))
1152           (error "Output file does not exist")))
1153       (set-buffer tmpbuf)
1154       (erase-buffer)
1155       (insert-buffer-substring artbuf)
1156       (goto-char (point-min))
1157       (if (looking-at "From ")
1158           (forward-line 1)
1159         (insert "From nobody " (current-time-string) "\n"))
1160       (let (case-fold-search)
1161         (while (re-search-forward "^From " nil t)
1162           (beginning-of-line)
1163           (insert ">")))
1164       ;; Decide whether to append to a file or to an Emacs buffer.
1165       (let ((outbuf (get-file-buffer filename)))
1166         (if (not outbuf)
1167             (let ((buffer-read-only nil))
1168               (save-excursion
1169                 (goto-char (point-max))
1170                 (forward-char -2)
1171                 (unless (looking-at "\n\n")
1172                   (goto-char (point-max))
1173                   (unless (bolp)
1174                     (insert "\n"))
1175                   (insert "\n"))
1176                 (goto-char (point-max))
1177                 (let ((file-name-coding-system nnmail-pathname-coding-system))
1178                   (mm-append-to-file (point-min) (point-max) filename))))
1179           ;; File has been visited, in buffer OUTBUF.
1180           (set-buffer outbuf)
1181           (let ((buffer-read-only nil))
1182             (goto-char (point-max))
1183             (unless (eobp)
1184               (insert "\n"))
1185             (insert "\n")
1186             (insert-buffer-substring tmpbuf)))))
1187     (kill-buffer tmpbuf)))
1188
1189 (defun gnus-convert-article-to-rmail ()
1190   "Convert article in current buffer to Rmail message format."
1191   (let ((buffer-read-only nil))
1192     ;; Convert article directly into Babyl format.
1193     (goto-char (point-min))
1194     (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
1195     (while (search-forward "\n\^_" nil t) ;single char
1196       (replace-match "\n^_" t t))       ;2 chars: "^" and "_"
1197     (goto-char (point-max))
1198     (insert "\^_")))
1199
1200 (defun gnus-map-function (funs arg)
1201   "Apply the result of the first function in FUNS to the second, and so on.
1202 ARG is passed to the first function."
1203   (while funs
1204     (setq arg (funcall (pop funs) arg)))
1205   arg)
1206
1207 (defun gnus-run-hooks (&rest funcs)
1208   "Does the same as `run-hooks', but saves the current buffer."
1209   (save-current-buffer
1210     (apply 'run-hooks funcs)))
1211
1212 (defun gnus-run-hook-with-args (hook &rest args)
1213   "Does the same as `run-hook-with-args', but saves the current buffer."
1214   (save-current-buffer
1215     (apply 'run-hook-with-args hook args)))
1216
1217 (defun gnus-run-mode-hooks (&rest funcs)
1218   "Run `run-mode-hooks' if it is available, otherwise `run-hooks'.
1219 This function saves the current buffer."
1220   (if (fboundp 'run-mode-hooks)
1221       (save-current-buffer (apply 'run-mode-hooks funcs))
1222     (save-current-buffer (apply 'run-hooks funcs))))
1223
1224 ;;; Various
1225
1226 (defvar gnus-group-buffer)              ; Compiler directive
1227 (defun gnus-alive-p ()
1228   "Say whether Gnus is running or not."
1229   (and (boundp 'gnus-group-buffer)
1230        (get-buffer gnus-group-buffer)
1231        (with-current-buffer gnus-group-buffer
1232          (eq major-mode 'gnus-group-mode))))
1233
1234 (defun gnus-remove-if (predicate sequence &optional hash-table-p)
1235   "Return a copy of SEQUENCE with all items satisfying PREDICATE removed.
1236 SEQUENCE should be a list, a vector, or a string.  Returns always a list.
1237 If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
1238   (let (out)
1239     (if hash-table-p
1240         (mapatoms (lambda (symbol)
1241                     (unless (funcall predicate symbol)
1242                       (push symbol out)))
1243                   sequence)
1244       (unless (listp sequence)
1245         (setq sequence (append sequence nil)))
1246       (while sequence
1247         (unless (funcall predicate (car sequence))
1248           (push (car sequence) out))
1249         (setq sequence (cdr sequence))))
1250     (nreverse out)))
1251
1252 (defun gnus-remove-if-not (predicate sequence &optional hash-table-p)
1253   "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed.
1254 SEQUENCE should be a list, a vector, or a string.  Returns always a list.
1255 If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
1256   (let (out)
1257     (if hash-table-p
1258         (mapatoms (lambda (symbol)
1259                     (when (funcall predicate symbol)
1260                       (push symbol out)))
1261                   sequence)
1262       (unless (listp sequence)
1263         (setq sequence (append sequence nil)))
1264       (while sequence
1265         (when (funcall predicate (car sequence))
1266           (push (car sequence) out))
1267         (setq sequence (cdr sequence))))
1268     (nreverse out)))
1269
1270 (if (fboundp 'assq-delete-all)
1271     (defalias 'gnus-delete-alist 'assq-delete-all)
1272   (defun gnus-delete-alist (key alist)
1273     "Delete from ALIST all elements whose car is KEY.
1274 Return the modified alist."
1275     (let (entry)
1276       (while (setq entry (assq key alist))
1277         (setq alist (delq entry alist)))
1278       alist)))
1279
1280 (defun gnus-grep-in-list (word list)
1281   "Find if a WORD matches any regular expression in the given LIST."
1282   (when (and word list)
1283     (catch 'found
1284       (dolist (r list)
1285         (when (string-match r word)
1286           (throw 'found r))))))
1287
1288 (defmacro gnus-alist-pull (key alist &optional assoc-p)
1289   "Modify ALIST to be without KEY."
1290   (unless (symbolp alist)
1291     (error "Not a symbol: %s" alist))
1292   (let ((fun (if assoc-p 'assoc 'assq)))
1293     `(setq ,alist (delq (,fun ,key ,alist) ,alist))))
1294
1295 (defun gnus-globalify-regexp (re)
1296   "Return a regexp that matches a whole line, if RE matches a part of it."
1297   (concat (unless (string-match "^\\^" re) "^.*")
1298           re
1299           (unless (string-match "\\$$" re) ".*$")))
1300
1301 (defun gnus-set-window-start (&optional point)
1302   "Set the window start to POINT, or (point) if nil."
1303   (let ((win (gnus-get-buffer-window (current-buffer) t)))
1304     (when win
1305       (set-window-start win (or point (point))))))
1306
1307 (defun gnus-annotation-in-region-p (b e)
1308   (if (= b e)
1309       (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
1310     (text-property-any b e 'gnus-undeletable t)))
1311
1312 (defun gnus-or (&rest elems)
1313   "Return non-nil if any of the elements are non-nil."
1314   (catch 'found
1315     (while elems
1316       (when (pop elems)
1317         (throw 'found t)))))
1318
1319 (defun gnus-and (&rest elems)
1320   "Return non-nil if all of the elements are non-nil."
1321   (catch 'found
1322     (while elems
1323       (unless (pop elems)
1324         (throw 'found nil)))
1325     t))
1326
1327 ;; gnus.el requires mm-util.
1328 (declare-function mm-disable-multibyte "mm-util")
1329
1330 (defun gnus-write-active-file (file hashtb &optional full-names)
1331   ;; `coding-system-for-write' should be `raw-text' or equivalent.
1332   (let ((coding-system-for-write nnmail-active-file-coding-system))
1333     (with-temp-file file
1334       ;; The buffer should be in the unibyte mode because group names
1335       ;; are ASCII text or encoded non-ASCII text (i.e., unibyte).
1336       (mm-disable-multibyte)
1337       (mapatoms
1338        (lambda (sym)
1339          (when (and sym
1340                     (boundp sym)
1341                     (symbol-value sym))
1342            (insert (format "%S %d %d y\n"
1343                            (if full-names
1344                                sym
1345                              (intern (gnus-group-real-name (symbol-name sym))))
1346                            (or (cdr (symbol-value sym))
1347                                (car (symbol-value sym)))
1348                            (car (symbol-value sym))))))
1349        hashtb)
1350       (goto-char (point-max))
1351       (while (search-backward "\\." nil t)
1352         (delete-char 1)))))
1353
1354 ;; Fixme: Why not use `with-output-to-temp-buffer'?
1355 (defmacro gnus-with-output-to-file (file &rest body)
1356   (let ((buffer (make-symbol "output-buffer"))
1357         (size (make-symbol "output-buffer-size"))
1358         (leng (make-symbol "output-buffer-length"))
1359         (append (make-symbol "output-buffer-append")))
1360     `(let* ((,size 131072)
1361             (,buffer (make-string ,size 0))
1362             (,leng 0)
1363             (,append nil)
1364             (standard-output
1365              (lambda (c)
1366                (aset ,buffer ,leng c)
1367
1368                (if (= ,size (setq ,leng (1+ ,leng)))
1369                    (progn (write-region ,buffer nil ,file ,append 'no-msg)
1370                           (setq ,leng 0
1371                                 ,append t))))))
1372        ,@body
1373        (when (> ,leng 0)
1374          (let ((coding-system-for-write 'no-conversion))
1375          (write-region (substring ,buffer 0 ,leng) nil ,file
1376                        ,append 'no-msg))))))
1377
1378 (put 'gnus-with-output-to-file 'lisp-indent-function 1)
1379 (put 'gnus-with-output-to-file 'edebug-form-spec '(form body))
1380
1381 (if (fboundp 'union)
1382     (defalias 'gnus-union 'union)
1383   (defun gnus-union (l1 l2)
1384     "Set union of lists L1 and L2."
1385     (cond ((null l1) l2)
1386           ((null l2) l1)
1387           ((equal l1 l2) l1)
1388           (t
1389            (or (>= (length l1) (length l2))
1390                (setq l1 (prog1 l2 (setq l2 l1))))
1391            (while l2
1392              (or (member (car l2) l1)
1393                  (push (car l2) l1))
1394              (pop l2))
1395            l1))))
1396
1397 (declare-function gnus-add-text-properties "gnus"
1398                   (start end properties &optional object))
1399
1400 (defun gnus-add-text-properties-when
1401   (property value start end properties &optional object)
1402   "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE."
1403   (let (point)
1404     (while (and start
1405                 (< start end) ;; XEmacs will loop for every when start=end.
1406                 (setq point (text-property-not-all start end property value)))
1407       (gnus-add-text-properties start point properties object)
1408       (setq start (text-property-any point end property value)))
1409     (if start
1410         (gnus-add-text-properties start end properties object))))
1411
1412 (defun gnus-remove-text-properties-when
1413   (property value start end properties &optional object)
1414   "Like `remove-text-properties', only applied on where PROPERTY is VALUE."
1415   (let (point)
1416     (while (and start
1417                 (< start end)
1418                 (setq point (text-property-not-all start end property value)))
1419       (remove-text-properties start point properties object)
1420       (setq start (text-property-any point end property value)))
1421     (if start
1422         (remove-text-properties start end properties object))
1423     t))
1424
1425 (defun gnus-string-remove-all-properties (string)
1426   (condition-case ()
1427       (let ((s string))
1428         (set-text-properties 0 (length string) nil string)
1429         s)
1430     (error string)))
1431
1432 ;; This might use `compare-strings' to reduce consing in the
1433 ;; case-insensitive case, but it has to cope with null args.
1434 ;; (`string-equal' uses symbol print names.)
1435 (defun gnus-string-equal (x y)
1436   "Like `string-equal', except it compares case-insensitively."
1437   (and (= (length x) (length y))
1438        (or (string-equal x y)
1439            (string-equal (downcase x) (downcase y)))))
1440
1441 (defcustom gnus-use-byte-compile t
1442   "If non-nil, byte-compile crucial run-time code.
1443 Setting it to nil has no effect after the first time `gnus-byte-compile'
1444 is run."
1445   :type 'boolean
1446   :version "22.1"
1447   :group 'gnus-various)
1448
1449 (defun gnus-byte-compile (form)
1450   "Byte-compile FORM if `gnus-use-byte-compile' is non-nil."
1451   (if gnus-use-byte-compile
1452       (progn
1453         (condition-case nil
1454             ;; Work around a bug in XEmacs 21.4
1455             (require 'byte-optimize)
1456           (error))
1457         (require 'bytecomp)
1458         (defalias 'gnus-byte-compile
1459           (lambda (form)
1460             (let ((byte-compile-warnings '(unresolved callargs redefine)))
1461               (byte-compile form))))
1462         (gnus-byte-compile form))
1463     form))
1464
1465 (defun gnus-remassoc (key alist)
1466   "Delete by side effect any elements of LIST whose car is `equal' to KEY.
1467 The modified LIST is returned.  If the first member
1468 of LIST has a car that is `equal' to KEY, there is no way to remove it
1469 by side effect; therefore, write `(setq foo (gnus-remassoc key foo))' to be
1470 sure of changing the value of `foo'."
1471   (when alist
1472     (if (equal key (caar alist))
1473         (cdr alist)
1474       (setcdr alist (gnus-remassoc key (cdr alist)))
1475       alist)))
1476
1477 (defun gnus-update-alist-soft (key value alist)
1478   (if value
1479       (cons (cons key value) (gnus-remassoc key alist))
1480     (gnus-remassoc key alist)))
1481
1482 (defun gnus-create-info-command (node)
1483   "Create a command that will go to info NODE."
1484   `(lambda ()
1485      (interactive)
1486      ,(concat "Enter the info system at node " node)
1487      (Info-goto-node ,node)
1488      (setq gnus-info-buffer (current-buffer))
1489      (gnus-configure-windows 'info)))
1490
1491 (defun gnus-not-ignore (&rest args)
1492   t)
1493
1494 (defvar gnus-directory-sep-char-regexp "/"
1495   "The regexp of directory separator character.
1496 If you find some problem with the directory separator character, try
1497 \"[/\\\\\]\" for some systems.")
1498
1499 (defun gnus-url-unhex (x)
1500   (if (> x ?9)
1501       (if (>= x ?a)
1502           (+ 10 (- x ?a))
1503         (+ 10 (- x ?A)))
1504     (- x ?0)))
1505
1506 ;; Fixme: Do it like QP.
1507 (defun gnus-url-unhex-string (str &optional allow-newlines)
1508   "Remove %XX, embedded spaces, etc in a url.
1509 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
1510 decoding of carriage returns and line feeds in the string, which is normally
1511 forbidden in URL encoding."
1512   (let ((tmp "")
1513         (case-fold-search t))
1514     (while (string-match "%[0-9a-f][0-9a-f]" str)
1515       (let* ((start (match-beginning 0))
1516              (ch1 (gnus-url-unhex (elt str (+ start 1))))
1517              (code (+ (* 16 ch1)
1518                       (gnus-url-unhex (elt str (+ start 2))))))
1519         (setq tmp (concat
1520                    tmp (substring str 0 start)
1521                    (cond
1522                     (allow-newlines
1523                      (char-to-string code))
1524                     ((or (= code ?\n) (= code ?\r))
1525                      " ")
1526                     (t (char-to-string code))))
1527               str (substring str (match-end 0)))))
1528     (setq tmp (concat tmp str))
1529     tmp))
1530
1531 (defun gnus-make-predicate (spec)
1532   "Transform SPEC into a function that can be called.
1533 SPEC is a predicate specifier that contains stuff like `or', `and',
1534 `not', lists and functions.  The functions all take one parameter."
1535   `(lambda (elem) ,(gnus-make-predicate-1 spec)))
1536
1537 (defun gnus-make-predicate-1 (spec)
1538   (cond
1539    ((symbolp spec)
1540     `(,spec elem))
1541    ((listp spec)
1542     (if (memq (car spec) '(or and not))
1543         `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec)))
1544       (error "Invalid predicate specifier: %s" spec)))))
1545
1546 (defun gnus-completing-read (prompt collection &optional require-match
1547                                     initial-input history def)
1548   "Call `gnus-completing-read-function'."
1549   (funcall gnus-completing-read-function
1550            (concat prompt (when def
1551                             (concat " (default " def ")"))
1552                    ": ")
1553            collection require-match initial-input history def))
1554
1555 (defun gnus-emacs-completing-read (prompt collection &optional require-match
1556                                           initial-input history def)
1557   "Call standard `completing-read-function'."
1558   (let ((completion-styles gnus-completion-styles))
1559     (completing-read prompt
1560                      (if (featurep 'xemacs)
1561                          ;; Old XEmacs (at least 21.4) expect an alist,
1562                          ;; in which the car of each element is a string,
1563                          ;; for collection.
1564                          (mapcar
1565                           (lambda (elem)
1566                             (list (format "%s" (or (car-safe elem) elem))))
1567                           collection)
1568                        collection)
1569                      nil require-match initial-input history def)))
1570
1571 (autoload 'ido-completing-read "ido")
1572 (defun gnus-ido-completing-read (prompt collection &optional require-match
1573                                         initial-input history def)
1574   "Call `ido-completing-read-function'."
1575   (ido-completing-read prompt collection nil require-match
1576                        initial-input history def))
1577
1578
1579 (declare-function iswitchb-read-buffer "iswitchb"
1580                   (prompt &optional default require-match start matches-set))
1581 (defvar iswitchb-temp-buflist)
1582
1583 (defun gnus-iswitchb-completing-read (prompt collection &optional require-match
1584                                             initial-input history def)
1585   "`iswitchb' based completing-read function."
1586   ;; Make sure iswitchb is loaded before we let-bind its variables.
1587   ;; If it is loaded inside the let, variables can become unbound afterwards.
1588   (require 'iswitchb)
1589   (let ((iswitchb-make-buflist-hook
1590          (lambda ()
1591            (setq iswitchb-temp-buflist
1592                  (let ((choices (append
1593                                  (when initial-input (list initial-input))
1594                                  (symbol-value history) collection))
1595                        filtered-choices)
1596                    (dolist (x choices)
1597                      (setq filtered-choices (adjoin x filtered-choices)))
1598                    (nreverse filtered-choices))))))
1599     (unwind-protect
1600         (progn
1601           (or iswitchb-mode
1602               (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
1603           (iswitchb-read-buffer prompt def require-match))
1604       (or iswitchb-mode
1605           (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)))))
1606
1607 (defun gnus-graphic-display-p ()
1608   (if (featurep 'xemacs)
1609       (device-on-window-system-p)
1610     (display-graphic-p)))
1611
1612 (put 'gnus-parse-without-error 'lisp-indent-function 0)
1613 (put 'gnus-parse-without-error 'edebug-form-spec '(body))
1614
1615 (defmacro gnus-parse-without-error (&rest body)
1616   "Allow continuing onto the next line even if an error occurs."
1617   `(while (not (eobp))
1618      (condition-case ()
1619          (progn
1620            ,@body
1621            (goto-char (point-max)))
1622        (error
1623         (gnus-error 4 "Invalid data on line %d"
1624                     (count-lines (point-min) (point)))
1625         (forward-line 1)))))
1626
1627 (defun gnus-cache-file-contents (file variable function)
1628   "Cache the contents of FILE in VARIABLE.  The contents come from FUNCTION."
1629   (let ((time (nth 5 (file-attributes file)))
1630         contents value)
1631     (if (or (null (setq value (symbol-value variable)))
1632             (not (equal (car value) file))
1633             (not (equal (nth 1 value) time)))
1634         (progn
1635           (setq contents (funcall function file))
1636           (set variable (list file time contents))
1637           contents)
1638       (nth 2 value))))
1639
1640 (defun gnus-multiple-choice (prompt choice &optional idx)
1641   "Ask user a multiple choice question.
1642 CHOICE is a list of the choice char and help message at IDX."
1643   (let (tchar buf)
1644     (save-window-excursion
1645       (save-excursion
1646         (while (not tchar)
1647           (message "%s (%s): "
1648                    prompt
1649                    (concat
1650                     (mapconcat (lambda (s) (char-to-string (car s)))
1651                                choice ", ") ", ?"))
1652           (setq tchar (read-char))
1653           (when (not (assq tchar choice))
1654             (setq tchar nil)
1655             (setq buf (get-buffer-create "*Gnus Help*"))
1656             (pop-to-buffer buf)
1657             (fundamental-mode)          ; for Emacs 20.4+
1658             (buffer-disable-undo)
1659             (erase-buffer)
1660             (insert prompt ":\n\n")
1661             (let ((max -1)
1662                   (list choice)
1663                   (alist choice)
1664                   (idx (or idx 1))
1665                   (i 0)
1666                   n width pad format)
1667               ;; find the longest string to display
1668               (while list
1669                 (setq n (length (nth idx (car list))))
1670                 (unless (> max n)
1671                   (setq max n))
1672                 (setq list (cdr list)))
1673               (setq max (+ max 4))      ; %c, `:', SPACE, a SPACE at end
1674               (setq n (/ (1- (window-width)) max)) ; items per line
1675               (setq width (/ (1- (window-width)) n)) ; width of each item
1676               ;; insert `n' items, each in a field of width `width'
1677               (while alist
1678                 (if (< i n)
1679                     ()
1680                   (setq i 0)
1681                   (delete-char -1)              ; the `\n' takes a char
1682                   (insert "\n"))
1683                 (setq pad (- width 3))
1684                 (setq format (concat "%c: %-" (int-to-string pad) "s"))
1685                 (insert (format format (caar alist) (nth idx (car alist))))
1686                 (setq alist (cdr alist))
1687                 (setq i (1+ i))))))))
1688     (if (buffer-live-p buf)
1689         (kill-buffer buf))
1690     tchar))
1691
1692 (if (featurep 'emacs)
1693     (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus)
1694   (if (fboundp 'select-frame-set-input-focus)
1695       (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus)
1696     ;; XEmacs 21.4, SXEmacs
1697     (defun gnus-select-frame-set-input-focus (frame)
1698       "Select FRAME, raise it, and set input focus, if possible."
1699       (raise-frame frame)
1700       (select-frame frame)
1701       (focus-frame frame))))
1702
1703 (defun gnus-frame-or-window-display-name (object)
1704   "Given a frame or window, return the associated display name.
1705 Return nil otherwise."
1706   (if (featurep 'xemacs)
1707       (device-connection (dfw-device object))
1708     (if (or (framep object)
1709             (and (windowp object)
1710                  (setq object (window-frame object))))
1711         (let ((display (frame-parameter object 'display)))
1712           (if (and (stringp display)
1713                    ;; Exclude invalid display names.
1714                    (string-match "\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'"
1715                                  display))
1716               display)))))
1717
1718 (defvar tool-bar-mode)
1719
1720 (defun gnus-tool-bar-update (&rest ignore)
1721   "Update the tool bar."
1722   (when (and (boundp 'tool-bar-mode)
1723              tool-bar-mode)
1724     (let* ((args nil)
1725            (func (cond ((featurep 'xemacs)
1726                         'ignore)
1727                        ((fboundp 'tool-bar-update)
1728                         'tool-bar-update)
1729                        ((fboundp 'force-window-update)
1730                         'force-window-update)
1731                        ((fboundp 'redraw-frame)
1732                         (setq args (list (selected-frame)))
1733                         'redraw-frame)
1734                        (t 'ignore))))
1735       (apply func args))))
1736
1737 ;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile.
1738 (defmacro gnus-mapcar (function seq1 &rest seqs2_n)
1739   "Apply FUNCTION to each element of the sequences, and make a list of the results.
1740 If there are several sequences, FUNCTION is called with that many arguments,
1741 and mapping stops as soon as the shortest sequence runs out.  With just one
1742 sequence, this is like `mapcar'.  With several, it is like the Common Lisp
1743 `mapcar' function extended to arbitrary sequence types."
1744
1745   (if seqs2_n
1746       (let* ((seqs (cons seq1 seqs2_n))
1747              (cnt 0)
1748              (heads (mapcar (lambda (seq)
1749                               (make-symbol (concat "head"
1750                                                    (int-to-string
1751                                                     (setq cnt (1+ cnt))))))
1752                             seqs))
1753              (result (make-symbol "result"))
1754              (result-tail (make-symbol "result-tail")))
1755         `(let* ,(let* ((bindings (cons nil nil))
1756                        (heads heads))
1757                   (nconc bindings (list (list result '(cons nil nil))))
1758                   (nconc bindings (list (list result-tail result)))
1759                   (while heads
1760                     (nconc bindings (list (list (pop heads) (pop seqs)))))
1761                   (cdr bindings))
1762            (while (and ,@heads)
1763              (setcdr ,result-tail (cons (funcall ,function
1764                                                  ,@(mapcar (lambda (h) (list 'car h))
1765                                                            heads))
1766                                         nil))
1767              (setq ,result-tail (cdr ,result-tail)
1768                    ,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads))))
1769            (cdr ,result)))
1770     `(mapcar ,function ,seq1)))
1771
1772 (if (fboundp 'merge)
1773     (defalias 'gnus-merge 'merge)
1774   ;; Adapted from cl-seq.el
1775   (defun gnus-merge (type list1 list2 pred)
1776     "Destructively merge lists LIST1 and LIST2 to produce a new list.
1777 Argument TYPE is for compatibility and ignored.
1778 Ordering of the elements is preserved according to PRED, a `less-than'
1779 predicate on the elements."
1780     (let ((res nil))
1781       (while (and list1 list2)
1782         (if (funcall pred (car list2) (car list1))
1783             (push (pop list2) res)
1784           (push (pop list1) res)))
1785       (nconc (nreverse res) list1 list2))))
1786
1787 (defvar xemacs-codename)
1788 (defvar sxemacs-codename)
1789 (defvar emacs-program-version)
1790
1791 (defun gnus-emacs-version ()
1792   "Stringified Emacs version."
1793   (let* ((lst (if (listp gnus-user-agent)
1794                   gnus-user-agent
1795                 '(gnus emacs type)))
1796          (system-v (cond ((memq 'config lst)
1797                           system-configuration)
1798                          ((memq 'type lst)
1799                           (symbol-name system-type))
1800                          (t nil)))
1801          codename emacsname)
1802     (cond ((featurep 'sxemacs)
1803            (setq emacsname "SXEmacs"
1804                  codename sxemacs-codename))
1805           ((featurep 'xemacs)
1806            (setq emacsname "XEmacs"
1807                  codename xemacs-codename))
1808           (t
1809            (setq emacsname "Emacs")))
1810     (cond
1811      ((not (memq 'emacs lst))
1812       nil)
1813      ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
1814       ;; Emacs:
1815       (concat "Emacs/" (match-string 1 emacs-version)
1816               (if system-v
1817                   (concat " (" system-v ")")
1818                 "")))
1819      ((or (featurep 'sxemacs) (featurep 'xemacs))
1820       ;; XEmacs or SXEmacs:
1821       (concat emacsname "/" emacs-program-version
1822               (let (plst)
1823                 (when (memq 'codename lst)
1824                   (push codename plst))
1825                 (when system-v
1826                   (push system-v plst))
1827                 (unless (featurep 'mule)
1828                   (push "no MULE" plst))
1829                 (when (> (length plst) 0)
1830                   (concat
1831                    " (" (mapconcat 'identity (reverse plst) ", ") ")")))))
1832      (t emacs-version))))
1833
1834 (defun gnus-rename-file (old-path new-path &optional trim)
1835   "Rename OLD-PATH as NEW-PATH.  If TRIM, recursively delete
1836 empty directories from OLD-PATH."
1837   (when (file-exists-p old-path)
1838     (let* ((old-dir (file-name-directory old-path))
1839            (old-name (file-name-nondirectory old-path))
1840            (new-dir (file-name-directory new-path))
1841            (new-name (file-name-nondirectory new-path))
1842            temp)
1843       (gnus-make-directory new-dir)
1844       (rename-file old-path new-path t)
1845       (when trim
1846         (while (progn (setq temp (directory-files old-dir))
1847                       (while (member (car temp) '("." ".."))
1848                         (setq temp (cdr temp)))
1849                       (= (length temp) 0))
1850           (delete-directory old-dir)
1851           (setq old-dir (file-name-as-directory
1852                          (file-truename
1853                           (concat old-dir "..")))))))))
1854
1855 (defun gnus-set-file-modes (filename mode)
1856   "Wrapper for set-file-modes."
1857   (ignore-errors
1858     (set-file-modes filename mode)))
1859
1860 (if (fboundp 'set-process-query-on-exit-flag)
1861     (defalias 'gnus-set-process-query-on-exit-flag
1862       'set-process-query-on-exit-flag)
1863   (defalias 'gnus-set-process-query-on-exit-flag
1864     'process-kill-without-query))
1865
1866 (defalias 'gnus-read-shell-command
1867   (if (fboundp 'read-shell-command) 'read-shell-command 'read-string))
1868
1869 (defmacro gnus-put-display-table (range value display-table)
1870   "Set the value for char RANGE to VALUE in DISPLAY-TABLE.  "
1871   (if (featurep 'xemacs)
1872       (progn
1873         `(if (fboundp 'put-display-table)
1874           (put-display-table ,range ,value ,display-table)
1875           (if (sequencep ,display-table)
1876               (aset ,display-table ,range ,value)
1877             (put-char-table ,range ,value ,display-table))))
1878     `(aset ,display-table ,range ,value)))
1879
1880 (defmacro gnus-get-display-table (character display-table)
1881   "Find value for CHARACTER in DISPLAY-TABLE.  "
1882   (if (featurep 'xemacs)
1883       `(if (fboundp 'get-display-table)
1884           (get-display-table ,character ,display-table)
1885           (if (sequencep ,display-table)
1886               (aref ,display-table ,character)
1887             (get-char-table ,character ,display-table)))
1888     `(aref ,display-table ,character)))
1889
1890 (declare-function image-size "image.c" (spec &optional pixels frame))
1891
1892 (defun gnus-rescale-image (image size)
1893   "Rescale IMAGE to SIZE if possible.
1894 SIZE is in format (WIDTH . HEIGHT). Return a new image.
1895 Sizes are in pixels."
1896   (if (or (not (fboundp 'imagemagick-types))
1897           (not (get-buffer-window (current-buffer))))
1898       image
1899     (let ((new-width (car size))
1900           (new-height (cdr size)))
1901       (when (> (cdr (image-size image t)) new-height)
1902         (setq image (or (create-image (plist-get (cdr image) :data) 'imagemagick t
1903                                       :height new-height)
1904                         image)))
1905       (when (> (car (image-size image t)) new-width)
1906         (setq image (or
1907                    (create-image (plist-get (cdr image) :data) 'imagemagick t
1908                                  :width new-width)
1909                    image)))
1910       image)))
1911
1912 (eval-when-compile (require 'gmm-utils))
1913 (defun gnus-recursive-directory-files (dir)
1914   "Return all regular files below DIR.
1915 The first found will be returned if a file has hard or symbolic links."
1916   (let (files attr attrs)
1917     (gmm-labels
1918         ((fn (directory)
1919              (dolist (file (directory-files directory t))
1920                (setq attr (file-attributes (file-truename file)))
1921                (when (and (not (member attr attrs))
1922                           (not (member (file-name-nondirectory file)
1923                                        '("." "..")))
1924                           (file-readable-p file))
1925                  (push attr attrs)
1926                  (cond ((file-regular-p file)
1927                         (push file files))
1928                        ((file-directory-p file)
1929                         (fn file)))))))
1930       (fn dir))
1931     files))
1932
1933 (defun gnus-list-memq-of-list (elements list)
1934   "Return non-nil if any of the members of ELEMENTS are in LIST."
1935   (let ((found nil))
1936     (dolist (elem elements)
1937       (setq found (or found
1938                       (memq elem list))))
1939     found))
1940
1941 (eval-and-compile
1942   (cond
1943    ((fboundp 'match-substitute-replacement)
1944     (defalias 'gnus-match-substitute-replacement 'match-substitute-replacement))
1945    (t
1946     (defun gnus-match-substitute-replacement (replacement &optional fixedcase literal string subexp)
1947       "Return REPLACEMENT as it will be inserted by `replace-match'.
1948 In other words, all back-references in the form `\\&' and `\\N'
1949 are substituted with actual strings matched by the last search.
1950 Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same
1951 meaning as for `replace-match'.
1952
1953 This is the definition of match-substitute-replacement in subr.el from GNU Emacs."
1954       (let ((match (match-string 0 string)))
1955         (save-match-data
1956           (set-match-data (mapcar (lambda (x)
1957                                     (if (numberp x)
1958                                         (- x (match-beginning 0))
1959                                       x))
1960                                   (match-data t)))
1961           (replace-match replacement fixedcase literal match subexp)))))))
1962
1963 (if (fboundp 'string-match-p)
1964     (defalias 'gnus-string-match-p 'string-match-p)
1965   (defsubst gnus-string-match-p (regexp string &optional start)
1966     "\
1967 Same as `string-match' except this function does not change the match data."
1968     (save-match-data
1969       (string-match regexp string start))))
1970
1971 (if (fboundp 'string-prefix-p)
1972     (defalias 'gnus-string-prefix-p 'string-prefix-p)
1973   (defun gnus-string-prefix-p (str1 str2 &optional ignore-case)
1974     "Return non-nil if STR1 is a prefix of STR2.
1975 If IGNORE-CASE is non-nil, the comparison is done without paying attention
1976 to case differences."
1977     (and (<= (length str1) (length str2))
1978          (let ((prefix (substring str2 0 (length str1))))
1979            (if ignore-case
1980                (string-equal (downcase str1) (downcase prefix))
1981              (string-equal str1 prefix))))))
1982
1983 ;; Simple check: can be a macro but this way, although slow, it's really clear.
1984 ;; We don't use `bound-and-true-p' because it's not in XEmacs.
1985 (defun gnus-bound-and-true-p (sym)
1986   (and (boundp sym) (symbol-value sym)))
1987
1988 (if (fboundp 'timer--function)
1989     (defalias 'gnus-timer--function 'timer--function)
1990   (defun gnus-timer--function (timer)
1991     (elt timer 5)))
1992
1993 (provide 'gnus-