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

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