Merge from gnus--rel--5.10

[gnus] / lisp / gnus-util.el

diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el
index 11bff31..7e94d4e 100644 (file)
--- a/lisp/gnus-util.el
+++ b/lisp/gnus-util.el
@@ -1,7 +1,7 @@
 ;;; gnus-util.el --- utility functions for Gnus
 
 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006 Free Software Foundation, Inc.
+;;   2005, 2006, 2007 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
@@ -103,7 +103,7 @@ This is a compatibility function for different Emacsen."
 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
 
 (defmacro gnus-intern-safe (string hashtable)
-  "Set hash value.  Arguments are STRING, VALUE, and HASHTABLE."
+  "Get hash value.  Arguments are STRING and HASHTABLE."
   `(let ((symbol (intern ,string ,hashtable)))
      (or (boundp symbol)
         (set symbol nil))
@@ -173,8 +173,13 @@ is slower."
     ;; 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.
-    (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
-      (setq address (substring from (match-beginning 0) (match-end 0))))
+    (cond (;; Check ``<foo@bar>'' first in order to handle the quite common
+          ;; form ``"abc@xyz" <foo@bar>'' (i.e. ``@'' as part of a comment)
+          ;; correctly.
+          (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" from)
+          (setq address (substring from (match-beginning 1) (match-end 1))))
+         ((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
         ;; Linear white space is not required.
@@ -596,8 +601,10 @@ If N, return the Nth ancestor instead."
 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))
+     (if (string-match "^\\([^:+]+\\)\\(?:\\+\\([^:]*\\)\\)?:" gname)
+        (format "%s:%s" (match-string 1 gname) (or
+                                                (match-string 2 gname)
+                                                ""))
        (format "%s:%s" (car gnus-select-method) (cadr gnus-select-method)))))
 
 (defun gnus-make-sort-function (funs)
@@ -1204,6 +1211,13 @@ Return the modified alist."
        (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.)
@@ -1605,6 +1619,25 @@ empty directories from OLD-PATH."
   (defalias 'gnus-set-process-query-on-exit-flag
     'process-kill-without-query))
 
+(if (fboundp 'with-local-quit)
+    (defalias 'gnus-with-local-quit 'with-local-quit)
+  (defmacro gnus-with-local-quit (&rest body)
+    "Execute BODY, allowing quits to terminate BODY but not escape further.
+When a quit terminates BODY, `gnus-with-local-quit' returns nil but
+requests another quit.  That quit will be processed as soon as quitting
+is allowed once again.  (Immediately, if `inhibit-quit' is nil.)"
+    ;;(declare (debug t) (indent 0))
+    `(condition-case nil
+        (let ((inhibit-quit nil))
+          ,@body)
+       (quit (setq quit-flag t)
+            ;; This call is to give a chance to handle quit-flag
+            ;; in case inhibit-quit is nil.
+            ;; Without this, it will not be handled until the next function
+            ;; call, and that might allow it to exit thru a condition-case
+            ;; that intends to handle the quit signal next time.
+            (eval '(ignore nil))))))
+
 (provide 'gnus-util)
 
 ;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49