X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=4c1b32e4ef267dbf65409e8b5caacce8803ac1cd;hb=27688c4fe73986a46e3f2cb9051170f41ef82f4c;hp=09cf62bb803e5028495363979146b248191df151;hpb=04ba5250e9e47ebe40860a0902d4ef6405ca143f;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 09cf62b..4c1b32e 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,5 +1,5 @@ ;;; gnus-util.el --- utility functions for Semi-gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -20,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: @@ -31,20 +31,24 @@ ;; Gnus first. ;; [Unfortunately, it does depend on other parts of Gnus, e.g. the -;; autoloads below...] +;; autoloads and defvars below...] ;;; Code: (eval-when-compile (require 'cl) ;; Fixme: this should be a gnus variable, not nnmail-. - (defvar nnmail-pathname-coding-system)) -(eval-when-compile (require 'static)) + (defvar nnmail-pathname-coding-system) + + ;; Inappropriate references to other parts of Gnus. + (defvar gnus-emphasize-whitespace-regexp) + ) -(require 'custom) (require 'time-date) (require 'netrc) +(eval-when-compile (require 'static)) + (eval-and-compile (autoload 'message-fetch-field "message") (autoload 'gnus-get-buffer-window "gnus-win") @@ -60,20 +64,12 @@ (defalias 'gnus-replace-in-string 'replace-in-string)) ((fboundp 'replace-regexp-in-string) (defun gnus-replace-in-string (string regexp newtext &optional literal) - (replace-regexp-in-string regexp newtext string nil literal))) - (t - (defun gnus-replace-in-string (string regexp newtext &optional literal) - (let ((start 0) tail) - (while (string-match regexp string start) - (setq tail (- (length string) (match-end 0))) - (setq string (replace-match newtext nil literal string)) - (setq start (- (length string) tail)))) - string)))) - -;;; 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) + "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) "Return non-nil if VARIABLE is bound and non-nil." @@ -130,35 +126,6 @@ (funcall (if (stringp buffer) 'get-buffer 'buffer-name) buffer)))) -(static-cond - ((fboundp 'point-at-bol) - (defalias 'gnus-point-at-bol 'point-at-bol)) - ((fboundp 'line-beginning-position) - (defalias 'gnus-point-at-bol 'line-beginning-position)) - (t - (defun gnus-point-at-bol () - "Return point at the beginning of the line." - (let ((p (point))) - (beginning-of-line) - (prog1 - (point) - (goto-char p)))) - )) -(static-cond - ((fboundp 'point-at-eol) - (defalias 'gnus-point-at-eol 'point-at-eol)) - ((fboundp 'line-end-position) - (defalias 'gnus-point-at-eol 'line-end-position)) - (t - (defun gnus-point-at-eol () - "Return point at the end of the line." - (let ((p (point))) - (end-of-line) - (prog1 - (point) - (goto-char p)))) - )) - ;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and ;; XEmacs. In Emacs we don't need to call `make-local-hook' first. ;; It's harmless, though, so the main purpose of this alias is to shut @@ -183,7 +150,7 @@ ;; Delete the current line (and the next N lines). (defmacro gnus-delete-line (&optional n) - `(delete-region (gnus-point-at-bol) + `(delete-region (point-at-bol) (progn (forward-line ,(or n 1)) (point)))) (defun gnus-byte-code (func) @@ -233,8 +200,7 @@ is slower." "Return the value of the header FIELD of current article." (save-excursion (save-restriction - (let ((case-fold-search t) - (inhibit-point-motion-hooks t)) + (let ((inhibit-point-motion-hooks t)) (nnheader-narrow-to-headers) (message-fetch-field field))))) @@ -246,7 +212,7 @@ is slower." (defun gnus-goto-colon () (beginning-of-line) - (let ((eol (gnus-point-at-eol))) + (let ((eol (point-at-eol))) (goto-char (or (text-property-any (point) eol 'gnus-position t) (search-forward ":" eol t) (point))))) @@ -261,12 +227,15 @@ is slower." (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." @@ -518,12 +487,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." @@ -570,13 +550,7 @@ If N, return the Nth ancestor instead." (defun gnus-read-event-char (&optional prompt) "Get the next event." - (let ((event (condition-case nil - (read-event prompt) - ;; `read-event' doesn't allow arguments in Mule 2.3 - (wrong-number-of-arguments - (when prompt - (message "%s" prompt)) - (read-event))))) + (let ((event (read-event prompt))) ;; should be gnus-characterp, but this can't be called in XEmacs anyway (cons (and (numberp event) event) event))) @@ -605,7 +579,8 @@ If N, return the Nth ancestor instead." (set-buffer gnus-work-buffer) (erase-buffer)) (set-buffer (gnus-get-buffer-create gnus-work-buffer)) - (kill-all-local-variables))) + (kill-all-local-variables) + (set-buffer-multibyte t))) (defmacro gnus-group-real-name (group) "Find the real name of a foreign newsgroup." @@ -614,6 +589,15 @@ 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) (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 @@ -659,30 +643,54 @@ 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." (require 'nnmail) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (pathname-coding-system nnmail-pathname-coding-system)) + (let ((file-name-coding-system nnmail-pathname-coding-system)) (when (and directory (not (file-exists-p directory))) (make-directory directory t))) @@ -692,8 +700,7 @@ and `print-level' to nil." "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) - (pathname-coding-system nnmail-pathname-coding-system)) + (let ((file-name-coding-system nnmail-pathname-coding-system)) ;; Write the buffer. (write-region (point-min) (point-max) file nil 'quietly))) @@ -717,6 +724,23 @@ 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))))) + (defun gnus-strip-whitespace (string) "Return STRING stripped of all whitespace." (while (string-match "[\r\n\t ]+" string) @@ -902,8 +926,7 @@ with potentially long computations." ;; Decide whether to append to a file or to an Emacs buffer. (let ((outbuf (get-file-buffer filename))) (if (not outbuf) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (pathname-coding-system nnmail-pathname-coding-system)) + (let ((file-name-coding-system nnmail-pathname-coding-system)) (write-region-as-binary (point-min) (point-max) filename 'append)) ;; File has been visited, in buffer OUTBUF. @@ -974,8 +997,7 @@ with potentially long computations." (insert "\n")) (insert "\n")) (goto-char (point-max)) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (pathname-coding-system nnmail-pathname-coding-system)) + (let ((file-name-coding-system nnmail-pathname-coding-system)) (write-region-as-binary (point-min) (point-max) filename 'append)))) ;; File has been visited, in buffer OUTBUF. @@ -1011,6 +1033,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 @@ -1089,8 +1118,7 @@ Return the modified alist." t)) (defun gnus-write-active-file (file hashtb &optional full-names) - (let ((output-coding-system nnmail-active-file-coding-system) - (coding-system-for-write nnmail-active-file-coding-system)) + (let ((coding-system-for-write nnmail-active-file-coding-system)) (with-temp-file file (mapatoms (lambda (sym) @@ -1122,7 +1150,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 @@ -1191,7 +1219,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) @@ -1214,7 +1242,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)) @@ -1291,32 +1319,12 @@ SPEC is a predicate specifier that contains stuff like `or', `and', `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) (error "Invalid predicate specifier: %s" spec))))) -(defun gnus-local-map-property (map) - "Return a list suitable for a text property list specifying keymap MAP." - (cond - ((featurep 'xemacs) - (list 'keymap map)) - ((>= emacs-major-version 21) - (list 'keymap map)) - (t - (list 'local-map map)))) - -(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate - require-match initial-contents - history default) - "Like `completing-read', allowing for non-existent 7th arg in older XEmacsen." - `(completing-read ,prompt ,table ,predicate ,require-match - ,initial-contents ,history - ,@(if (and (featurep 'xemacs) (< emacs-minor-version 2)) - () - (list default)))) - (defun gnus-completing-read (prompt table &optional predicate require-match history) (when (and history (not (boundp history))) (set history nil)) - (gnus-completing-read-maybe-default + (completing-read (if (symbol-value history) (concat prompt " (" (car (symbol-value history)) "): ") (concat prompt ": ")) @@ -1434,17 +1442,9 @@ CHOICE is a list of the choice char and help message at IDX." (x-focus-frame frame)) ((eq window-system 'w32) (w32-focus-frame frame))) - (when (or (not (boundp 'focus-follows-mouse)) - (symbol-value 'focus-follows-mouse)) + (when focus-follows-mouse (set-mouse-position frame (1- (frame-width frame)) 0))))) -(unless (fboundp 'frame-parameter) - (defalias 'frame-parameter - (lambda (frame parameter) - "Return FRAME's value for parameter PARAMETER. -If FRAME is nil, describe the currently selected frame." - (cdr (assq parameter (frame-parameters frame)))))) - (defun gnus-frame-or-window-display-name (object) "Given a frame or window, return the associated display name. Return nil otherwise." @@ -1511,45 +1511,96 @@ 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) - (concat (format (if (boundp 'MULE) - "Mule/2.3 (based on Emacs %s)" - "Emacs/%s") - (match-string 1 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 +empty directories from OLD-PATH." + (when (file-exists-p old-path) + (let* ((old-dir (file-name-directory old-path)) + (old-name (file-name-nondirectory old-path)) + (new-dir (file-name-directory new-path)) + (new-name (file-name-nondirectory new-path)) + temp) + (gnus-make-directory new-dir) + (rename-file old-path new-path t) + (when trim + (while (progn (setq temp (directory-files old-dir)) + (while (member (car temp) '("." "..")) + (setq temp (cdr temp))) + (= (length temp) 0)) + (delete-directory old-dir) + (setq old-dir (file-name-as-directory + (file-truename + (concat old-dir ".."))))))))) + +(defun gnus-set-file-modes (filename mode) + "Wrapper for set-file-modes." + (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)