;;; 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.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(defmacro with-no-warnings (&rest body)
`(progn ,@body))))
+(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)
+ (function-item
+ :doc "Use `ido-completing-read' function."
+ gnus-ido-completing-read)
+ (function-item
+ :doc "Use iswitchb based completing-read function."
+ gnus-iswitchb-completing-read)))
+
+(defcustom gnus-completion-styles
+ (if (and (boundp 'completion-styles-alist)
+ (boundp 'completion-styles))
+ (append (when (and (assq 'substring completion-styles-alist)
+ (not (memq 'substring completion-styles)))
+ (list 'substring))
+ completion-styles)
+ nil)
+ "Value of `completion-styles' to use when completing."
+ :version "24.1"
+ :group 'gnus-meta
+ :type 'list)
+
;; Fixme: this should be a gnus variable, not nnmail-.
(defvar nnmail-pathname-coding-system)
(defvar nnmail-active-file-coding-system)
(defvar gnus-original-article-buffer)
(defvar gnus-user-agent)
-(require 'time-date)
-(require 'netrc)
-
-(autoload 'message-fetch-field "message")
(autoload 'gnus-get-buffer-window "gnus-win")
(autoload 'nnheader-narrow-to-headers "nnheader")
(autoload 'nnheader-replace-chars-in-string "nnheader")
;; 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."
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))
(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
(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.
;;
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
(* (- (string-to-number days) 1) 3600 24))))
+(defmacro gnus-date-get-time (date)
+ "Convert DATE string to Emacs time.
+Cache the result as a text property stored in DATE."
+ ;; Either return the cached value...
+ `(let ((d ,date))
+ (if (equal "" d)
+ '(0 0)
+ (or (get-text-property 0 'gnus-time d)
+ ;; or compute the value...
+ (let ((time (safe-date-to-time d)))
+ ;; and store it back in the string.
+ (put-text-property 0 1 'gnus-time time d)
+ time)))))
+
(defvar gnus-user-date-format-alist
'(((gnus-seconds-today) . "%k:%M")
(604800 . "%a %k:%M") ;;that's one week
(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.
+Returns \" ? \" if there's bad input or if another 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)))
+ (let* ((messy-date (gnus-float-time (gnus-date-get-time messy-date)))
(now (gnus-float-time))
;;If we don't find something suitable we'll use this one
(my-format "%b %d '%y"))
(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))
+ (format-time-string "%d-%b" (gnus-date-get-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."
- ;; Either return the cached value...
- `(let ((d ,date))
- (if (equal "" d)
- '(0 0)
- (or (get-text-property 0 'gnus-time d)
- ;; or compute the value...
- (let ((time (safe-date-to-time d)))
- ;; and store it back in the string.
- (put-text-property 0 1 'gnus-time time d)
- time)))))
-
(defsubst gnus-time-iso8601 (time)
"Return a string of TIME in YYYYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
(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
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'."
(overlay-get overlay 'face))
(overlays-at pos)))))))
+(if (fboundp 'invisible-p)
+ (defalias 'gnus-invisible-p 'invisible-p)
+ ;; for Emacs < 22.2, and XEmacs.
+ (defun gnus-invisible-p (pos)
+ "Return non-nil if the character after POS is currently invisible."
+ (let ((prop (get-char-property pos 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec))))))
+
+;; Note: the optional 2nd argument has a different meaning between
+;; Emacs and XEmacs.
+;; (next-char-property-change POSITION &optional LIMIT)
+;; (next-extent-change POS &optional OBJECT)
+(defalias 'gnus-next-char-property-change
+ (if (fboundp 'next-extent-change)
+ 'next-extent-change 'next-char-property-change))
+
+(defalias 'gnus-previous-char-property-change
+ (if (fboundp 'previous-extent-change)
+ 'previous-extent-change 'previous-char-property-change))
+
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996
;; The primary idea here is to try to protect internal datastructures
;; from becoming corrupted when the user hits C-g, or if a hook or
;;; 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)
(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)
(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)))
"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)
(setq alist (delq entry alist)))
alist)))
+(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-pull (key alist &optional assoc-p)
"Modify ALIST to be without KEY."
(unless (symbolp alist)
`(,(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 collection nil require-match initial-input history def)))
+
+(defun gnus-ido-completing-read (prompt collection &optional require-match
+ initial-input history def)
+ "Call `ido-completing-read-function'."
+ (require 'ido)
+ (ido-completing-read prompt collection nil require-match initial-input history def))
+
+(defun gnus-iswitchb-completing-read (prompt collection &optional require-match
+ initial-input history def)
+ "`iswitchb' based completing-read function."
+ (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
+ (when (not iswitchb-mode)
+ (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
+ (iswitchb-read-buffer prompt def require-match))
+ (when (not 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))
(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 (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.
(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)
-;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
;;; gnus-util.el ends here
projects / gnus / blobdiff