X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=b01d06c28332dbed911744117f7bd7a26abb8cd0;hb=8047583c8c86a5c6a61bddc27b391042e39e1ce5;hp=d3bad273a3afdf21312530217ef23e29a0b7be56;hpb=d1b6d13953a652e136e4f86647dc1935cc7997b1;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el
index d3bad27..b01d06c 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
 ;;        Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -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,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."
@@ -130,35 +121,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 +145,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 +195,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 +207,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 +222,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."
@@ -570,13 +534,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 +563,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 +573,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,24 +627,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)
+  "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))))
+
+(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."
@@ -1186,7 +1179,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 "21.4"
   :group 'gnus-various)
 
 (defun gnus-byte-compile (form)
@@ -1286,32 +1279,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 ": "))
@@ -1429,17 +1402,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."
@@ -1521,7 +1486,7 @@ predicate on the elements."
      ((eq gnus-user-agent 'gnus)
       nil)
      ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
-      (concat "Emacs/%s" (match-string 1 emacs-version)
+      (concat "Emacs/" (match-string 1 emacs-version)
 	      (if system-v
 		  (concat " (" system-v ")")
 		"")))
@@ -1543,6 +1508,32 @@ predicate on the elements."
 	 "")))
      (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)
 
 ;;; gnus-util.el ends here