X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=80c36e209b8e6edd7a83fd1e7fbdc2f2c766434b;hb=599d38f40adb7c4862af916f0372ce9dca39ae12;hp=e2e50a02c747e2150a098b59e3db43cf5ca919a1;hpb=a79d0dfbcf171121be8d01c00176717a8c5a0044;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index e2e50a02c..80c36e209 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, 2004 -;; 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 @@ -9,7 +10,7 @@ ;; 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) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -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,8 +60,11 @@ (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 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. @@ -249,6 +254,16 @@ 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 (symbolp s1) (setq s1 (symbol-name s1))) + (if (symbolp s2) (setq s2 (symbol-name s2))) + (if case-fold-search + (string-lessp (downcase s1) (downcase s2)) + (string-lessp s1 s2))) + ;;; Time functions. (defun gnus-file-newer-than (file date) @@ -304,8 +319,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 @@ -451,6 +466,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.0" ;; 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 +547,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 +580,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) @@ -586,8 +677,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 +783,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))) @@ -701,6 +794,45 @@ 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))))) + +;; 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) @@ -991,6 +1123,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 @@ -1002,14 +1141,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) @@ -1037,7 +1168,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) ".*$"))) @@ -1069,8 +1200,12 @@ Return the modified alist." t)) (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 @@ -1101,7 +1236,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 @@ -1156,6 +1291,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.) @@ -1170,7 +1312,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) @@ -1376,20 +1518,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))) @@ -1411,6 +1552,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. @@ -1462,41 +1623,51 @@ 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 + (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) @@ -1516,8 +1687,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) @@ -1525,6 +1696,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