From 49a238c7b481ff356fbeb76506a7f960ccd0be96 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Mon, 11 Sep 2000 13:12:03 +0000 Subject: [PATCH] * wl-e21.el (wl-e21-highlight-folder-group-icon): New function. (wl-highlight-folder-current-line): Use it. * wl-folder.el (wl-folder-entity-assign-id): Don't put text props in `id-name'. --- wl/ChangeLog | 8 +++ wl/wl-e21.el | 167 ++++++++++++++++++++++++++++--------------------------- wl/wl-folder.el | 12 ++-- 3 files changed, 98 insertions(+), 89 deletions(-) diff --git a/wl/ChangeLog b/wl/ChangeLog index cf2d245..576e616 100644 --- a/wl/ChangeLog +++ b/wl/ChangeLog @@ -1,3 +1,11 @@ +2000-09-11 Katsumi Yamaoka + + * wl-e21.el (wl-e21-highlight-folder-group-icon): New function. + (wl-highlight-folder-current-line): Use it. + + * wl-folder.el (wl-folder-entity-assign-id): Don't put text props + in `id-name'. + 2000-09-08 Katsumi Yamaoka * wl.el: Require `wl-e21' when Emacs 21 is running. diff --git a/wl/wl-e21.el b/wl/wl-e21.el index 666d4a0..46539f1 100644 --- a/wl/wl-e21.el +++ b/wl/wl-e21.el @@ -197,19 +197,19 @@ (defun wl-e21-insert-image (image &optional string) (unless string (setq string " ")) - (let* ((from (point)) - (to (+ from (length string)))) + (let* ((start (point)) + (end (+ start (length string)))) (if (stringp image) (progn (insert string) - (let ((ovl (make-overlay from to))) + (let ((ovl (make-overlay start end))) (overlay-put ovl 'before-string image) (overlay-put ovl 'evaporate t) - (add-text-properties from to + (add-text-properties start end '(invisible t intangible t rear-nonsticky t)))) (insert-image image string)) - (put-text-property from to 'wl-e21-icon t))) + (put-text-property start end 'wl-e21-icon t))) (defun wl-e21-make-icon-image (icon-string icon-file) (if wl-highlight-folder-with-icon @@ -231,93 +231,94 @@ :file ,icon-file :ascent center)))))) icon-string)) +(eval-when-compile + (defsubst wl-e21-highlight-folder-group-icon (image &optional string-face) + (let ((string (match-string-no-properties 1)) + (start (goto-char (match-beginning 1))) + (inhibit-read-only t)) + (delete-region start (match-end 1)) + (unless (get image 'image) + (put image 'image (wl-e21-make-icon-image + string + (symbol-value + (cdr (assq image wl-folder-toggle-icon-list)))))) + (setq image (get image 'image)) + (wl-e21-insert-image image string) + (when (stringp image) + (put-text-property (line-beginning-position) (line-end-position) + 'face string-face)) + (when wl-use-highlight-mouse-line + (put-text-property start (line-end-position) + 'mouse-face 'highlight))))) + (defun wl-highlight-folder-current-line (&optional numbers) (interactive) (save-excursion - (let ((fld-name (wl-folder-get-folder-name-by-id - (get-text-property (point) 'wl-folder-entity-id))) - type num) - (beginning-of-line) - (when (and fld-name (looking-at "[ \t]+\\([^ \t]+\\)")) + (beginning-of-line) + ;; put an icon + (let (fld-name) + (cond + (;; opened folder group + (looking-at wl-highlight-folder-opened-regexp) + (wl-e21-highlight-folder-group-icon 'wl-folder-opened-image + 'wl-highlight-folder-opened-face)) + (;; closed folder group + (looking-at wl-highlight-folder-closed-regexp) + (wl-e21-highlight-folder-group-icon 'wl-folder-closed-image + 'wl-highlight-folder-closed-face)) + (;; basic folder + (and (setq fld-name (wl-folder-get-folder-name-by-id + (get-text-property (point) 'wl-folder-entity-id))) + (looking-at "[ \t]+\\([^ \t]+\\)")) (goto-char (1- (match-beginning 1))) (let ((inhibit-read-only t)) (if (get-text-property (point) 'wl-e21-icon) (delete-char 1) (forward-char 1)) - (cond - ((string= fld-name wl-trash-folder);; set trash folder icon - (setq num (nth 2 numbers));; number of messages - (wl-e21-insert-image (get (if (or (not num) (zerop num)) - 'wl-folder-trash-empty-image - 'wl-folder-trash-image) - 'image))) - ((string= fld-name wl-draft-folder);; set draft folder icon - (wl-e21-insert-image (get 'wl-folder-draft-image 'image))) - ((string= fld-name wl-queue-folder) - (wl-e21-insert-image (get 'wl-folder-queue-image 'image))) - ((and (setq type (elmo-folder-get-type fld-name)) - (or numbers;; XXX dirty...!! - (not (assoc fld-name wl-folder-group-alist)))) - ;; not group folder. - (wl-e21-insert-image (get (intern (format "wl-folder-%s-image" - type)) - 'image))))))) - (let (fsymbol matched) - (when (and numbers (nth 0 numbers) (nth 1 numbers)) - (setq matched t - fsymbol - (let ((unsync (nth 0 numbers)) - (unread (nth 1 numbers))) - (cond ((and unsync (zerop unsync)) - (if (and unread (zerop unread)) - 'wl-highlight-folder-zero-face - 'wl-highlight-folder-unread-face)) - ((and unsync - (>= unsync wl-folder-many-unsync-threshold)) - 'wl-highlight-folder-many-face) - (t - 'wl-highlight-folder-few-face)))) - (let ((inhibit-read-only t)) - (put-text-property (line-beginning-position) (line-end-position) - 'face fsymbol))) - (let ((highlights '("opened" "closed")) - highlight image) - (while (setq highlight (pop highlights)) - (unless wl-highlight-group-folder-by-numbers - (setq fsymbol (intern (format "wl-highlight-folder-%s-face" - highlight)))) - (beginning-of-line) - (when (looking-at (symbol-value - (intern (format "wl-highlight-folder-%s-regexp" - highlight)))) - (let ((from (match-beginning 1)) - (to (match-end 1)) - (string (match-string-no-properties 1))) - (setq image (intern (format "wl-folder-%s-image" highlight)) - matched t - highlights nil) - (unless (get image 'image) - (put image 'image - (wl-e21-make-icon-image - string - (symbol-value - (cdr (assq image wl-folder-toggle-icon-list)))))) - (let ((inhibit-read-only t)) - (delete-region (goto-char from) to) - (wl-e21-insert-image (get image 'image) string) - (put-text-property (line-beginning-position) - (line-end-position) 'face fsymbol)))))) - (unless matched + (let ((start (point)) + type) + (wl-e21-insert-image + (cond + ((string= fld-name wl-trash-folder);; trash folder + (let ((num (nth 2 numbers)));; number of messages + (get (if (or (not num) (zerop num)) + 'wl-folder-trash-empty-image + 'wl-folder-trash-image) + 'image))) + ((string= fld-name wl-draft-folder);; draft folder + (get 'wl-folder-draft-image 'image)) + ((string= fld-name wl-queue-folder);; queue folder + (get 'wl-folder-queue-image 'image)) + (;; and one of many other folders + (setq type (elmo-folder-get-type fld-name)) + (get (intern (format "wl-folder-%s-image" type)) 'image)))) + (when wl-use-highlight-mouse-line + (put-text-property start (line-end-position) + 'mouse-face 'highlight))))))) + (let ((inhibit-read-only t)) + (if (and numbers (nth 0 numbers) (nth 1 numbers)) + (let ((unsync (nth 0 numbers)) + (unread (nth 1 numbers)) + (inhibit-read-only t)) + (put-text-property + (line-beginning-position) (line-end-position) + 'face + (cond ((and unsync (zerop unsync)) + (if (and unread (zerop unread)) + 'wl-highlight-folder-zero-face + 'wl-highlight-folder-unread-face)) + ((and unsync + (>= unsync wl-folder-many-unsync-threshold)) + 'wl-highlight-folder-many-face) + (t + 'wl-highlight-folder-few-face)))) (beginning-of-line) - (let ((inhibit-read-only t)) - (put-text-property (point) (line-end-position) 'face - (if (looking-at (format "^[ ]*\\(%s\\|%s\\)" - wl-folder-unsubscribe-mark - wl-folder-removed-mark)) - 'wl-highlight-folder-killed-face - 'wl-highlight-folder-unknown-face)))) - (when wl-use-highlight-mouse-line - (wl-highlight-folder-mouse-line))))) + (put-text-property (point) (line-end-position) 'face + (if (looking-at (format "^[ ]*\\(%s\\|%s\\)" + wl-folder-unsubscribe-mark + wl-folder-removed-mark)) + 'wl-highlight-folder-killed-face + 'wl-highlight-folder-unknown-face)))))) (defun wl-highlight-plugged-current-line () (interactive) diff --git a/wl/wl-folder.el b/wl/wl-folder.el index cc5d4c7..0dd4ef7 100644 --- a/wl/wl-folder.el +++ b/wl/wl-folder.el @@ -1261,12 +1261,12 @@ If current line is group folder, all subfolders are marked." (get-text-property 0 'wl-folder-entity-id (car entity)))) + (wl-folder-set-id-name wl-folder-entity-id + (copy-sequence (car entity)) hashtb) (put-text-property 0 (length (car entity)) 'wl-folder-entity-id wl-folder-entity-id - (car entity)) - (wl-folder-set-id-name wl-folder-entity-id - (car entity) hashtb)) + (car entity))) (and entities (wl-push entities entity-stack)) (setq entities (nth 2 entity))) @@ -1275,12 +1275,12 @@ If current line is group folder, all subfolders are marked." (get-text-property 0 'wl-folder-entity-id entity))) + (wl-folder-set-id-name wl-folder-entity-id + (copy-sequence entity) hashtb) (put-text-property 0 (length entity) 'wl-folder-entity-id wl-folder-entity-id - entity) - (wl-folder-set-id-name wl-folder-entity-id - entity hashtb)))) + entity)))) (setq wl-folder-entity-id (+ 1 wl-folder-entity-id)) (unless entities (setq entities (wl-pop entity-stack)))))) -- 1.7.10.4