;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(require 'cl)
;; Fixme: this should be a gnus variable, not nnmail-.
(defvar nnmail-pathname-coding-system)
+ (defvar nnmail-active-file-coding-system)
;; Inappropriate references to other parts of Gnus.
(defvar gnus-emphasize-whitespace-regexp)
+ (defvar gnus-original-article-buffer)
+ (defvar gnus-user-agent)
)
(require 'time-date)
(require 'netrc)
(eval-and-compile
(cond
- ((fboundp 'replace-in-string)
- (defalias 'gnus-replace-in-string 'replace-in-string))
+ ;; Prefer `replace-regexp-in-string' (present in Emacs, XEmacs 21.5,
+ ;; SXEmacs 22.1.4) over `replace-in-string'. The later leads to inf-loops
+ ;; on empty matches:
+ ;; (replace-in-string "foo" "/*$" "/")
+ ;; (replace-in-string "xe" "\\(x\\)?" "")
((fboundp 'replace-regexp-in-string)
(defun gnus-replace-in-string (string regexp newtext &optional literal)
- (replace-regexp-in-string regexp newtext string nil literal)))))
+ "Replace all matches for REGEXP with NEWTEXT in STRING.
+If LITERAL is non-nil, insert NEWTEXT literally. Return a new
+string containing the replacements.
-;;; bring in the netrc functions as aliases
-(defalias 'gnus-netrc-get 'netrc-get)
-(defalias 'gnus-netrc-machine 'netrc-machine)
-(defalias 'gnus-parse-netrc 'netrc-parse)
+This is a compatibility function for different Emacsen."
+ (replace-regexp-in-string regexp newtext string nil literal)))
+ ((fboundp 'replace-in-string)
+ (defalias 'gnus-replace-in-string 'replace-in-string))))
(defun gnus-boundp (variable)
"Return non-nil if VARIABLE is bound and non-nil."
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
(defmacro gnus-intern-safe (string hashtable)
- "Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
+ "Get hash value. Arguments are STRING and HASHTABLE."
`(let ((symbol (intern ,string ,hashtable)))
(or (boundp symbol)
(set symbol nil))
;; First find the address - the thing with the @ in it. This may
;; not be accurate in mail addresses, but does the trick most of
;; the time in news messages.
- (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
- (setq address (substring from (match-beginning 0) (match-end 0))))
+ (cond (;; Check ``<foo@bar>'' first in order to handle the quite common
+ ;; form ``"abc@xyz" <foo@bar>'' (i.e. ``@'' as part of a comment)
+ ;; correctly.
+ (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" from)
+ (setq address (substring from (match-beginning 1) (match-end 1))))
+ ((string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
+ (setq address (substring from (match-beginning 0) (match-end 0)))))
;; Then we check whether the "name <address>" format is used.
(and address
;; Linear white space is not required.
(defun gnus-remove-text-with-property (prop)
"Delete all text in the current buffer with text property PROP."
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (while (get-text-property (point) prop)
- (delete-char 1))
- (goto-char (next-single-property-change (point) prop nil (point-max))))))
+ (let ((start (point-min))
+ end)
+ (unless (get-text-property start prop)
+ (setq start (next-single-property-change start prop)))
+ (while start
+ (setq end (text-property-any start (point-max) prop nil))
+ (delete-region start (or end (point-max)))
+ (setq start (when end
+ (next-single-property-change start prop))))))
(defun gnus-newsgroup-directory-form (newsgroup)
"Make hierarchical directory name from NEWSGROUP name."
(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 " ")))
+ (concat prompt " (default " default "): ")
+ (concat prompt ": ")))
(answer (apply 'completing-read prompt args)))
(if (or (null answer) (zerop (length answer)))
default
(apply 'format args)))
(defun gnus-error (level &rest args)
- "Beep an error if LEVEL is equal to or less than `gnus-verbose'."
+ "Beep an error if LEVEL is equal to or less than `gnus-verbose'.
+ARGS are passed to `message'."
(when (<= (floor level) gnus-verbose)
(apply 'message args)
(ding)
(defun gnus-split-references (references)
"Return a list of Message-IDs in REFERENCES."
(let ((beg 0)
+ (references (or references ""))
ids)
(while (string-match "<[^<]+[^< \t]" references beg)
(push (substring references (match-beginning 0) (setq beg (match-end 0)))
ids))
(nreverse ids)))
+(defun gnus-extract-references (references)
+ "Return a list of Message-IDs in REFERENCES (in In-Reply-To
+ format), trimmed to only contain the Message-IDs."
+ (let ((ids (gnus-split-references references))
+ refs)
+ (dolist (id ids)
+ (when (string-match "<[^<>]+>" id)
+ (push (match-string 0 id) refs)))
+ refs))
+
(defsubst gnus-parent-id (references &optional n)
"Return the last Message-ID in REFERENCES.
If N, return the Nth ancestor instead."
(substring gname (match-end 0))
gname)))
+(defmacro gnus-group-server (group)
+ "Find the server name of a foreign newsgroup.
+For example, (gnus-group-server \"nnimap+yxa:INBOX.foo\") would
+yield \"nnimap:yxa\"."
+ `(let ((gname ,group))
+ (if (string-match "^\\([^:+]+\\)\\(?:\\+\\([^:]*\\)\\)?:" gname)
+ (format "%s:%s" (match-string 1 gname) (or
+ (match-string 2 gname)
+ ""))
+ (format "%s:%s" (car gnus-select-method) (cadr gnus-select-method)))))
+
(defun gnus-make-sort-function (funs)
"Return a composite sort condition based on the functions in FUNS."
(cond
(define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
[menu-bar edit] 'undefined))
+(defmacro gnus-bind-print-variables (&rest forms)
+ "Bind print-* variables and evaluate FORMS.
+This macro is used with `prin1', `pp', etc. in order to ensure printed
+Lisp objects are loadable. Bind `print-quoted' and `print-readably'
+to t, and `print-escape-multibyte', `print-escape-newlines',
+`print-escape-nonascii', `print-length', `print-level' and
+`print-string-length' to nil."
+ `(let ((print-quoted t)
+ (print-readably t)
+ ;;print-circle
+ ;;print-continuous-numbering
+ print-escape-multibyte
+ print-escape-newlines
+ print-escape-nonascii
+ ;;print-gensym
+ print-length
+ print-level
+ print-string-length)
+ ,@forms))
+
(defun gnus-prin1 (form)
"Use `prin1' on FORM in the current buffer.
-Bind `print-quoted' and `print-readably' to t while printing."
- (let ((print-quoted t)
- (print-readably t)
- (print-escape-multibyte nil)
- print-level print-length)
- (prin1 form (current-buffer))))
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (prin1 form (current-buffer))))
(defun gnus-prin1-to-string (form)
"The same as `prin1'.
-Bind `print-quoted' and `print-readably' to t, and `print-length'
-and `print-level' to nil."
- (let ((print-quoted t)
- (print-readably t)
- (print-length nil)
- (print-level nil))
- (prin1-to-string form)))
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (prin1-to-string form)))
+
+(defun gnus-pp (form &optional stream)
+ "Use `pp' on FORM in the current buffer.
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (pp form (or stream (current-buffer)))))
+
+(defun gnus-pp-to-string (form)
+ "The same as `pp-to-string'.
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (pp-to-string form)))
(defun gnus-make-directory (directory)
"Make DIRECTORY (and all its parents) if it doesn't exist."
(when (file-exists-p file)
(delete-file file)))
+(defun gnus-delete-directory (directory)
+ "Delete files in DIRECTORY. Subdirectories remain.
+If there's no subdirectory, delete DIRECTORY as well."
+ (when (file-directory-p directory)
+ (let ((files (directory-files
+ directory t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))
+ file dir)
+ (while files
+ (setq file (pop files))
+ (if (eq t (car (file-attributes file)))
+ ;; `file' is a subdirectory.
+ (setq dir t)
+ ;; `file' is a file or a symlink.
+ (delete-file file)))
+ (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)
(save-current-buffer
(apply 'run-hooks funcs)))
+(defun gnus-run-mode-hooks (&rest funcs)
+ "Run `run-mode-hooks' if it is available, otherwise `run-hooks'.
+This function saves the current buffer."
+ (if (fboundp 'run-mode-hooks)
+ (save-current-buffer (apply 'run-mode-hooks funcs))
+ (save-current-buffer (apply 'run-hooks funcs))))
+
;;; Various
(defvar gnus-group-buffer) ; Compiler directive
(set-buffer gnus-group-buffer)
(eq major-mode 'gnus-group-mode))))
-(defun gnus-remove-duplicates (list)
- (let (new)
- (while list
- (or (member (car list) new)
- (setq new (cons (car list) new)))
- (setq list (cdr list)))
- (nreverse new)))
-
(defun gnus-remove-if (predicate list)
"Return a copy of LIST with all items satisfying PREDICATE removed."
(let (out)
(standard-output
(lambda (c)
(aset ,buffer ,leng c)
-
+
(if (= ,size (setq ,leng (1+ ,leng)))
(progn (write-region ,buffer nil ,file ,append 'no-msg)
(setq ,leng 0
(remove-text-properties start end properties object))
t))
+(defun gnus-string-remove-all-properties (string)
+ (condition-case ()
+ (let ((s string))
+ (set-text-properties 0 (length string) nil string)
+ s)
+ (error string)))
+
;; This might use `compare-strings' to reduce consing in the
;; case-insensitive case, but it has to cope with null args.
;; (`string-equal' uses symbol print names.)
Setting it to nil has no effect after the first time `gnus-byte-compile'
is run."
:type 'boolean
- :version "21.1"
+ :version "22.1"
:group 'gnus-various)
(defun gnus-byte-compile (form)
"Delete by side effect any elements of LIST whose car is `equal' to KEY.
The modified LIST is returned. If the first member
of LIST has a car that is `equal' to KEY, there is no way to remove it
-by side effect; therefore, write `(setq foo (remassoc key foo))' to be
+by side effect; therefore, write `(setq foo (gnus-remassoc key foo))' to be
sure of changing the value of `foo'."
(when alist
(if (equal key (caar alist))
(defun gnus-select-frame-set-input-focus (frame)
"Select FRAME, raise it, and set input focus, if possible."
(cond ((featurep 'xemacs)
- (raise-frame frame)
- (select-frame frame)
- (focus-frame frame))
- ;; The function `select-frame-set-input-focus' won't set
- ;; the input focus under Emacs 21.2 and X window system.
- ;;((fboundp 'select-frame-set-input-focus)
- ;; (defalias 'gnus-select-frame-set-input-focus
- ;; 'select-frame-set-input-focus)
- ;; (select-frame-set-input-focus frame))
+ (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 ((and (eq window-system 'x)
- (fboundp 'x-focus-frame))
+ (cond ((memq window-system '(x mac))
(x-focus-frame frame))
((eq window-system 'w32)
(w32-focus-frame frame)))
display))
display)))))
+(eval-when-compile
+ (defvar tool-bar-mode))
+
+(defun gnus-tool-bar-update (&rest ignore)
+ "Update the tool bar."
+ (when (and (boundp 'tool-bar-mode)
+ tool-bar-mode)
+ (let* ((args nil)
+ (func (cond ((featurep 'xemacs)
+ 'ignore)
+ ((fboundp 'tool-bar-update)
+ 'tool-bar-update)
+ ((fboundp 'force-window-update)
+ 'force-window-update)
+ ((fboundp 'redraw-frame)
+ (setq args (list (selected-frame)))
+ 'redraw-frame)
+ (t 'ignore))))
+ (apply func args))))
+
;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile.
(defmacro gnus-mapcar (function seq1 &rest seqs2_n)
"Apply FUNCTION to each element of the sequences, and make a list of the results.
(nconc (nreverse res) list1 list2))))
(eval-when-compile
- (defvar xemacs-codename))
+ (defvar xemacs-codename)
+ (defvar sxemacs-codename)
+ (defvar emacs-program-version))
(defun gnus-emacs-version ()
"Stringified Emacs version."
- (let ((system-v
- (cond
- ((eq gnus-user-agent 'emacs-gnus-config)
- system-configuration)
- ((eq gnus-user-agent 'emacs-gnus-type)
- (symbol-name system-type))
- (t nil))))
+ (let* ((lst (if (listp gnus-user-agent)
+ gnus-user-agent
+ '(gnus emacs type)))
+ (system-v (cond ((memq 'config lst)
+ system-configuration)
+ ((memq 'type lst)
+ (symbol-name system-type))
+ (t nil)))
+ codename emacsname)
+ (cond ((featurep 'sxemacs)
+ (setq emacsname "SXEmacs"
+ codename sxemacs-codename))
+ ((featurep 'xemacs)
+ (setq emacsname "XEmacs"
+ codename xemacs-codename))
+ (t
+ (setq emacsname "Emacs")))
(cond
- ((eq gnus-user-agent 'gnus)
+ ((not (memq 'emacs lst))
nil)
((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
+ ;; Emacs:
(concat "Emacs/" (match-string 1 emacs-version)
(if system-v
(concat " (" system-v ")")
"")))
- ((string-match
- "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
- emacs-version)
- (concat
- (match-string 1 emacs-version)
- (format "/%d.%d" emacs-major-version emacs-minor-version)
- (if (match-beginning 3)
- (match-string 3 emacs-version)
- "")
- (if (boundp 'xemacs-codename)
- (concat
- " (" xemacs-codename
- (if system-v
- (concat ", " system-v ")")
+ ((or (featurep 'sxemacs) (featurep 'xemacs))
+ ;; XEmacs or SXEmacs:
+ (concat emacsname "/" emacs-program-version
+ " ("
+ (when (and (memq 'codename lst)
+ codename)
+ (concat codename
+ (when system-v ", ")))
+ (when system-v system-v)
")"))
- "")))
(t emacs-version))))
(defun gnus-rename-file (old-path new-path &optional trim)
(setq temp (cdr temp)))
(= (length temp) 0))
(delete-directory old-dir)
- (setq old-dir (file-name-as-directory
- (file-truename
+ (setq old-dir (file-name-as-directory
+ (file-truename
(concat old-dir "..")))))))))
(defun gnus-set-file-modes (filename mode)
(ignore-errors
(set-file-modes filename mode)))
+(if (fboundp 'set-process-query-on-exit-flag)
+ (defalias 'gnus-set-process-query-on-exit-flag
+ 'set-process-query-on-exit-flag)
+ (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))))))
+
(provide 'gnus-util)
;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
projects / gnus / blobdiff