X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=fef67cd52e9b5e255b41e3faca99e04c05767dc6;hp=f5679ee850fc87c48943d9ab084d4a862dd3fde7;hb=cf1cc15caa87116a3869bbfaea7cd0b02a8250e2;hpb=a492e6b6cf2c4846d91731bc9cb878725291a9e1 diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index f5679ee85..fef67cd52 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,7 +1,6 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +;; Copyright (C) 1996-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -33,16 +32,43 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) -(eval-when-compile - (unless (fboundp 'with-no-warnings) - (defmacro with-no-warnings (&rest body) - `(progn ,@body)))) +(require 'time-date) + +(defcustom gnus-completing-read-function 'gnus-emacs-completing-read + "Function use to do completing read." + :version "24.1" + :group 'gnus-meta + :type `(radio (function-item + :doc "Use Emacs standard `completing-read' function." + gnus-emacs-completing-read) + ;; iswitchb.el is very old and ido.el is unavailable + ;; in XEmacs, so we exclude those function items. + ,@(unless (featurep 'xemacs) + '((function-item + :doc "Use `ido-completing-read' function." + gnus-ido-completing-read) + (function-item + :doc "Use iswitchb based completing-read function." + gnus-iswitchb-completing-read))))) + +(defcustom gnus-completion-styles + (if (and (boundp 'completion-styles-alist) + (boundp 'completion-styles)) + (append (when (and (assq 'substring completion-styles-alist) + (not (memq 'substring completion-styles))) + (list 'substring)) + completion-styles) + nil) + "Value of `completion-styles' to use when completing." + :version "24.1" + :group 'gnus-meta + :type 'list) ;; Fixme: this should be a gnus variable, not nnmail-. (defvar nnmail-pathname-coding-system) @@ -53,10 +79,6 @@ (defvar gnus-original-article-buffer) (defvar gnus-user-agent) -(require 'time-date) -(require 'netrc) - -(autoload 'message-fetch-field "message") (autoload 'gnus-get-buffer-window "gnus-win") (autoload 'nnheader-narrow-to-headers "nnheader") (autoload 'nnheader-replace-chars-in-string "nnheader") @@ -126,11 +148,9 @@ This is a compatibility function for different Emacsen." ;; XEmacs. In Emacs we don't need to call `make-local-hook' first. ;; It's harmless, though, so the main purpose of this alias is to shut ;; up the byte compiler. -(defalias 'gnus-make-local-hook - (if (eq (get 'make-local-hook 'byte-compile) - 'byte-compile-obsolete) - 'ignore ; Emacs - 'make-local-hook)) ; XEmacs +(defalias 'gnus-make-local-hook (if (featurep 'xemacs) + 'make-local-hook + 'ignore)) (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -206,8 +226,11 @@ Uses `gnus-extract-address-components'." Uses `gnus-extract-address-components'." (nth 1 (gnus-extract-address-components from))) +(declare-function message-fetch-field "message" (header &optional not-all)) + (defun gnus-fetch-field (field) "Return the value of the header FIELD of current article." + (require 'message) (save-excursion (save-restriction (let ((inhibit-point-motion-hooks t)) @@ -228,13 +251,14 @@ Uses `gnus-extract-address-components'." (point))))) (declare-function gnus-find-method-for-group "gnus" (group &optional info)) -(autoload 'gnus-group-name-decode "gnus-group") +(declare-function gnus-group-name-decode "gnus-group" (string charset)) (declare-function gnus-group-name-charset "gnus-group" (method group)) ;; gnus-group requires gnus-int which requires message. (declare-function message-tokenize-header "message" (header &optional separator)) (defun gnus-decode-newsgroups (newsgroups group &optional method) + (require 'gnus-group) (let ((method (or method (gnus-find-method-for-group group)))) (mapconcat (lambda (group) (gnus-group-name-decode group (gnus-group-name-charset @@ -254,6 +278,24 @@ Uses `gnus-extract-address-components'." (setq start (when end (next-single-property-change start prop)))))) +(defun gnus-find-text-property-region (start end prop) + "Return a list of text property regions that has property PROP." + (let (regions value) + (unless (get-text-property start prop) + (setq start (next-single-property-change start prop))) + (while start + (setq value (get-text-property start prop) + end (text-property-not-all start (point-max) prop value)) + (if (not end) + (setq start nil) + (when value + (push (list (set-marker (make-marker) start) + (set-marker (make-marker) end) + value) + regions)) + (setq start (next-single-property-change start prop)))) + (nreverse regions))) + (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) @@ -291,14 +333,16 @@ Symbols are also allowed; their print names are used instead." (and (= (car fdate) (car date)) (> (nth 1 fdate) (nth 1 date)))))) +;; Every version of Emacs Gnus supports has built-in float-time. +;; The featurep test silences an irritating compiler warning. (eval-and-compile - (if (and (fboundp 'float-time) - (subrp (symbol-function 'float-time))) + (if (or (featurep 'emacs) + (fboundp 'float-time)) (defalias 'gnus-float-time 'float-time) (defun gnus-float-time (&optional time) "Convert time value TIME to a floating point number. TIME defaults to the current time." - (with-no-warnings (time-to-seconds (or time (current-time))))))) + (time-to-seconds (or time (current-time)))))) ;;; Keymap macros. @@ -344,67 +388,14 @@ TIME defaults to the current time." (define-key keymap key (pop plist)) (pop plist))))) -(defun gnus-completing-read-with-default (default prompt &rest args) - ;; Like `completing-read', except that DEFAULT is the default argument. - (let* ((prompt (if default - (concat prompt " (default " default "): ") - (concat prompt ": "))) - (answer (apply 'completing-read prompt args))) - (if (or (null answer) (zerop (length answer))) - default - answer))) - -;; Two silly functions to ensure that all `y-or-n-p' questions clear -;; the echo area. -;; -;; Do we really need these functions? Workarounds for bugs in the corresponding -;; Emacs functions? Maybe these bugs are no longer present in any supported -;; (X)Emacs version? Alias them to the original functions and see if anyone -;; reports a problem. If not, replace with original functions. --rsteib, -;; 2007-12-14 -;; -;; All supported Emacsen clear the echo area after `yes-or-no-p', so we can -;; remove `yes-or-no-p'. RMS says that not clearing after `y-or-n-p' is -;; intentional (see below), so we could remove `gnus-y-or-n-p' too. -;; Objections? --rsteib, 2008-02-16 -;; -;; ,----[ http://thread.gmane.org/gmane.emacs.gnus.general/65099/focus=66070 ] -;; | From: Richard Stallman -;; | Subject: Re: Do we need gnus-yes-or-no-p and gnus-y-or-n-p? -;; | To: Katsumi Yamaoka [...] -;; | Cc: emacs-devel@[...], xemacs-beta@[...], ding@[...] -;; | Date: Mon, 07 Jan 2008 12:16:05 -0500 -;; | Message-ID: -;; | -;; | The behavior of `y-or-n-p' that it doesn't clear the question -;; | and the answer is not serious of course, but I feel it is not -;; | cool. -;; | -;; | It is intentional. -;; | -;; | Currently, it is commented out in the trunk by Reiner Steib. He -;; | also wrote the benefit of leaving the question and the answer in -;; | the echo area as follows: -;; | -;; | (http://article.gmane.org/gmane.emacs.gnus.general/66061) -;; | > In contrast to yes-or-no-p it is much easier to type y, n, -;; | > SPC, DEL, etc accidentally, so it might be useful for the user -;; | > to see what he has typed. -;; | -;; | Yes, that is the reason. -;; `---- - -;; (defun gnus-y-or-n-p (prompt) -;; (prog1 -;; (y-or-n-p prompt) -;; (message ""))) -;; (defun gnus-yes-or-no-p (prompt) -;; (prog1 -;; (yes-or-no-p prompt) -;; (message ""))) - -(defalias 'gnus-y-or-n-p 'y-or-n-p) -(defalias 'gnus-yes-or-no-p 'yes-or-no-p) +(defun gnus-y-or-n-p (prompt) + (prog1 + (y-or-n-p prompt) + (message ""))) +(defun gnus-yes-or-no-p (prompt) + (prog1 + (yes-or-no-p prompt) + (message ""))) ;; By Frank Schmitt . Allows to have ;; age-depending date representations. (e.g. just the time if it's @@ -429,57 +420,6 @@ TIME defaults to the current time." (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) (* (- (string-to-number days) 1) 3600 24)))) -(defvar gnus-user-date-format-alist - '(((gnus-seconds-today) . "%k:%M") - (604800 . "%a %k:%M") ;;that's one week - ((gnus-seconds-month) . "%a %d") - ((gnus-seconds-year) . "%b %d") - (t . "%b %d '%y")) ;;this one is used when no - ;;other does match - "Specifies date format depending on age of article. -This is an alist of items (AGE . FORMAT). AGE can be a number (of -seconds) or a Lisp expression evaluating to a number. When the age of -the article is less than this number, then use `format-time-string' -with the corresponding FORMAT for displaying the date of the article. -If AGE is not a number or a Lisp expression evaluating to a -non-number, then the corresponding FORMAT is used as a default value. - -Note that the list is processed from the beginning, so it should be -sorted by ascending AGE. Also note that items following the first -non-number AGE will be ignored. - -You can use the functions `gnus-seconds-today', `gnus-seconds-month' -and `gnus-seconds-year' in the AGE spec. They return the number of -seconds passed since the start of today, of this month, of this year, -respectively.") - -(defun gnus-user-date (messy-date) - "Format the messy-date according to gnus-user-date-format-alist. -Returns \" ? \" if there's bad input or if an other error occurs. -Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." - (condition-case () - (let* ((messy-date (gnus-float-time (safe-date-to-time messy-date))) - (now (gnus-float-time)) - ;;If we don't find something suitable we'll use this one - (my-format "%b %d '%y")) - (let* ((difference (- now messy-date)) - (templist gnus-user-date-format-alist) - (top (eval (caar templist)))) - (while (if (numberp top) (< top difference) (not top)) - (progn - (setq templist (cdr templist)) - (setq top (eval (caar templist))))) - (if (stringp (cdr (car templist))) - (setq my-format (cdr (car templist))))) - (format-time-string (eval my-format) (seconds-to-time messy-date))) - (error " ? "))) - -(defun gnus-dd-mmm (messy-date) - "Return a string like DD-MMM from a big messy string." - (condition-case () - (format-time-string "%d-%b" (safe-date-to-time messy-date)) - (error " - "))) - (defmacro gnus-date-get-time (date) "Convert DATE string to Emacs time. Cache the result as a text property stored in DATE." @@ -494,6 +434,12 @@ Cache the result as a text property stored in DATE." (put-text-property 0 1 'gnus-time time d) time))))) +(defun gnus-dd-mmm (messy-date) + "Return a string like DD-MMM from a big messy string." + (condition-case () + (format-time-string "%d-%b" (gnus-date-get-time messy-date)) + (error " - "))) + (defsubst gnus-time-iso8601 (time) "Return a string of TIME in YYYYMMDDTHHMMSS format." (format-time-string "%Y%m%dT%H%M%S" time)) @@ -525,12 +471,13 @@ Cache the result as a text property stored in DATE." (setq i (* 2 i))) i)) -(defcustom gnus-verbose 7 +(defcustom gnus-verbose 6 "*Integer that says how verbose Gnus should be. The higher the number, the more messages Gnus will flash to say what it's doing. At zero, Gnus will be totally mute; at five, Gnus will display most important messages; and at ten, Gnus will keep on jabbering all the time." + :version "24.1" :group 'gnus-start :type 'integer) @@ -551,8 +498,7 @@ but also to the ones displayed in the echo area." (eval-when-compile (defmacro gnus-message-with-timestamp-1 (format-string args) - (let ((timestamp '((format-time-string "%Y%m%dT%H%M%S" time) - "." (format "%03d" (/ (nth 2 time) 1000)) "> "))) + (let ((timestamp '(format-time-string "%Y%m%dT%H%M%S.%3N> " time))) (if (featurep 'xemacs) `(let (str time) (if (or (and (null ,format-string) (null ,args)) @@ -565,10 +511,10 @@ but also to the ones displayed in the echo area." (cond ((eq gnus-add-timestamp-to-message 'log) (setq time (current-time)) (display-message 'no-log str) - (log-message 'message (concat ,@timestamp str))) + (log-message 'message (concat ,timestamp str))) (gnus-add-timestamp-to-message (setq time (current-time)) - (display-message 'message (concat ,@timestamp str))) + (display-message 'message (concat ,timestamp str))) (t (display-message 'message str)))) str) @@ -582,7 +528,7 @@ but also to the ones displayed in the echo area." (setq time (current-time)) (with-current-buffer (get-buffer-create "*Messages*") (goto-char (point-max)) - (insert ,@timestamp str "\n") + (insert ,timestamp str "\n") (forward-line (- message-log-max)) (delete-region (point-min) (point)) (goto-char (point-max)))) @@ -596,11 +542,13 @@ but also to the ones displayed in the echo area." (and ,format-string str) (message nil)) (setq time (current-time)) - (message "%s" (concat ,@timestamp str)) + (message "%s" (concat ,timestamp str)) str)) (t (apply 'message ,format-string ,args)))))))) +(defvar gnus-action-message-log nil) + (defun gnus-message-with-timestamp (format-string &rest args) "Display message with timestamp. Arguments are the same as `message'. The `gnus-add-timestamp-to-message' variable controls how to add @@ -615,14 +563,26 @@ Guideline for numbers: that take a long time, 7 - not very important messages on stuff, 9 - messages inside loops." (if (<= level gnus-verbose) - (if gnus-add-timestamp-to-message - (apply 'gnus-message-with-timestamp args) - (apply 'message args)) + (let ((message + (if gnus-add-timestamp-to-message + (apply 'gnus-message-with-timestamp args) + (apply 'message args)))) + (when (and (consp gnus-action-message-log) + (<= level 3)) + (push message gnus-action-message-log)) + message) ;; We have to do this format thingy here even if the result isn't ;; shown - the return value has to be the same as the return value ;; from `message'. (apply 'format args))) +(defun gnus-final-warning () + (when (and (consp gnus-action-message-log) + (setq gnus-action-message-log + (delete nil gnus-action-message-log))) + (message "Warning: %s" + (mapconcat #'identity gnus-action-message-log "; ")))) + (defun gnus-error (level &rest args) "Beep an error if LEVEL is equal to or less than `gnus-verbose'. ARGS are passed to `message'." @@ -669,11 +629,9 @@ If N, return the Nth ancestor instead." (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) (match-string 1 references)))))) -(defun gnus-buffer-live-p (buffer) +(defsubst gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." - (and buffer - (get-buffer buffer) - (buffer-name (get-buffer buffer)))) + (and buffer (buffer-live-p (get-buffer buffer)))) (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." @@ -856,6 +814,7 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (defun gnus-write-buffer (file) "Write the current buffer's contents to FILE." + (require 'nnmail) (let ((file-name-coding-system nnmail-pathname-coding-system)) ;; Make sure the directory exists. (gnus-make-directory (file-name-directory file)) @@ -867,6 +826,15 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (when (file-exists-p file) (delete-file file))) +(defun gnus-delete-duplicates (list) + "Remove duplicate entries from LIST." + (let ((result nil)) + (while list + (unless (member (car list) result) + (push (car list) result)) + (pop list)) + (nreverse result))) + (defun gnus-delete-directory (directory) "Delete files in DIRECTORY. Subdirectories remain. If there's no subdirectory, delete DIRECTORY as well." @@ -1070,23 +1038,15 @@ with potentially long computations." ;;; Functions for saving to babyl/mail files. (eval-when-compile - (condition-case nil - (progn - (require 'rmail) - (autoload 'rmail-update-summary "rmailsum")) - (error - (define-compiler-macro rmail-select-summary (&rest body) - ;; Rmail of the XEmacs version is supplied by the package, and - ;; requires tm and apel packages. However, there may be those - ;; who haven't installed those packages. This macro helps such - ;; people even if they install those packages later. - `(eval '(rmail-select-summary ,@body))) - ;; If there's rmail but there's no tm (or there's apel of the - ;; mainstream, not the XEmacs version), loading rmail of the XEmacs - ;; version fails halfway, however it provides the rmail-select-summary - ;; macro which uses the following functions: - (autoload 'rmail-summary-displayed "rmail") - (autoload 'rmail-maybe-display-summary "rmail")))) + (if (featurep 'xemacs) + ;; Don't load tm and apel XEmacs packages that provide some + ;; Emacs emulating functions and variables. + (let ((features features)) + (provide 'tm-view) + (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore)) + (require 'rmail)) ;; It requires tm-view that loads apel. + (require 'rmail)) + (autoload 'rmail-update-summary "rmailsum")) (defvar mm-text-coding-system) @@ -1099,6 +1059,7 @@ In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless FILENAME exists and is Babyl format." (require 'rmail) (require 'mm-util) + (require 'nnmail) ;; Some of this codes is borrowed from rmailout.el. (setq filename (expand-file-name filename)) ;; FIXME should we really be messing with this defcustom? @@ -1123,8 +1084,7 @@ FILENAME exists and is Babyl format." (gnus-yes-or-no-p (concat "\"" filename "\" does not exist, create it? "))) (let ((file-buffer (create-file-buffer filename))) - (save-excursion - (set-buffer file-buffer) + (with-current-buffer file-buffer (if (fboundp 'rmail-insert-rmail-file-header) (rmail-insert-rmail-file-header)) (let ((require-final-newline nil) @@ -1191,6 +1151,7 @@ FILENAME exists and is Babyl format." (defun gnus-output-to-mail (filename &optional ask) "Append the current article to a mail file named FILENAME." + (require 'nnmail) (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) (tmpbuf (get-buffer-create " *Gnus-output*"))) @@ -1202,8 +1163,7 @@ FILENAME exists and is Babyl format." (gnus-y-or-n-p (concat "\"" filename "\" does not exist, create it? "))) (let ((file-buffer (create-file-buffer filename))) - (save-excursion - (set-buffer file-buffer) + (with-current-buffer file-buffer (let ((require-final-newline nil) (coding-system-for-write mm-text-coding-system)) (gnus-write-buffer filename))) @@ -1268,6 +1228,11 @@ ARG is passed to the first function." (save-current-buffer (apply 'run-hooks funcs))) +(defun gnus-run-hook-with-args (hook &rest args) + "Does the same as `run-hook-with-args', but saves the current buffer." + (save-current-buffer + (apply 'run-hook-with-args hook args))) + (defun gnus-run-mode-hooks (&rest funcs) "Run `run-mode-hooks' if it is available, otherwise `run-hooks'. This function saves the current buffer." @@ -1282,17 +1247,50 @@ This function saves the current buffer." "Say whether Gnus is running or not." (and (boundp 'gnus-group-buffer) (get-buffer gnus-group-buffer) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(defun gnus-remove-if (predicate list) - "Return a copy of LIST with all items satisfying PREDICATE removed." +(defun gnus-process-live-p (process) + "Returns non-nil if PROCESS is alive. +A process is considered alive if its status is `run', `open', +`listen', `connect' or `stop'." + (memq (process-status process) + '(run open listen connect stop))) + +(defun gnus-remove-if (predicate sequence &optional hash-table-p) + "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. +SEQUENCE should be a list, a vector, or a string. Returns always a list. +If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." (let (out) - (while list - (unless (funcall predicate (car list)) - (push (car list) out)) - (setq list (cdr list))) + (if hash-table-p + (mapatoms (lambda (symbol) + (unless (funcall predicate symbol) + (push symbol out))) + sequence) + (unless (listp sequence) + (setq sequence (append sequence nil))) + (while sequence + (unless (funcall predicate (car sequence)) + (push (car sequence) out)) + (setq sequence (cdr sequence)))) + (nreverse out))) + +(defun gnus-remove-if-not (predicate sequence &optional hash-table-p) + "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed. +SEQUENCE should be a list, a vector, or a string. Returns always a list. +If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." + (let (out) + (if hash-table-p + (mapatoms (lambda (symbol) + (when (funcall predicate symbol) + (push symbol out))) + sequence) + (unless (listp sequence) + (setq sequence (append sequence nil))) + (while sequence + (when (funcall predicate (car sequence)) + (push (car sequence) out)) + (setq sequence (cdr sequence)))) (nreverse out))) (if (fboundp 'assq-delete-all) @@ -1305,7 +1303,15 @@ Return the modified alist." (setq alist (delq entry alist))) alist))) -(defmacro gnus-pull (key alist &optional assoc-p) +(defun gnus-grep-in-list (word list) + "Find if a WORD matches any regular expression in the given LIST." + (when (and word list) + (catch 'found + (dolist (r list) + (when (string-match r word) + (throw 'found r)))))) + +(defmacro gnus-alist-pull (key alist &optional assoc-p) "Modify ALIST to be without KEY." (unless (symbolp alist) (error "Not a symbol: %s" alist)) @@ -1563,28 +1569,65 @@ SPEC is a predicate specifier that contains stuff like `or', `and', `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) (error "Invalid predicate specifier: %s" spec))))) -(defun gnus-completing-read (prompt table &optional predicate require-match - history) - (when (and history - (not (boundp history))) - (set history nil)) - (completing-read - (if (symbol-value history) - (concat prompt " (" (car (symbol-value history)) "): ") - (concat prompt ": ")) - table - predicate - require-match - nil - history - (car (symbol-value history)))) +(defun gnus-completing-read (prompt collection &optional require-match + initial-input history def) + "Call `gnus-completing-read-function'." + (funcall gnus-completing-read-function + (concat prompt (when def + (concat " (default " def ")")) + ": ") + collection require-match initial-input history def)) + +(defun gnus-emacs-completing-read (prompt collection &optional require-match + initial-input history def) + "Call standard `completing-read-function'." + (let ((completion-styles gnus-completion-styles)) + (completing-read prompt + ;; Old XEmacs (at least 21.4) expect an alist for + ;; collection. + (mapcar 'list collection) + nil require-match initial-input history def))) + +(autoload 'ido-completing-read "ido") +(defun gnus-ido-completing-read (prompt collection &optional require-match + initial-input history def) + "Call `ido-completing-read-function'." + (ido-completing-read prompt collection nil require-match + initial-input history def)) + + +(declare-function iswitchb-read-buffer "iswitchb" + (prompt &optional default require-match start matches-set)) +(defvar iswitchb-temp-buflist) + +(defun gnus-iswitchb-completing-read (prompt collection &optional require-match + initial-input history def) + "`iswitchb' based completing-read function." + ;; Make sure iswitchb is loaded before we let-bind its variables. + ;; If it is loaded inside the let, variables can become unbound afterwards. + (require 'iswitchb) + (let ((iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist + (let ((choices (append + (when initial-input (list initial-input)) + (symbol-value history) collection)) + filtered-choices) + (dolist (x choices) + (setq filtered-choices (adjoin x filtered-choices))) + (nreverse filtered-choices)))))) + (unwind-protect + (progn + (or iswitchb-mode + (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)) + (iswitchb-read-buffer prompt def require-match)) + (or iswitchb-mode + (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) (defun gnus-graphic-display-p () - (or (and (fboundp 'display-graphic-p) - (display-graphic-p)) - ;;;!!!This is bogus. Fixme! - (and (featurep 'xemacs) - t))) + (if (featurep 'xemacs) + (device-on-window-system-p) + (display-graphic-p))) (put 'gnus-parse-without-error 'lisp-indent-function 0) (put 'gnus-parse-without-error 'edebug-form-spec '(body)) @@ -1666,30 +1709,16 @@ CHOICE is a list of the choice char and help message at IDX." (kill-buffer buf)) tchar)) -(declare-function x-focus-frame "xfns.c" (frame)) -(declare-function w32-focus-frame "../term/w32-win" (frame)) - -(defun gnus-select-frame-set-input-focus (frame) - "Select FRAME, raise it, and set input focus, if possible." - (cond ((featurep 'xemacs) - (if (fboundp 'select-frame-set-input-focus) - (select-frame-set-input-focus frame) - (raise-frame frame) - (select-frame frame) - (focus-frame frame))) - ;; `select-frame-set-input-focus' defined in Emacs 21 will not - ;; set the input focus. - ((>= emacs-major-version 22) - (select-frame-set-input-focus frame)) - (t - (raise-frame frame) - (select-frame frame) - (cond ((memq window-system '(x ns mac)) - (x-focus-frame frame)) - ((eq window-system 'w32) - (w32-focus-frame frame))) - (when focus-follows-mouse - (set-mouse-position frame (1- (frame-width frame)) 0))))) +(if (featurep 'emacs) + (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus) + (if (fboundp 'select-frame-set-input-focus) + (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus) + ;; XEmacs 21.4, SXEmacs + (defun gnus-select-frame-set-input-focus (frame) + "Select FRAME, raise it, and set input focus, if possible." + (raise-frame frame) + (select-frame frame) + (focus-frame frame)))) (defun gnus-frame-or-window-display-name (object) "Given a frame or window, return the associated display name. @@ -1854,25 +1883,6 @@ empty directories from OLD-PATH." (defalias 'gnus-set-process-query-on-exit-flag 'process-kill-without-query)) -(if (fboundp 'with-local-quit) - (defalias 'gnus-with-local-quit 'with-local-quit) - (defmacro gnus-with-local-quit (&rest body) - "Execute BODY, allowing quits to terminate BODY but not escape further. -When a quit terminates BODY, `gnus-with-local-quit' returns nil but -requests another quit. That quit will be processed as soon as quitting -is allowed once again. (Immediately, if `inhibit-quit' is nil.)" - ;;(declare (debug t) (indent 0)) - `(condition-case nil - (let ((inhibit-quit nil)) - ,@body) - (quit (setq quit-flag t) - ;; This call is to give a chance to handle quit-flag - ;; in case inhibit-quit is nil. - ;; Without this, it will not be handled until the next function - ;; call, and that might allow it to exit thru a condition-case - ;; that intends to handle the quit signal next time. - (eval '(ignore nil)))))) - (defalias 'gnus-read-shell-command (if (fboundp 'read-shell-command) 'read-shell-command 'read-string)) @@ -1897,7 +1907,103 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" (get-char-table ,character ,display-table))) `(aref ,display-table ,character))) +(defun gnus-rescale-image (image size) + "Rescale IMAGE to SIZE if possible. +SIZE is in format (WIDTH . HEIGHT). Return a new image. +Sizes are in pixels." + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) + image + (let ((new-width (car size)) + (new-height (cdr size))) + (when (> (cdr (image-size image t)) new-height) + (setq image (or (create-image (plist-get (cdr image) :data) 'imagemagick t + :height new-height) + image))) + (when (> (car (image-size image t)) new-width) + (setq image (or + (create-image (plist-get (cdr image) :data) 'imagemagick t + :width new-width) + image))) + image))) + +(defun gnus-recursive-directory-files (dir) + "Return all regular files below DIR." + (let (files) + (dolist (file (directory-files dir t)) + (when (and (not (member (file-name-nondirectory file) '("." ".."))) + (file-readable-p file)) + (cond + ((file-regular-p file) + (push file files)) + ((file-directory-p file) + (setq files (append (gnus-recursive-directory-files file) files)))))) + files)) + +(defun gnus-list-memq-of-list (elements list) + "Return non-nil if any of the members of ELEMENTS are in LIST." + (let ((found nil)) + (dolist (elem elements) + (setq found (or found + (memq elem list)))) + found)) + +(eval-and-compile + (cond + ((fboundp 'match-substitute-replacement) + (defalias 'gnus-match-substitute-replacement 'match-substitute-replacement)) + (t + (defun gnus-match-substitute-replacement (replacement &optional fixedcase literal string subexp) + "Return REPLACEMENT as it will be inserted by `replace-match'. +In other words, all back-references in the form `\\&' and `\\N' +are substituted with actual strings matched by the last search. +Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same +meaning as for `replace-match'. + +This is the definition of match-substitute-replacement in subr.el from GNU Emacs." + (let ((match (match-string 0 string))) + (save-match-data + (set-match-data (mapcar (lambda (x) + (if (numberp x) + (- x (match-beginning 0)) + x)) + (match-data t))) + (replace-match replacement fixedcase literal match subexp))))))) + +(if (fboundp 'string-match-p) + (defalias 'gnus-string-match-p 'string-match-p) + (defsubst gnus-string-match-p (regexp string &optional start) + "\ +Same as `string-match' except this function does not change the match data." + (save-match-data + (string-match regexp string start)))) + +(eval-and-compile + (if (fboundp 'macroexpand-all) + (defalias 'gnus-macroexpand-all 'macroexpand-all) + (defun gnus-macroexpand-all (form &optional environment) + "Return result of expanding macros at all levels in FORM. +If no macros are expanded, FORM is returned unchanged. +The second optional arg ENVIRONMENT specifies an environment of macro +definitions to shadow the loaded ones for use in file byte-compilation." + (if (consp form) + (let ((idx 1) + (len (length (setq form (copy-sequence form)))) + expanded) + (while (< idx len) + (setcar (nthcdr idx form) (gnus-macroexpand-all (nth idx form) + environment)) + (setq idx (1+ idx))) + (if (eq (setq expanded (macroexpand form environment)) form) + form + (gnus-macroexpand-all expanded environment))) + form)))) + +;; Simple check: can be a macro but this way, although slow, it's really clear. +;; We don't use `bound-and-true-p' because it's not in XEmacs. +(defun gnus-bound-and-true-p (sym) + (and (boundp sym) (symbol-value sym))) + (provide 'gnus-util) -;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 ;;; gnus-util.el ends here