X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=110e2e038d177a4cb95422048d49116b5ac87e2c;hp=8aa4925b4172c8fbf5d31b1bbdfa4e260ebfe515;hb=5193de49edd84a0e8d74e8289269b6055e14d6b1;hpb=3faf040012d34b6930e3447d9f61c828a5230b5b diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 8aa4925b4..110e2e038 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,26 +1,25 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -34,30 +33,38 @@ ;;; Code: +;; For Emacs < 22.2. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile - (require 'cl) - ;; Fixme: this should be a gnus variable, not nnmail-. - (defvar nnmail-pathname-coding-system) + (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) - ;; Inappropriate references to other parts of Gnus. - (defvar gnus-emphasize-whitespace-regexp) - ) (require 'time-date) (require 'netrc) -(eval-and-compile - (autoload 'message-fetch-field "message") - (autoload 'gnus-get-buffer-window "gnus-win") - (autoload 'rmail-insert-rmail-file-header "rmail") - (autoload 'rmail-count-new-messages "rmail") - (autoload 'rmail-show-message "rmail") - (autoload 'nnheader-narrow-to-headers "nnheader") - (autoload 'nnheader-replace-chars-in-string "nnheader")) +(autoload 'message-fetch-field "message") +(autoload 'gnus-get-buffer-window "gnus-win") +(autoload 'rmail-insert-rmail-file-header "rmail") +(autoload 'rmail-count-new-messages "rmail") +(autoload 'rmail-show-message "rmail") +(autoload 'nnheader-narrow-to-headers "nnheader") +(autoload 'nnheader-replace-chars-in-string "nnheader") (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 latter 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 all matches for REGEXP with NEWTEXT in STRING. @@ -65,7 +72,9 @@ 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))))) + (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." @@ -94,21 +103,12 @@ This is a compatibility function for different Emacsen." (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)) symbol)) -;; Added by Geoffrey T. Dairiki . A safe way -;; to limit the length of a string. This function is necessary since -;; `(substr "abc" 0 30)' pukes with "Args out of range". -;; Fixme: Why not `truncate-string-to-width'? -(defsubst gnus-limit-string (str width) - (if (> (length str) width) - (substring str 0 width) - str)) - (defsubst gnus-goto-char (point) (and point (goto-char point))) @@ -164,8 +164,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. @@ -187,6 +192,15 @@ is slower." (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))) (defun gnus-fetch-field (field) "Return the value of the header FIELD of current article." @@ -209,6 +223,13 @@ is slower." (search-forward ":" eol 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-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) (let ((method (or method (gnus-find-method-for-group group)))) (mapconcat (lambda (group) @@ -249,6 +270,15 @@ is slower." (not (or (string< s1 s2) (string= s1 s2)))) +(defun gnus-string< (s1 s2) + "Return t if first arg string is less than second in lexicographic order. +Case is significant if and only if `case-fold-search' is nil. +Symbols are also allowed; their print names are used instead." + (if case-fold-search + (string-lessp (downcase (if (symbolp s1) (symbol-name s1) s1)) + (downcase (if (symbolp s2) (symbol-name s2) s2))) + (string-lessp s1 s2))) + ;;; Time functions. (defun gnus-file-newer-than (file date) @@ -304,8 +334,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 @@ -313,15 +343,55 @@ is slower." ;; Two silly functions to ensure that all `y-or-n-p' questions clear ;; the echo area. -(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 ""))) +;; +;; 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: +;; | +;; | 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) ;; By Frank Schmitt . Allows to have ;; age-depending date representations. (e.g. just the time if it's @@ -451,6 +521,79 @@ jabbering all the time." :group 'gnus-start :type 'integer) +(defcustom gnus-add-timestamp-to-message nil + "Non-nil means add timestamps to messages that Gnus issues. +If it is `log', add timestamps to only the messages that go into the +\"*Messages*\" buffer (in XEmacs, it is the \" *Message-Log*\" buffer). +If it is neither nil nor `log', add timestamps not only to log messages +but also to the ones displayed in the echo area." + :version "23.1" ;; No Gnus + :group 'gnus-various + :type '(choice :format "%{%t%}:\n %[Value Menu%] %v" + (const :tag "Logged messages only" log) + (sexp :tag "All messages" + :match (lambda (widget value) value) + :value t) + (const :tag "No timestamp" nil))) + +(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)) "> "))) + (if (featurep 'xemacs) + `(let (str time) + (if (or (and (null ,format-string) (null ,args)) + (progn + (setq str (apply 'format ,format-string ,args)) + (zerop (length str)))) + (prog1 + (and ,format-string str) + (clear-message nil)) + (cond ((eq gnus-add-timestamp-to-message 'log) + (setq time (current-time)) + (display-message 'no-log str) + (log-message 'message (concat ,@timestamp str))) + (gnus-add-timestamp-to-message + (setq time (current-time)) + (display-message 'message (concat ,@timestamp str))) + (t + (display-message 'message str)))) + str) + `(let (str time) + (cond ((eq gnus-add-timestamp-to-message 'log) + (setq str (let (message-log-max) + (apply 'message ,format-string ,args))) + (when (and message-log-max + (> message-log-max 0) + (/= (length str) 0)) + (setq time (current-time)) + (with-current-buffer (get-buffer-create "*Messages*") + (goto-char (point-max)) + (insert ,@timestamp str "\n") + (forward-line (- message-log-max)) + (delete-region (point-min) (point)) + (goto-char (point-max)))) + str) + (gnus-add-timestamp-to-message + (if (or (and (null ,format-string) (null ,args)) + (progn + (setq str (apply 'format ,format-string ,args)) + (zerop (length str)))) + (prog1 + (and ,format-string str) + (message nil)) + (setq time (current-time)) + (message "%s" (concat ,@timestamp str)) + str)) + (t + (apply 'message ,format-string ,args)))))))) + +(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 +timestamp to message." + (gnus-message-with-timestamp-1 format-string args)) + (defun gnus-message (level &rest args) "If LEVEL is lower than `gnus-verbose' print ARGS using `message'. @@ -459,14 +602,17 @@ Guideline for numbers: that take a long time, 7 - not very important messages on stuff, 9 - messages inside loops." (if (<= level gnus-verbose) - (apply 'message args) + (if gnus-add-timestamp-to-message + (apply 'gnus-message-with-timestamp args) + (apply 'message args)) ;; 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-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) @@ -489,7 +635,7 @@ inside loops." (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)) + (let ((ids (gnus-split-references references)) refs) (dolist (id ids) (when (string-match "<[^<>]+>" id) @@ -564,6 +710,10 @@ If N, return the Nth ancestor instead." (defvar gnus-work-buffer " *gnus work*") +(declare-function gnus-get-buffer-create "gnus" (name)) +;; gnus.el requires mm-util. +(declare-function mm-enable-multibyte "mm-util") + (defun gnus-set-work-buffer () "Put point in the empty Gnus work buffer." (if (get-buffer gnus-work-buffer) @@ -586,8 +736,10 @@ If N, return the Nth ancestor instead." 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) (match-string 2 gname)) + (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) @@ -690,9 +842,9 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (defun gnus-write-buffer (file) "Write the current buffer's contents to FILE." - ;; Make sure the directory exists. - (gnus-make-directory (file-name-directory file)) (let ((file-name-coding-system nnmail-pathname-coding-system)) + ;; Make sure the directory exists. + (gnus-make-directory (file-name-directory file)) ;; Write the buffer. (write-region (point-min) (point-max) file nil 'quietly))) @@ -718,12 +870,37 @@ 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 . +(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 string (replace-match "" t t string))) string) +(declare-function gnus-put-text-property "gnus" + (start end property value &optional object)) + (defsubst gnus-put-text-property-excluding-newlines (beg end prop val) "The same as `put-text-property', but don't put this prop on any newlines in the region." (save-match-data @@ -735,6 +912,10 @@ If there's no subdirectory, delete DIRECTORY as well." (setq beg (point))) (gnus-put-text-property beg (point) prop val))))) +(declare-function gnus-overlay-put "gnus" (overlay prop value)) +(declare-function gnus-make-overlay "gnus" + (beg end &optional buffer front-advance rear-advance)) + (defsubst gnus-put-overlay-excluding-newlines (beg end prop val) "The same as `put-text-property', but don't put this prop on any newlines in the region." (save-match-data @@ -775,10 +956,10 @@ If there's no subdirectory, delete DIRECTORY as well." (overlays-at pos))))))) ;;; 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 -;;; similar blows up. Often in Gnus multiple tables/lists need to be -;;; updated at the same time, or information can be lost. +;; 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 +;; similar blows up. Often in Gnus multiple tables/lists need to be +;; updated at the same time, or information can be lost. (defvar gnus-atomic-be-safe t "If t, certain operations will be protected from interruption by C-g.") @@ -797,7 +978,7 @@ variables and then do only the assignment atomically." (put 'gnus-atomic-progn 'lisp-indent-function 0) (defmacro gnus-atomic-progn-assign (protect &rest forms) - "Evaluate FORMS, but insure that the variables listed in PROTECT + "Evaluate FORMS, but ensure that the variables listed in PROTECT are not changed if anything in FORMS signals an error or otherwise non-locally exits. The variables listed in PROTECT are updated atomically. It is safe to use gnus-atomic-progn-assign with long computations. @@ -868,9 +1049,13 @@ with potentially long computations." ;; 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"))) - (defvar rmail-default-rmail-file) - (defvar mm-text-coding-system)) + (autoload 'rmail-maybe-display-summary "rmail")))) + +(defvar rmail-default-rmail-file) +(defvar mm-text-coding-system) + +(declare-function mm-append-to-file "mm-util" + (start end filename &optional codesys inhibit)) (defun gnus-output-to-rmail (filename &optional ask) "Append the current article to an Rmail file named FILENAME." @@ -1008,6 +1193,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 @@ -1019,14 +1211,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) @@ -1054,7 +1238,7 @@ Return the modified alist." `(setq ,alist (delq (,fun ,key ,alist) ,alist)))) (defun gnus-globalify-regexp (re) - "Return a regexp that matches a whole line, iff RE matches a part of it." + "Return a regexp that matches a whole line, if RE matches a part of it." (concat (unless (string-match "^\\^" re) "^.*") re (unless (string-match "\\$$" re) ".*$"))) @@ -1085,9 +1269,16 @@ Return the modified alist." (throw 'found nil))) t)) +;; gnus.el requires mm-util. +(declare-function mm-disable-multibyte "mm-util") + (defun gnus-write-active-file (file hashtb &optional full-names) + ;; `coding-system-for-write' should be `raw-text' or equivalent. (let ((coding-system-for-write nnmail-active-file-coding-system)) (with-temp-file file + ;; The buffer should be in the unibyte mode because group names + ;; are ASCII text or encoded non-ASCII text (i.e., unibyte). + (mm-disable-multibyte) (mapatoms (lambda (sym) (when (and sym @@ -1118,7 +1309,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 @@ -1148,6 +1339,9 @@ Return the modified alist." (pop l2)) l1)))) +(declare-function gnus-add-text-properties "gnus" + (start end properties &optional object)) + (defun gnus-add-text-properties-when (property value start end properties &optional object) "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." @@ -1173,6 +1367,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.) @@ -1187,7 +1388,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.4" + :version "22.1" :group 'gnus-various) (defun gnus-byte-compile (form) @@ -1390,23 +1591,25 @@ CHOICE is a list of the choice char and help message at IDX." (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) - (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))) @@ -1428,6 +1631,25 @@ Return nil otherwise." display)) display))))) +(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. @@ -1478,42 +1700,51 @@ predicate on the elements." (push (pop list1) res))) (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 + (let (plst) + (when (memq 'codename lst) + (push codename plst)) + (when system-v + (push system-v plst)) + (unless (featurep 'mule) + (push "no MULE" plst)) + (when (> (length plst) 0) + (concat + " (" (mapconcat 'identity (reverse plst) ", ") ")"))))) (t emacs-version)))) (defun gnus-rename-file (old-path new-path &optional trim) @@ -1533,8 +1764,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) @@ -1542,7 +1773,35 @@ 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)))))) + +(defalias 'gnus-read-shell-command + (if (fboundp 'read-shell-command) 'read-shell-command 'read-string)) + (provide 'gnus-util) -;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 +;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 ;;; gnus-util.el ends here