*** empty log message ***

[gnus] / lisp / gnus-util.el

diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el
index 03aceba..0c22d41 100644 (file)
--- a/lisp/gnus-util.el
+++ b/lisp/gnus-util.el
@@ -1,7 +1,7 @@
 ;;; gnus-util.el --- utility functions for Gnus
 ;;; gnus-util.el --- utility functions for Gnus

-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.

 
 

-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>

 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.
 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.


@@ -30,29 +30,41 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

-(require 'cl)
+(require 'custom)
+(eval-when-compile (require 'cl))

 (require 'nnheader)
 (require 'nnheader)

-(require 'timezone)

 (require 'message)
 (require 'message)

+(require 'time-date)
+
+(eval-and-compile
+  (autoload 'rmail-insert-rmail-file-header "rmail")
+  (autoload 'rmail-count-new-messages "rmail")
+  (autoload 'rmail-show-message "rmail"))
+
+(defun gnus-boundp (variable)
+  "Return non-nil if VARIABLE is bound and non-nil."
+  (and (boundp variable)
+       (symbol-value variable)))

 
 (defmacro gnus-eval-in-buffer-window (buffer &rest forms)
   "Pop to BUFFER, evaluate FORMS, and then return to the original window."
   (let ((tempvar (make-symbol "GnusStartBufferWindow"))
 
 (defmacro gnus-eval-in-buffer-window (buffer &rest forms)
   "Pop to BUFFER, evaluate FORMS, and then return to the original window."
   (let ((tempvar (make-symbol "GnusStartBufferWindow"))

-       (w (make-symbol "w"))
-       (buf (make-symbol "buf")))
+        (w (make-symbol "w"))
+        (buf (make-symbol "buf")))

     `(let* ((,tempvar (selected-window))
     `(let* ((,tempvar (selected-window))

-           (,buf ,buffer)
-           (,w (get-buffer-window ,buf 'visible)))
+            (,buf ,buffer)
+            (,w (get-buffer-window ,buf 'visible)))

        (unwind-protect
        (unwind-protect

-          (progn
-            (if ,w
-                (select-window ,w)
-              (pop-to-buffer ,buf))
-            ,@forms)
-        (select-window ,tempvar)))))
+           (progn
+             (if ,w
+                 (progn
+                   (select-window ,w)
+                   (set-buffer (window-buffer ,w)))
+               (pop-to-buffer ,buf))
+             ,@forms)
+         (select-window ,tempvar)))))

 
 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
 
 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)

-(put 'gnus-eval-in-buffer-window 'lisp-indent-hook 1)

 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
 
 (defmacro gnus-intern-safe (string hashtable)
 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
 
 (defmacro gnus-intern-safe (string hashtable)


@@ -62,12 +74,6 @@
         (set symbol nil))
      symbol))
 
         (set symbol nil))
      symbol))
 

-;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;;   function `substring' might cut on a middle of multi-octet
-;;   character.
-(defun gnus-truncate-string (str width)
-  (substring str 0 width))
-

 ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>.  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".
 ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>.  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".


@@ -79,37 +85,32 @@
 (defsubst gnus-functionp (form)
   "Return non-nil if FORM is funcallable."
   (or (and (symbolp form) (fboundp form))
 (defsubst gnus-functionp (form)
   "Return non-nil if FORM is funcallable."
   (or (and (symbolp form) (fboundp form))

-      (and (listp form) (eq (car form) 'lambda))))
+      (and (listp form) (eq (car form) 'lambda))
+      (byte-code-function-p form)))

 
 (defsubst gnus-goto-char (point)
   (and point (goto-char point)))
 
 (defmacro gnus-buffer-exists-p (buffer)
   `(let ((buffer ,buffer))
 
 (defsubst gnus-goto-char (point)
   (and point (goto-char point)))
 
 (defmacro gnus-buffer-exists-p (buffer)
   `(let ((buffer ,buffer))

-     (and buffer
-         (funcall (if (stringp buffer) 'get-buffer 'buffer-name)
-                  buffer))))
+     (when buffer
+       (funcall (if (stringp buffer) 'get-buffer 'buffer-name)
+               buffer))))

 
 (defmacro gnus-kill-buffer (buffer)
   `(let ((buf ,buffer))
 
 (defmacro gnus-kill-buffer (buffer)
   `(let ((buf ,buffer))

-     (if (gnus-buffer-exists-p buf)
-        (kill-buffer buf))))
-
-(defsubst gnus-point-at-bol ()
-  "Return point at the beginning of the line."
-  (let ((p (point)))
-    (beginning-of-line)
-    (prog1
-       (point)
-      (goto-char p))))
-
-(defsubst gnus-point-at-eol ()
-  "Return point at the end of the line."
-  (let ((p (point)))
-    (end-of-line)
-    (prog1
-       (point)
-      (goto-char p))))
+     (when (gnus-buffer-exists-p buf)
+       (kill-buffer buf))))
+
+(fset 'gnus-point-at-bol
+      (if (fboundp 'point-at-bol)
+         'point-at-bol
+       'line-beginning-position))
+
+(fset 'gnus-point-at-eol
+      (if (fboundp 'point-at-eol)
+         'point-at-eol
+       'line-end-position))

 
 (defun gnus-delete-first (elt list)
   "Delete by side effect the first occurrence of ELT as a member of LIST."
 
 (defun gnus-delete-first (elt list)
   "Delete by side effect the first occurrence of ELT as a member of LIST."


@@ -130,7 +131,7 @@
 
 (defun gnus-byte-code (func)
   "Return a form that can be `eval'ed based on FUNC."
 
 (defun gnus-byte-code (func)
   "Return a form that can be `eval'ed based on FUNC."

-  (let ((fval (symbol-function func)))
+  (let ((fval (indirect-function func)))

     (if (byte-code-function-p fval)
        (let ((flist (append fval nil)))
          (setcar flist 'byte-code)
     (if (byte-code-function-p fval)
        (let ((flist (append fval nil)))
          (setcar flist 'byte-code)


@@ -142,11 +143,10 @@
     ;; 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.
     ;; 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.

-    (if (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
-       (setq address (substring from (match-beginning 0) (match-end 0))))
+    (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
+      (setq address (substring from (match-beginning 0) (match-end 0))))

     ;; Then we check whether the "name <address>" format is used.
     (and address
     ;; Then we check whether the "name <address>" format is used.
     (and address

-        ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>

         ;; Linear white space is not required.
         (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
         (and (setq name (substring from 0 (match-beginning 0)))
         ;; Linear white space is not required.
         (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
         (and (setq name (substring from 0 (match-beginning 0)))


@@ -160,7 +160,6 @@
                                   (1- (match-end 0)))))
        (and (string-match "()" from)
             (setq name address))
                                   (1- (match-end 0)))))
        (and (string-match "()" from)
             (setq name address))

-       ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>.

        ;; XOVER might not support folded From headers.
        (and (string-match "(.*" from)
             (setq name (substring from (1+ (match-beginning 0))
        ;; XOVER might not support folded From headers.
        (and (string-match "(.*" from)
             (setq name (substring from (1+ (match-beginning 0))


@@ -202,8 +201,8 @@
       (setq idx 0))
     ;; Replace all occurrences of `.' with `/'.
     (while (< idx len)
       (setq idx 0))
     ;; Replace all occurrences of `.' with `/'.
     (while (< idx len)

-      (if (= (aref newsgroup idx) ?.)
-         (aset newsgroup idx ?/))
+      (when (= (aref newsgroup idx) ?.)
+       (aset newsgroup idx ?/))

       (setq idx (1+ idx)))
     newsgroup))
 
       (setq idx (1+ idx)))
     newsgroup))
 


@@ -218,42 +217,6 @@
 
 ;;; Time functions.
 
 
 ;;; Time functions.
 

-(defun gnus-days-between (date1 date2)
-  ;; Return the number of days between date1 and date2.
-  (- (gnus-day-number date1) (gnus-day-number date2)))
-
-(defun gnus-day-number (date)
-  (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) )
-                    (timezone-parse-date date))))
-    (timezone-absolute-from-gregorian
-     (nth 1 dat) (nth 2 dat) (car dat))))
-
-(defun gnus-time-to-day (time)
-  "Convert TIME to day number."
-  (let ((tim (decode-time time)))
-    (timezone-absolute-from-gregorian
-     (nth 4 tim) (nth 3 tim) (nth 5 tim))))
-
-(defun gnus-encode-date (date)
-  "Convert DATE to internal time."
-  (let* ((parse (timezone-parse-date date))
-        (date (mapcar (lambda (d) (and d (string-to-int d))) parse))
-        (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3)))))
-    (encode-time (caddr time) (cadr time) (car time)
-                (caddr date) (cadr date) (car date) (nth 4 date))))
-
-(defun gnus-time-minus (t1 t2)
-  "Subtract two internal times."
-  (let ((borrow (< (cadr t1) (cadr t2))))
-    (list (- (car t1) (car t2) (if borrow 1 0))
-         (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
-
-(defun gnus-time-less (t1 t2)
-  "Say whether time T1 is less than time T2."
-  (or (< (car t1) (car t2))
-      (and (= (car t1) (car t2))
-          (< (nth 1 t1) (nth 1 t2)))))
-

 (defun gnus-file-newer-than (file date)
   (let ((fdate (nth 5 (file-attributes file))))
     (or (> (car fdate) (car date))
 (defun gnus-file-newer-than (file date)
   (let ((fdate (nth 5 (file-attributes file))))
     (or (> (car fdate) (car date))


@@ -275,16 +238,15 @@
   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
 
 (put 'gnus-define-keys 'lisp-indent-function 1)
   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
 
 (put 'gnus-define-keys 'lisp-indent-function 1)

-(put 'gnus-define-keys 'lisp-indent-hook 1)

 (put 'gnus-define-keys-safe 'lisp-indent-function 1)
 (put 'gnus-define-keys-safe 'lisp-indent-function 1)

-(put 'gnus-define-keys-safe 'lisp-indent-hook 1)

 (put 'gnus-local-set-keys 'lisp-indent-function 1)
 (put 'gnus-local-set-keys 'lisp-indent-function 1)

-(put 'gnus-local-set-keys 'lisp-indent-hook 1)

 
 (defmacro gnus-define-keymap (keymap &rest plist)
   "Define all keys in PLIST in KEYMAP."
   `(gnus-define-keys-1 ,keymap (quote ,plist)))
 
 
 (defmacro gnus-define-keymap (keymap &rest plist)
   "Define all keys in PLIST in KEYMAP."
   `(gnus-define-keys-1 ,keymap (quote ,plist)))
 

+(put 'gnus-define-keymap 'lisp-indent-function 1)
+

 (defun gnus-define-keys-1 (keymap plist &optional safe)
   (when (null keymap)
     (error "Can't set keys in a null keymap"))
 (defun gnus-define-keys-1 (keymap plist &optional safe)
   (when (null keymap)
     (error "Can't set keys in a null keymap"))


@@ -307,7 +269,7 @@
 
 (defun gnus-completing-read (default prompt &rest args)
   ;; Like `completing-read', except that DEFAULT is the default argument.
 
 (defun gnus-completing-read (default prompt &rest args)
   ;; Like `completing-read', except that DEFAULT is the default argument.

-  (let* ((prompt (if default 
+  (let* ((prompt (if default

                     (concat prompt " (default " default ") ")
                   (concat prompt " ")))
         (answer (apply 'completing-read prompt args)))
                     (concat prompt " (default " default ") ")
                   (concat prompt " ")))
         (answer (apply 'completing-read prompt args)))


@@ -327,34 +289,36 @@
       (yes-or-no-p prompt)
     (message "")))
 
       (yes-or-no-p prompt)
     (message "")))
 

-;; I suspect there's a better way, but I haven't taken the time to do
-;; it yet. -erik selberg@cs.washington.edu

 (defun gnus-dd-mmm (messy-date)
 (defun gnus-dd-mmm (messy-date)

-  "Return a string like DD-MMM from a big messy string"
-  (let ((datevec (condition-case () (timezone-parse-date messy-date) 
-                  (error nil))))
-    (if (not datevec)
-       "??-???"
-      (format "%2s-%s"
-             (condition-case ()
-                 ;; Make sure leading zeroes are stripped.
-                 (number-to-string (string-to-number (aref datevec 2)))
-               (error "??"))
-             (capitalize
-              (or (car
-                   (nth (1- (string-to-number (aref datevec 1)))
-                        timezone-months-assoc))
-                  "???"))))))
-
-(defun gnus-date-iso8601 (header)
-  "Convert the date field in HEADER to YYMMDDTHHMMSS"
+  "Return a string like DD-MMM from a big messy string."
+  (format-time-string "%d-%b" (safe-date-to-time messy-date)))
+
+(defmacro gnus-date-get-time (date)
+  "Convert DATE string to Emacs time.
+Cache the result as a text property stored in DATE."
+  ;; Either return the cached value...
+  `(let ((d ,date))
+     (if (equal "" d)
+        '(0 0)
+       (or (get-text-property 0 'gnus-time d)
+          ;; or compute the value...
+          (let ((time (safe-date-to-time d)))
+            ;; and store it back in the string.
+            (put-text-property 0 1 'gnus-time time d)
+            time)))))
+
+(defsubst gnus-time-iso8601 (time)
+  "Return a string of TIME in YYMMDDTHHMMSS format."
+  (format-time-string "%Y%m%dT%H%M%S" time))
+
+(defun gnus-date-iso8601 (date)
+  "Convert the DATE to YYMMDDTHHMMSS."

   (condition-case ()
   (condition-case ()

-      (format-time-string "%Y%m%dT%H%M%S"
-                         (nnmail-date-to-time (mail-header-date header)))
+      (gnus-time-iso8601 (gnus-date-get-time date))

     (error "")))
 
 (defun gnus-mode-string-quote (string)
     (error "")))
 
 (defun gnus-mode-string-quote (string)

-  "Quote all \"%\" in STRING."
+  "Quote all \"%\"'s in STRING."

   (save-excursion
     (gnus-set-work-buffer)
     (insert string)
   (save-excursion
     (gnus-set-work-buffer)
     (insert string)


@@ -363,25 +327,31 @@
       (insert "%"))
     (buffer-string)))
 
       (insert "%"))
     (buffer-string)))
 

-;; Make a hash table (default and minimum size is 255).
+;; Make a hash table (default and minimum size is 256).

 ;; Optional argument HASHSIZE specifies the table size.
 (defun&nb