X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=bb03786f397968f4aa4613fb1ec9f5dabd30f15a;hb=8145852ab9b9e2f1ceea9b433fc6fface47cf6fd;hp=423b287b1c576e0415fe42424a5ba31957f833f3;hpb=66faad5855bdc7a0641cc1cfb8b697a000bf11d0;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 423b287b1..bb03786f3 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,5 +1,5 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -29,14 +29,19 @@ ;; used by Gnus and may be used by any other package without loading ;; Gnus first. +;; [Unfortunately, it does depend on other parts of Gnus, e.g. the +;; autoloads and defvars below...] + ;;; Code: -(require 'custom) (eval-when-compile (require 'cl) ;; Fixme: this should be a gnus variable, not nnmail-. - (defvar nnmail-pathname-coding-system)) -(require 'nnheader) + (defvar nnmail-pathname-coding-system) + + ;; Inappropriate references to other parts of Gnus. + (defvar gnus-emphasize-whitespace-regexp) + ) (require 'time-date) (require 'netrc) @@ -45,7 +50,9 @@ (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 'rmail-show-message "rmail") + (autoload 'nnheader-narrow-to-headers "nnheader") + (autoload 'nnheader-replace-chars-in-string "nnheader")) (eval-and-compile (cond @@ -53,20 +60,7 @@ (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-regexp-in-string regexp newtext string nil literal))))) (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." @@ -104,17 +98,12 @@ ;; 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-functionp (form) - "Return non-nil if FORM is funcallable." - (or (and (symbolp form) (fboundp form)) - (and (listp form) (eq (car form) 'lambda)) - (byte-code-function-p form))) - (defsubst gnus-goto-char (point) (and point (goto-char point))) @@ -124,15 +113,15 @@ (funcall (if (stringp buffer) 'get-buffer 'buffer-name) buffer)))) -(defalias 'gnus-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) - -(defalias 'gnus-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position)) +;; 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 +;; up the byte compiler. +(defalias 'gnus-make-local-hook + (if (eq (get 'make-local-hook 'byte-compile) + 'byte-compile-obsolete) + 'ignore ; Emacs + 'make-local-hook)) ; XEmacs (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -148,7 +137,7 @@ ;; Delete the current line (and the next N lines). (defmacro gnus-delete-line (&optional n) - `(delete-region (progn (beginning-of-line) (point)) + `(delete-region (point-at-bol) (progn (forward-line ,(or n 1)) (point)))) (defun gnus-byte-code (func) @@ -161,6 +150,11 @@ (cons 'progn (cddr fval))))) (defun gnus-extract-address-components (from) + "Extract address components from a From header. +Given an RFC-822 address FROM, extract full name and canonical address. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple +solution than `mail-extract-address-components', which works much better, but +is slower." (let (name address) ;; First find the address - the thing with the @ in it. This may ;; not be accurate in mail addresses, but does the trick most of @@ -193,14 +187,19 @@ "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))))) +(defun gnus-fetch-original-field (field) + "Fetch FIELD from the original version of the current article." + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field field))) + + (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))))) @@ -215,14 +214,16 @@ (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)))))) -(require 'nnheader) (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) @@ -321,19 +322,20 @@ ;; age-depending date representations. (e.g. just the time if it's ;; from today, the day of the week if it's within the last 7 days and ;; the full date if it's older) + (defun gnus-seconds-today () - "Returns the number of seconds passed today" + "Return the number of seconds passed today." (let ((now (decode-time (current-time)))) (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) (defun gnus-seconds-month () - "Returns the number of seconds passed this month" + "Return the number of seconds passed this month." (let ((now (decode-time (current-time)))) (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) (* (- (car (nthcdr 3 now)) 1) 3600 24)))) (defun gnus-seconds-year () - "Returns the number of seconds passed this year" + "Return the number of seconds passed this year." (let ((now (decode-time (current-time))) (days (format-time-string "%j" (current-time)))) (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) @@ -364,30 +366,25 @@ seconds passed since the start of today, of this month, of this year, respectively.") (defun gnus-user-date (messy-date) - "Format the messy-date acording to gnus-user-date-format-alist. + "Format the messy-date according to gnus-user-date-format-alist. Returns \" ? \" if there's bad input or if an other error occurs. Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (condition-case () - (let* ((messy-date (safe-date-to-time messy-date)) - (now (current-time)) + (let* ((messy-date (time-to-seconds (safe-date-to-time messy-date))) + (now (time-to-seconds (current-time))) ;;If we don't find something suitable we'll use this one - (my-format "%b %m '%y") - (high (lsh (- (car now) (car messy-date)) 16))) - (if (and (> high -1) (= (logand high 65535) 0)) - ;;overflow and bad input - (let* ((difference (+ high (- (car (cdr now)) - (car (cdr messy-date))))) - (templist gnus-user-date-format-alist) - (top (eval (caar templist)))) - (while (if (numberp top) (< top difference) (not top)) - (progn - (setq templist (cdr templist)) - (setq top (eval (caar templist))))) - (if (stringp (cdr (car templist))) - (setq my-format (cdr (car templist)))))) - (format-time-string (eval my-format) messy-date)) + (my-format "%b %d '%y")) + (let* ((difference (- now messy-date)) + (templist gnus-user-date-format-alist) + (top (eval (caar templist)))) + (while (if (numberp top) (< top difference) (not top)) + (progn + (setq templist (cdr templist)) + (setq top (eval (caar templist))))) + (if (stringp (cdr (car templist))) + (setq my-format (cdr (car templist))))) + (format-time-string (eval my-format) (seconds-to-time messy-date))) (error " ? "))) -;;end of Frank's code (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." @@ -449,12 +446,13 @@ jabbering all the time." :group 'gnus-start :type 'integer) -;; Show message if message has a lower level than `gnus-verbose'. -;; Guideline for numbers: -;; 1 - error messages, 3 - non-serious error messages, 5 - messages -;; for things that take a long time, 7 - not very important messages -;; on stuff, 9 - messages inside loops. (defun gnus-message (level &rest args) + "If LEVEL is lower than `gnus-verbose' print ARGS using `message'. + +Guideline for numbers: +1 - error messages, 3 - non-serious error messages, 5 - messages for things +that take a long time, 7 - not very important messages on stuff, 9 - messages +inside loops." (if (<= level gnus-verbose) (apply 'message args) ;; We have to do this format thingy here even if the result isn't @@ -476,12 +474,23 @@ jabbering all the time." (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." @@ -567,11 +576,20 @@ 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 FUNC." + "Return a composite sort condition based on the functions in FUNS." (cond ;; Just a simple function. - ((gnus-functionp funs) funs) + ((functionp funs) funs) ;; No functions at all. ((null funs) funs) ;; A list of functions. @@ -585,7 +603,7 @@ If N, return the Nth ancestor instead." (car funs)))) (defun gnus-make-sort-function-1 (funs) - "Return a composite sort condition based on the functions in FUNC." + "Return a composite sort condition based on the functions in FUNS." (let ((function (car funs)) (first 't1) (last 't2)) @@ -596,7 +614,7 @@ If N, return the Nth ancestor instead." (setq function (cadr function) first 't2 last 't1)) - ((gnus-functionp function) + ((functionp function) ;; Do nothing. ) (t @@ -612,24 +630,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." @@ -786,10 +829,31 @@ with potentially long computations." ;;; Functions for saving to babyl/mail files. -(defvar rmail-default-rmail-file) +(eval-when-compile + (condition-case nil + (progn + (require 'rmail) + (autoload 'rmail-update-summary "rmailsum")) + (error + (define-compiler-macro rmail-select-summary (&rest body) + ;; Rmail of the XEmacs version is supplied by the package, and + ;; requires tm and apel packages. However, there may be those + ;; who haven't installed those packages. This macro helps such + ;; people even if they install those packages later. + `(eval '(rmail-select-summary ,@body))) + ;; If there's rmail but there's no tm (or there's apel of the + ;; mainstream, not the XEmacs version), loading rmail of the XEmacs + ;; 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)) + (defun gnus-output-to-rmail (filename &optional ask) "Append the current article to an Rmail file named FILENAME." (require 'rmail) + (require 'mm-util) ;; Most of these codes are borrowed from rmailout.el. (setq filename (expand-file-name filename)) (setq rmail-default-rmail-file filename) @@ -911,7 +975,7 @@ with potentially long computations." (insert "\^_"))) (defun gnus-map-function (funs arg) - "Applies the result of the first function in FUNS to the second, and so on. + "Apply the result of the first function in FUNS to the second, and so on. ARG is passed to the first function." (while funs (setq arg (funcall (pop funs) arg))) @@ -968,7 +1032,7 @@ Return the modified alist." `(setq ,alist (delq (,fun ,key ,alist) ,alist)))) (defun gnus-globalify-regexp (re) - "Returns a regexp that matches a whole line, iff RE matches a part of it." + "Return a regexp that matches a whole line, iff RE matches a part of it." (concat (unless (string-match "^\\^" re) "^.*") re (unless (string-match "\\$$" re) ".*$"))) @@ -1019,6 +1083,33 @@ Return the modified alist." (while (search-backward "\\." nil t) (delete-char 1))))) +;; Fixme: Why not use `with-output-to-temp-buffer'? +(defmacro gnus-with-output-to-file (file &rest body) + (let ((buffer (make-symbol "output-buffer")) + (size (make-symbol "output-buffer-size")) + (leng (make-symbol "output-buffer-length")) + (append (make-symbol "output-buffer-append"))) + `(let* ((,size 131072) + (,buffer (make-string ,size 0)) + (,leng 0) + (,append nil) + (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 + ,append t)))))) + ,@body + (when (> ,leng 0) + (let ((coding-system-for-write 'no-conversion)) + (write-region (substring ,buffer 0 ,leng) nil ,file + ,append 'no-msg)))))) + +(put 'gnus-with-output-to-file 'lisp-indent-function 1) +(put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) + (if (fboundp 'union) (defalias 'gnus-union 'union) (defun gnus-union (l1 l2) @@ -1060,6 +1151,9 @@ Return the modified alist." (remove-text-properties start end properties object)) t)) +;; 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.) (defun gnus-string-equal (x y) "Like `string-equal', except it compares case-insensitively." (and (= (length x) (length y)) @@ -1067,11 +1161,11 @@ Return the modified alist." (string-equal (downcase x) (downcase y))))) (defcustom gnus-use-byte-compile t - "If non-nil, byte-compile crucial run-time codes. -Setting it to nil has no effect after first time running -`gnus-byte-compile'." + "If non-nil, byte-compile crucial run-time code. +Setting it to nil has no effect after the first time `gnus-byte-compile' +is run." :type 'boolean - :version "21.1" + :version "21.4" :group 'gnus-various) (defun gnus-byte-compile (form) @@ -1083,15 +1177,18 @@ Setting it to nil has no effect after first time running (require 'byte-optimize) (error)) (require 'bytecomp) - (defalias 'gnus-byte-compile 'byte-compile) - (byte-compile form)) + (defalias 'gnus-byte-compile + (lambda (form) + (let ((byte-compile-warnings '(unresolved callargs redefine))) + (byte-compile form)))) + (gnus-byte-compile form)) form)) (defun gnus-remassoc (key alist) "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)) @@ -1128,12 +1225,12 @@ If you find some problem with the directory separator character, try (+ 10 (- x ?A))) (- x ?0))) +;; Fixme: Do it like QP. (defun gnus-url-unhex-string (str &optional allow-newlines) - "Remove %XXX embedded spaces, etc in a url. + "Remove %XX, embedded spaces, etc in a url. If optional second argument ALLOW-NEWLINES is non-nil, then allow the decoding of carriage returns and line feeds in the string, which is normally forbidden in URL encoding." - (setq str (or (mm-subst-char-in-string ?+ ? str) "")) (let ((tmp "") (case-fold-search t)) (while (string-match "%[0-9a-f][0-9a-f]" str) @@ -1168,16 +1265,6 @@ 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)))) - (defun gnus-completing-read (prompt table &optional predicate require-match history) (when (and history @@ -1236,10 +1323,11 @@ CHOICE is a list of the choice char and help message at IDX." (save-window-excursion (save-excursion (while (not tchar) - (message "%s (%s?): " + (message "%s (%s): " prompt - (mapconcat (lambda (s) (char-to-string (car s))) - choice "")) + (concat + (mapconcat (lambda (s) (char-to-string (car s))) + choice ", ") ", ?")) (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) @@ -1318,6 +1406,121 @@ Return nil otherwise." display)) display))))) +;; 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. +If there are several sequences, FUNCTION is called with that many arguments, +and mapping stops as soon as the shortest sequence runs out. With just one +sequence, this is like `mapcar'. With several, it is like the Common Lisp +`mapcar' function extended to arbitrary sequence types." + + (if seqs2_n + (let* ((seqs (cons seq1 seqs2_n)) + (cnt 0) + (heads (mapcar (lambda (seq) + (make-symbol (concat "head" + (int-to-string + (setq cnt (1+ cnt)))))) + seqs)) + (result (make-symbol "result")) + (result-tail (make-symbol "result-tail"))) + `(let* ,(let* ((bindings (cons nil nil)) + (heads heads)) + (nconc bindings (list (list result '(cons nil nil)))) + (nconc bindings (list (list result-tail result))) + (while heads + (nconc bindings (list (list (pop heads) (pop seqs))))) + (cdr bindings)) + (while (and ,@heads) + (setcdr ,result-tail (cons (funcall ,function + ,@(mapcar (lambda (h) (list 'car h)) + heads)) + nil)) + (setq ,result-tail (cdr ,result-tail) + ,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads)))) + (cdr ,result))) + `(mapcar ,function ,seq1))) + +(if (fboundp 'merge) + (defalias 'gnus-merge 'merge) + ;; Adapted from cl-seq.el + (defun gnus-merge (type list1 list2 pred) + "Destructively merge lists LIST1 and LIST2 to produce a new list. +Argument TYPE is for compatibility and ignored. +Ordering of the elements is preserved according to PRED, a `less-than' +predicate on the elements." + (let ((res nil)) + (while (and list1 list2) + (if (funcall pred (car list2) (car list1)) + (push (pop list2) res) + (push (pop list1) res))) + (nconc (nreverse res) list1 list2)))) + +(eval-when-compile + (defvar xemacs-codename)) + +(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)))) + (cond + ((eq gnus-user-agent 'gnus) + nil) + ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) + (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)))) + +(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))) + (provide 'gnus-util) +;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 ;;; gnus-util.el ends here