diff lisp/gnus/gnus-group.el @ 110486:1ad1adb298a3

Merge Changes made in Gnus trunk. gnus-html.el (gnus-html-get-image-data): Search also for \r\n\r\n to get the start of data. gnus-html.el: Use gnus-html-encode-url to encode URL. gnus-sum.el (gnus-update-marks): Add sanity check to not delete marks outside the active range. gnus.el: Try to keep the server/method cache unique. gnus-html.el (gnus-html-rescale-image): Use window-inside-pixel-edges rather than window-pixel-edges. gnus-html.el (gnus-html-put-image): Stop using markers. gnus-html.el (gnus-html-image-fetched): Search also for \r\n\r\n to get the start of data. nnimap.el: Expunge IMAP groups by default on article deletion. gnus-int.el (gnus-request-expire-articles): Inhibit the daemon, since this command might take a while. nnimap.el (nnimap-request-list): Set the current nnimap group to nil, since EXAMINE changes it on the server. nnmail.el, nnimap.el: Allow nnimap to just delete 'junk messages when splitting. nnimap.el (nnimap-parse-flags): Make IMAP flags parsing much faster by using `read'. nnimap.el (nnimap-make-process-buffer): Record the server name. gnus-html.el (gnus-html-image-fetched): Only cache if gnus-html-image-automatic-caching is set. gnus-html.el (gnus-html-image-fetched): Check for errors. gnus-start.el (gnus-read-active-for-groups): Only run -request-scan once per method on `g'. nnimap.el (nnimap-request-expire-articles): If nnmail-expiry-wait is immediate, then expire all articles. gnus-group.el (gnus-group-get-icon): Compute icon to return. gnus-group.el (gnus-group-icon-list): Fix bad docstring information. nnimap.el (nnimap-update-info): Fix up various off-by-one errors when syncing flags in nnimap. time-date.el (date-to-time): Speed up date-to-time. gnus-start.el (gnus-get-unread-articles): Don't have `gnus-get-unread-articles-in-group' update info. gnus-group.el: Remove gnus-group-highlight-line from the default hook list. gnus-group.el (gnus-group-highlight-line): Typo fix: beg, not start. gnus-group.el (gnus-group-insert-group-line): Pass the real group name so that it gets the right data. gnus-int.el (gnus-open-server): Add tracing for performance debugging. nnimap.el (nnimap-parse-flags): Parse the data in any order. nnimap.el (nnimap-update-info): Fix up code slightly.

--- a/lisp/gnus/gnus-group.el	Thu Sep 23 01:14:00 2010 +0200
+++ b/lisp/gnus/gnus-group.el	Thu Sep 23 00:30:37 2010 +0000
@@ -292,14 +292,8 @@
   :group 'gnus-exit
   :type 'hook)
 
-(defcustom gnus-group-update-hook '(gnus-group-highlight-line gnus-group-add-icon)
-  "Hook called when a group line is changed.
-The hook will not be called if `gnus-visual' is nil.
-
-The default functions `gnus-group-highlight-line' will highlight
-the line according to the `gnus-group-highlight' variable, and
-`gnus-group-add-icon' will add an icon according to
-`gnus-group-icon-list'"
+(defcustom gnus-group-update-hook nil
+  "Hook called when a group line is changed."
   :group 'gnus-group-visual
   :type 'hook)
 
@@ -429,7 +423,6 @@
 unread: The number of unread articles in the group.
 method: The select method used.
 mailp: Whether it's a mail group or not.
-newsp: Whether it's a news group or not
 level: The level of the group.
 score: The score of the group.
 ticked: The number of ticked articles."
@@ -1579,7 +1572,7 @@
 	      ?m ? ))
 	 (gnus-tmp-moderated-string
 	  (if (eq gnus-tmp-moderated ?m) "(m)" ""))
-         (gnus-tmp-group-icon (propertize " " 'gnus-group-icon t))
+         (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-qualified-group))
 	 (gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
 	 (gnus-tmp-news-method (or (car gnus-tmp-method) ""))
 	 (gnus-tmp-news-method-string
@@ -1626,108 +1619,85 @@
 			      'gnus-tool-bar-update))
     (forward-line -1)
     (when (inline (gnus-visual-p 'group-highlight 'highlight))
-      (gnus-run-hooks 'gnus-group-update-hook))
+      (gnus-group-highlight-line gnus-tmp-group beg end))
+    (gnus-run-hooks 'gnus-group-update-hook)
     (forward-line)
     ;; Allow XEmacs to remove front-sticky text properties.
     (gnus-group-remove-excess-properties)))
 
-(defun gnus-group-highlight-line ()
-  "Highlight the current line according to `gnus-group-highlight'."
-  (let* ((list gnus-group-highlight)
-	 (p (point))
-	 (end (point-at-eol))
-	 ;; now find out where the line starts and leave point there.
-	 (beg (progn (beginning-of-line) (point)))
-	 (group (gnus-group-group-name))
-	 (entry (gnus-group-entry group))
-	 (unread (if (numberp (car entry)) (car entry) 0))
-	 (active (gnus-active group))
-	 (total (if active (1+ (- (cdr active) (car active))) 0))
-	 (info (nth 2 entry))
-	 (method (inline (gnus-server-get-method group (gnus-info-method info))))
-	 (marked (gnus-info-marks info))
-	 (mailp (apply 'append
-		       (mapcar
-			(lambda (x)
-			  (memq x (assoc (symbol-name
-					  (car (or method gnus-select-method)))
-					 gnus-valid-select-methods)))
-			'(mail post-mail))))
-	 (level (or (gnus-info-level info) gnus-level-killed))
-	 (score (or (gnus-info-score info) 0))
-	 (ticked (gnus-range-length (cdr (assq 'tick marked))))
-	 (group-age (gnus-group-timestamp-delta group))
-	 (inhibit-read-only t))
-    ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
-    ;; ======================================================================
-    ;; From: Richard Stallman
-    ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
-    ;; Cc: [e-mail]
-    ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
-    ;; Message-ID: <[e-mail]>
-    ;;
-    ;; [...]
-    ;; The kludge is that the alist elements contain expressions that refer
-    ;; to local variables with short names.  Perhaps write your own tiny
-    ;; evaluator that handles just `and', `or', and numeric comparisons
-    ;; and just a few specific variables.
-    ;; ======================================================================
-    ;;
-    ;; Similar for other evaluated variables.  Grep for risky-local-variable
-    ;; to find them!  -- rsteib
-    ;;
-    ;; Eval the cars of the lists until we find a match.
-    (while (and list
-		(not (eval (caar list))))
-      (setq list (cdr list)))
-    (let ((face (cdar list)))
-      (unless (eq face (get-text-property beg 'face))
-	(gnus-put-text-property-excluding-characters-with-faces
-	 beg end 'face
-	 (setq face (if (boundp face) (symbol-value face) face)))
-	(gnus-extent-start-open beg)))
-    (goto-char p)))
-
-(defun gnus-group-add-icon ()
-  "Add an icon to the current line according to `gnus-group-icon-list'."
-  (save-excursion
-    (let* ((end (line-end-position))
-           ;; now find out where the line starts and leave point there.
-           (beg (line-beginning-position)))
-      (save-restriction
-        (narrow-to-region beg end)
-        (goto-char beg)
-        (let ((mystart (text-property-any beg end 'gnus-group-icon t)))
-          (when mystart
-            (let* ((group (gnus-group-group-name))
-                   (entry (gnus-group-entry group))
-                   (unread (if (numberp (car entry)) (car entry) 0))
-                   (active (gnus-active group))
-                   (total (if active (1+ (- (cdr active) (car active))) 0))
-                   (info (nth 2 entry))
-                   (method (gnus-server-get-method group (gnus-info-method info)))
-                   (marked (gnus-info-marks info))
-                   (mailp (memq 'mail (assoc (symbol-name
-                                              (car (or method gnus-select-method)))
-                                             gnus-valid-select-methods)))
-                   (level (or (gnus-info-level info) gnus-level-killed))
-                   (score (or (gnus-info-score info) 0))
-                   (ticked (gnus-range-length (cdr (assq 'tick marked))))
-                   (group-age (gnus-group-timestamp-delta group))
-                   (inhibit-read-only t)
-                   (list gnus-group-icon-list)
-                   (myend (next-single-property-change
-                           mystart 'gnus-group-icon)))
-              (while (and list
-                          (not (eval (caar list))))
-                (setq list (cdr list)))
-              (when list
-                (put-text-property
-                 mystart myend
-                 'display
-                 (append
-                  (gnus-create-image (expand-file-name (cdar list)))
-                  '(:ascent center)))))))))))
+(defun gnus-group-update-eval-form (group list)
+  "Eval `car' of each element of LIST, and return the first that return t.
+Some value are bound so the form can use them."
+  (when list
+    (let* ((entry (gnus-group-entry group))
+           (unread (if (numberp (car entry)) (car entry) 0))
+           (active (gnus-active group))
+           (total (if active (1+ (- (cdr active) (car active))) 0))
+           (info (nth 2 entry))
+           (method (inline (gnus-server-get-method group (gnus-info-method info))))
+           (marked (gnus-info-marks info))
+           (mailp (apply 'append
+                         (mapcar
+                          (lambda (x)
+                            (memq x (assoc (symbol-name
+                                            (car (or method gnus-select-method)))
+                                           gnus-valid-select-methods)))
+                          '(mail post-mail))))
+           (level (or (gnus-info-level info) gnus-level-killed))
+           (score (or (gnus-info-score info) 0))
+           (ticked (gnus-range-length (cdr (assq 'tick marked))))
+           (group-age (gnus-group-timestamp-delta group)))
+      ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
+      ;; ======================================================================
+      ;; From: Richard Stallman
+      ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
+      ;; Cc: [e-mail]
+      ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
+      ;; Message-ID: <[e-mail]>
+      ;;
+      ;; [...]
+      ;; The kludge is that the alist elements contain expressions that refer
+      ;; to local variables with short names.  Perhaps write your own tiny
+      ;; evaluator that handles just `and', `or', and numeric comparisons
+      ;; and just a few specific variables.
+      ;; ======================================================================
+      ;;
+      ;; Similar for other evaluated variables.  Grep for risky-local-variable
+      ;; to find them!  -- rsteib
+      ;;
+      ;; Eval the cars of the lists until we find a match.
+      (while (and list
+                  (not (eval (caar list))))
+        (setq list (cdr list)))
+      list)))
+
+(defun gnus-group-highlight-line (group beg end)
+  "Highlight the current line according to `gnus-group-highlight'.
+GROUP is current group, and the line to highlight starts at START
+and ends at END."
+  (let ((face (cdar (gnus-group-update-eval-form
+                      group
+                      gnus-group-highlight))))
+    (unless (eq face (get-text-property beg 'face))
+      (let ((inhibit-read-only t))
+        (gnus-put-text-property-excluding-characters-with-faces
+         beg end 'face
+         (if (boundp face) (symbol-value face) face)))
+      (gnus-extent-start-open beg))))
+
+(defun gnus-group-get-icon (group)
+  "Return an icon for GROUP according to `gnus-group-icon-list'."
+  (if gnus-group-icon-list
+      (let ((image-path
+             (cdar (gnus-group-update-eval-form group gnus-group-icon-list))))
+        (if image-path
+            (propertize " "
+                        'display
+                        (append
+                         (gnus-create-image (expand-file-name image-path))
+                         '(:ascent center)))
+          " "))
+    " "))
 
 (defun gnus-group-update-group (group &optional visible-only)
   "Update all lines where GROUP appear.