X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=5326b938cf4469dc346eeef668d85e5e4702c8c2;hb=8112a77959fee38576a8b4b3f5f6cb32208d4d03;hp=2f9bdd62e6e3605e2a5a4e6e127a1f5d8c716904;hpb=defbfad6913b5077f97df1382534d5b48edbd5b8;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 2f9bdd62e..5326b938c 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -33,7 +33,7 @@ ;;; 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 @@ -44,18 +44,22 @@ (defmacro with-no-warnings (&rest body) `(progn ,@body)))) -(defcustom gnus-completing-read-function - #'gnus-std-completing-read - "Function to do a completing read." +(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-std-completing-read) - (function-item :doc "Use iswitchb's completing-read function." - gnus-icompleting-read) - (function-item :doc "Use ido's completing-read function." - gnus-ido-completing-read) - (function))) + :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) @@ -148,11 +152,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." @@ -1288,6 +1290,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." @@ -1305,13 +1312,40 @@ This function saves the current buffer." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(defun gnus-remove-if (predicate list) - "Return a copy of LIST with all items satisfying PREDICATE removed." +(defun gnus-remove-if (predicate sequence &optional hash-table-p) + "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. +SEQUENCE should be a list, a vector, or a string. Returns always a list. +If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." + (let (out) + (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) - (while list - (unless (funcall predicate (car list)) - (push (car list) out)) - (setq list (cdr list))) + (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) @@ -1332,7 +1366,7 @@ Return the modified alist." (when (string-match r word) (throw 'found r)))))) -(defmacro gnus-pull (key alist &optional assoc-p) +(defmacro gnus-alist-pull (key alist &optional assoc-p) "Modify ALIST to be without KEY." (unless (symbolp alist) (error "Not a symbol: %s" alist)) @@ -1590,25 +1624,46 @@ 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-std-completing-read (prompt collection &optional require-match +(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) - (completing-read prompt collection nil require-match - initial-input history def)) + "Call `ido-completing-read-function'." + (ido-completing-read prompt collection nil require-match + initial-input history def)) + -(defun gnus-icompleting-read (prompt collection &optional require-match - initial-input history def) - (require 'iswitchb) +(autoload 'iswitchb-read-buffer "iswitchb") +(defun gnus-iswitchb-completing-read (prompt collection &optional require-match + initial-input history def) + "`iswitchb' based completing-read function." (let ((iswitchb-make-buflist-hook (lambda () (setq iswitchb-temp-buflist - (let ((choices (append (list) - (when initial-input (list initial-input)) - (symbol-value history) collection)) + (let ((choices (append + (when initial-input (list initial-input)) + (symbol-value history) collection)) filtered-choices) - (while choices - (when (and (car choices) (not (member (car choices) filtered-choices))) - (setq filtered-choices (cons (car choices) filtered-choices))) - (setq choices (cdr choices))) + (dolist (x choices) + (setq filtered-choices (adjoin x filtered-choices))) (nreverse filtered-choices)))))) (unwind-protect (progn @@ -1618,23 +1673,6 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (when (not iswitchb-mode) (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) -(defun gnus-ido-completing-read (prompt collection &optional require-match - initial-input history def) - (require 'ido) - (ido-completing-read prompt collection nil require-match - initial-input history def)) - -(defun gnus-completing-read (prompt collection &optional require-match - initial-input history def) - "Do a completing read with the configured `gnus-completing-read-function'." - (let ((completion-styles gnus-completion-styles)) - (funcall - gnus-completing-read-function - (concat prompt (when def - (concat " (default " def ")")) - ": ") - collection require-match initial-input history def))) - (defun gnus-graphic-display-p () (if (featurep 'xemacs) (device-on-window-system-p) @@ -1935,6 +1973,26 @@ 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))) + (provide 'gnus-util) ;;; gnus-util.el ends here