X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=7e94d4e6f2942ad4e73f3a0e04a5a54a9098862c;hb=86720e148d6539b56265ba389b73ee4ce10d213e;hp=e0e73e57baf32356799ef3961bc06657ece2c3ed;hpb=50c4ee6d30ff794f1ae34bbd864aee85827ac121;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index e0e73e57b..7e94d4e6f 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,6 +1,7 @@ ;;; 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 ;; Keywords: news @@ -19,8 +20,8 @@ ;; 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: @@ -38,9 +39,12 @@ (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) @@ -56,11 +60,21 @@ (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. + +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." @@ -89,7 +103,7 @@ (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)) @@ -159,8 +173,13 @@ is slower." ;; 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 ``'' first in order to handle the quite common + ;; form ``"abc@xyz" '' (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
" format is used. (and address ;; Linear white space is not required. @@ -299,8 +318,8 @@ is slower." (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 @@ -461,7 +480,8 @@ inside loops." (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) @@ -474,12 +494,23 @@ inside loops." (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." @@ -565,6 +596,17 @@ 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 @@ -610,24 +652,49 @@ If N, return the Nth ancestor instead." (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." @@ -651,6 +718,45 @@ and `print-level' to nil." (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 . +(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) @@ -941,6 +1047,13 @@ ARG is passed to the first function." (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 @@ -952,14 +1065,6 @@ ARG is passed to the first function." (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) @@ -1051,7 +1156,7 @@ Return the modified alist." (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 @@ -1106,6 +1211,13 @@ Return the modified alist." (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.) @@ -1120,7 +1232,7 @@ Return the modified alist." 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) @@ -1143,7 +1255,7 @@ is run." "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)) @@ -1326,20 +1438,19 @@ CHOICE is a list of the choice char and help message at IDX." (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))) @@ -1361,6 +1472,26 @@ Return nil otherwise." 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. @@ -1412,41 +1543,48 @@ predicate on the elements." (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) @@ -1466,8 +1604,8 @@ empty directories from OLD-PATH." (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) @@ -1475,6 +1613,31 @@ empty directories from OLD-PATH." (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