[Emacs-diffs] Changes to emacs/lisp/gnus/gnus-util.el,v

[Miles Bader]

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Changes by:     Miles Bader <miles>     07/10/28 09:18:40

Index: lisp/gnus/gnus-util.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/gnus-util.el,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -b -r1.49 -r1.50
--- lisp/gnus/gnus-util.el      18 Oct 2007 21:07:57 -0000      1.49
+++ lisp/gnus/gnus-util.el      28 Oct 2007 09:18:30 -0000      1.50
@@ -31,11 +31,10 @@
 ;; Gnus first.
 
 ;; [Unfortunately, it does depend on other parts of Gnus, e.g. the
-;; autoloads below...]
+;; autoloads and defvars below...]
 
 ;;; Code:
 
-(require 'custom)
 (eval-when-compile
   (require 'cl)
   ;; Fixme: this should be a gnus variable, not nnmail-.
@@ -75,25 +74,7 @@
 This is a compatibility function for different Emacsen."
       (replace-regexp-in-string regexp newtext string nil literal)))
    ((fboundp 'replace-in-string)
-    (defalias 'gnus-replace-in-string 'replace-in-string))
-   (t
-    (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."
-      (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)
+    (defalias 'gnus-replace-in-string 'replace-in-string))))
 
 (defun gnus-boundp (variable)
   "Return non-nil if VARIABLE is bound and non-nil."
@@ -128,15 +109,6 @@
         (set symbol nil))
      symbol))
 
-;; Added by Geoffrey T. Dairiki <address@hidden>.  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)))
 
@@ -146,16 +118,6 @@
        (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
@@ -180,7 +142,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)
@@ -235,8 +197,7 @@
   "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)))))
 
@@ -248,7 +209,7 @@
 
 (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)))))
@@ -263,12 +224,15 @@
 
 (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."
@@ -501,6 +465,79 @@
   :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'.
 
@@ -509,7 +546,9 @@
 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'.
@@ -530,12 +569,23 @@
 (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."
@@ -709,11 +759,11 @@
 `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'.
@@ -732,9 +782,9 @@
 
 (defun gnus-write-buffer (file)
   "Write the current buffer's contents to FILE."
+  (let ((file-name-coding-system nnmail-pathname-coding-system))
   ;; Make sure the directory exists.
   (gnus-make-directory (file-name-directory file))
-  (let ((file-name-coding-system nnmail-pathname-coding-system))
     ;; Write the buffer.
     (write-region (point-min) (point-max) file nil 'quietly)))
 
@@ -1149,8 +1199,12 @@
     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
@@ -1236,6 +1290,13 @@
        (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.)
@@ -1350,32 +1411,12 @@
        `(,(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 ": "))
@@ -1616,13 +1657,16 @@
      ((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)
-             ")"))
+             (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)
@@ -1646,6 +1690,11 @@
                         (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)