X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=8a65702a980e8713cea3545275e1b8c432f849d6;hb=4cacb5f23eb830e6950dba987063f413977708d7;hp=b01d06c28332dbed911744117f7bd7a26abb8cd0;hpb=aa5128c389ce456d803dc54ed86912c6c29ebdaa;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index b01d06c..8a65702 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,5 +1,6 @@ ;;; gnus-util.el --- utility functions for Semi-gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -20,8 +21,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: @@ -39,9 +40,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) @@ -64,6 +68,11 @@ (defalias 'gnus-replace-in-string 'replace-in-string)) ((fboundp 'replace-regexp-in-string) (defun gnus-replace-in-string (string regexp newtext &optional 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))))) (defun gnus-boundp (variable) @@ -307,8 +316,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 @@ -482,12 +491,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." @@ -659,11 +679,11 @@ 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) +(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 (current-buffer)))) + (gnus-bind-print-variables (pp form (or stream (current-buffer))))) (defun gnus-pp-to-string (form) "The same as `pp-to-string'. @@ -708,6 +728,23 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (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))))) + (defun gnus-strip-whitespace (string) "Return STRING stripped of all whitespace." (while (string-match "[\r\n\t ]+" string) @@ -1000,6 +1037,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 @@ -1011,14 +1055,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) @@ -1110,7 +1146,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 @@ -1179,7 +1215,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) @@ -1202,7 +1238,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)) @@ -1471,42 +1507,64 @@ 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) + (unless (featurep 'meadow) + (defalias 'Meadow-version 'ignore))) (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))) + (mule-v (when (and (memq 'mule lst) + (featurep 'mule)) + (concat + " MULE" + (when (boundp 'mule-version) + (concat "/" (symbol-value 'mule-version))) + (when (featurep 'meadow) + (let ((mver (Meadow-version))) + (if (string-match "^Meadow-" mver) + (concat " Meadow/" + (substring mver (match-end 0))))))))) + 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 ")") - ")")) - ""))) - (t emacs-version)))) + "") + mule-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) + ")" + mule-v)) + (t (concat emacs-version mule-v))))) (defun gnus-rename-file (old-path new-path &optional trim) "Rename OLD-PATH as NEW-PATH. If TRIM, recursively delete @@ -1525,8 +1583,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) @@ -1534,6 +1592,12 @@ 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)) + (provide 'gnus-util) ;;; gnus-util.el ends here