;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2014 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;;; Code:
-;; For Emacs <22.2 and XEmacs.
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
(require 'cl))
+(require 'time-date)
+
(defcustom gnus-completing-read-function 'gnus-emacs-completing-read
"Function use to do completing read."
:version "24.1"
"Value of `completion-styles' to use when completing."
:version "24.1"
:group 'gnus-meta
- :type 'list)
+ :type '(repeat symbol))
;; Fixme: this should be a gnus variable, not nnmail-.
(defvar nnmail-pathname-coding-system)
`(delete-region (point-at-bol)
(progn (forward-line ,(or n 1)) (point))))
-(defun gnus-byte-code (func)
- "Return a form that can be `eval'ed based on FUNC."
- (let ((fval (indirect-function func)))
- (if (byte-code-function-p fval)
- (let ((flist (append fval nil)))
- (setcar flist 'byte-code)
- flist)
- (cons 'progn (cddr fval)))))
-
(defun gnus-extract-address-components (from)
"Extract address components from a From header.
Given an RFC-822 address FROM, extract full name and canonical address.
(match-end 0)))))
(list (if (string= name "") nil name) (or address from))))
-(defun gnus-extract-address-component-name (from)
- "Extract name from a From header.
-Uses `gnus-extract-address-components'."
- (nth 0 (gnus-extract-address-components from)))
-
-(defun gnus-extract-address-component-email (from)
- "Extract e-mail address from a From header.
-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)
(defun gnus-goto-colon ()
- (beginning-of-line)
+ (move-beginning-of-line 1)
(let ((eol (point-at-eol)))
(goto-char (or (text-property-any (point) eol 'gnus-position t)
(search-forward ":" eol t)
(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 (or (featurep 'emacs)
- (and (fboundp 'float-time)
- (subrp (symbol-function 'float-time))))
+ (fboundp 'float-time))
(defalias 'gnus-float-time 'float-time)
(defun gnus-float-time (&optional time)
"Convert time value TIME to a floating point number.
(defmacro gnus-define-keys (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
+ ;; Convert the key [?\S-\ ] to [(shift space)] for XEmacs.
+ (when (featurep 'xemacs)
+ (let ((bindings plist))
+ (while bindings
+ (when (equal (car bindings) [?\S-\ ])
+ (setcar bindings [(shift space)]))
+ (setq bindings (cddr bindings)))))
`(gnus-define-keys-1 (quote ,keymap) (quote ,plist)))
(defmacro gnus-define-keys-safe (keymap &rest plist)
(define-key keymap key (pop plist))
(pop plist)))))
-;; 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: <E1JBva1-000528-VY@fencepost.gnu.org>
-;; |
-;; | 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 <ich@Frank-Schmitt.net>. Allows to have
;; age-depending date representations. (e.g. just the time if it's
(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
- ((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 another error occurs.
-Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
- (condition-case ()
- (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"))
- (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 ()
(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)
(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))
(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)
(> message-log-max 0)
(/= (length str) 0))
(setq time (current-time))
- (with-current-buffer (get-buffer-create "*Messages*")
+ (with-current-buffer (if (fboundp 'messages-buffer)
+ (messages-buffer)
+ (get-buffer-create "*Messages*"))
(goto-char (point-max))
- (insert ,@timestamp str "\n")
- (forward-line (- message-log-max))
- (delete-region (point-min) (point))
+ (let ((inhibit-read-only t))
+ (insert ,timestamp str "\n")
+ (forward-line (- message-log-max))
+ (delete-region (point-min) (point)))
(goto-char (point-max))))
str)
(gnus-add-timestamp-to-message
(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))))))))
(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."
;; should be gnus-characterp, but this can't be called in XEmacs anyway
(cons (and (numberp event) event) event)))
-(defun gnus-sortable-date (date)
- "Make string suitable for sorting from DATE."
- (gnus-time-iso8601 (date-to-time date)))
-
(defun gnus-copy-file (file &optional to)
"Copy FILE to TO."
(interactive
(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."
(unless dir
(delete-directory directory)))))
-;; The following two functions are used in gnus-registry.
-;; They were contributed by Andreas Fuchs <asf@void.at>.
-(defun gnus-alist-to-hashtable (alist)
- "Build a hashtable from the values in ALIST."
- (let ((ht (make-hash-table
- :size 4096
- :test 'equal)))
- (mapc
- (lambda (kv-pair)
- (puthash (car kv-pair) (cdr kv-pair) ht))
- alist)
- ht))
-
-(defun gnus-hashtable-to-alist (hash)
- "Build an alist from the values in HASH."
- (let ((list nil))
- (maphash
- (lambda (key value)
- (setq list (cons (cons key value) list)))
- hash)
- list))
-
(defun gnus-strip-whitespace (string)
"Return STRING stripped of all whitespace."
(while (string-match "[\r\n\t ]+" string)
(setq beg (point)))
(gnus-overlay-put (gnus-make-overlay beg (point)) prop val)))))
-(defun gnus-put-text-property-excluding-characters-with-faces (beg end
- prop val)
- "The same as `put-text-property', but don't put props on characters with the `gnus-face' property."
- (let ((b beg))
- (while (/= b end)
- (when (get-text-property b 'gnus-face)
- (setq b (next-single-property-change b 'gnus-face nil end)))
- (when (/= b end)
+(defun gnus-put-text-property-excluding-characters-with-faces (beg end prop val)
+ "The same as `put-text-property', except where `gnus-face' is set.
+If so, and PROP is `face', set the second element of its value to VAL.
+Otherwise, do nothing."
+ (while (< beg end)
+ ;; Property values are compared with `eq'.
+ (let ((stop (next-single-property-change beg 'face nil end)))
+ (if (get-text-property beg 'gnus-face)
+ (when (eq prop 'face)
+ (setcar (cdr (get-text-property beg 'face)) (or val 'default)))
(inline
- (gnus-put-text-property
- b (setq b (next-single-property-change b 'gnus-face nil end))
- prop val))))))
+ (gnus-put-text-property beg stop prop val)))
+ (setq beg stop))))
+
+(defun gnus-get-text-property-excluding-characters-with-faces (pos prop)
+ "The same as `get-text-property', except where `gnus-face' is set.
+If so, and PROP is `face', return the second element of its value.
+Otherwise, return the value."
+ (let ((val (get-text-property pos prop)))
+ (if (and (get-text-property pos 'gnus-face)
+ (eq prop 'face))
+ (cadr val)
+ (get-text-property pos prop))))
(defmacro gnus-faces-at (position)
"Return a list of faces at POSITION."
'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
+;; The primary idea here is to try to protect internal data structures
;; from becoming corrupted when the user hits C-g, or if a hook or
;; similar blows up. Often in Gnus multiple tables/lists need to be
;; updated at the same time, or information can be lost.
(declare-function mm-append-to-file "mm-util"
(start end filename &optional codesys inhibit))
+(declare-function rmail-swap-buffers-maybe "rmail" ())
+(declare-function rmail-maybe-set-message-counters "rmail" ())
+(declare-function rmail-count-new-messages "rmail" (&optional nomsg))
+(declare-function rmail-summary-exists "rmail" ())
+(declare-function rmail-show-message "rmail" (&optional n no-summary))
+;; Macroexpansion of rmail-select-summary:
+(declare-function rmail-summary-displayed "rmail" ())
+(declare-function rmail-pop-to-buffer "rmail" (&rest args))
+(declare-function rmail-maybe-display-summary "rmail" ())
(defun gnus-output-to-rmail (filename &optional ask)
"Append the current article to an Rmail file named FILENAME.
"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)
+ (if (featurep 'xemacs)
+ ;; Old XEmacs (at least 21.4) expect an alist,
+ ;; in which the car of each element is a string,
+ ;; for collection.
+ (mapcar
+ (lambda (elem)
+ (list (format "%s" (or (car-safe elem) elem))))
+ collection)
+ collection)
nil require-match initial-input history def)))
(autoload 'ido-completing-read "ido")
(get-char-table ,character ,display-table)))
`(aref ,display-table ,character)))
+(declare-function image-size "image.c" (spec &optional pixels frame))
+
(defun gnus-rescale-image (image size)
"Rescale IMAGE to SIZE if possible.
SIZE is in format (WIDTH . HEIGHT). Return a new image.
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))
(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))))
+(if (fboundp 'string-prefix-p)
+ (defalias 'gnus-string-prefix-p 'string-prefix-p)
+ (defun gnus-string-prefix-p (str1 str2 &optional ignore-case)
+ "Return non-nil if STR1 is a prefix of STR2.
+If IGNORE-CASE is non-nil, the comparison is done without paying attention
+to case differences."
+ (and (<= (length str1) (length str2))
+ (let ((prefix (substring str2 0 (length str1))))
+ (if ignore-case
+ (string-equal (downcase str1) (downcase prefix))
+ (string-equal str1 prefix))))))
+
+;; 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)))
+
+(if (fboundp 'timer--function)
+ (defalias 'gnus-timer--function 'timer--function)
+ (defun gnus-timer--function (timer)
+ (elt timer 5)))
(provide 'gnus-util)