X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-thread.el;h=9c82126a4bbe0bbbae24d7ff46e0401b4d7c1a9c;hb=a188e316446f771a0900c8e05026e39b224eb0f9;hp=1dda0725cdeffb49cdc55232baa56d9897713ee9;hpb=10a95fa561ec82f555499e359e703a69eaecbad5;p=elisp%2Fwanderlust.git diff --git a/wl/wl-thread.el b/wl/wl-thread.el index 1dda072..9c82126 100644 --- a/wl/wl-thread.el +++ b/wl/wl-thread.el @@ -1,10 +1,10 @@ -;;; wl-thread.el -- Thread display modules for Wanderlust. +;;; wl-thread.el --- Thread display modules for Wanderlust. -;; Copyright 1998,1999,2000 Yuuichi Teranishi -;; Masahiro MURATA +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Masahiro MURATA ;; Author: Yuuichi Teranishi -;; Masahiro MURATA +;; Masahiro MURATA ;; Keywords: mail, net news ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -26,86 +26,40 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'wl-summary) (require 'wl-highlight) +(eval-when-compile (require 'cl)) ;; buffer local variables. ;;(defvar wl-thread-top-entity '(nil t nil nil)) ; top entity -(defvar wl-thread-tops nil) ; top number list (number) +(defvar wl-thread-tops nil) ; top number list (number) (defvar wl-thread-entities nil) -(defvar wl-thread-entity-list nil) ; entity list -(defvar wl-thread-entity-hashtb nil) ; obarray -(defvar wl-thread-indent-regexp nil) +(defvar wl-thread-entity-list nil) ; entity list +(defvar wl-thread-entity-hashtb nil) ; obarray (make-variable-buffer-local 'wl-thread-entity-hashtb) (make-variable-buffer-local 'wl-thread-entities) ; ".wl-thread-entity" (make-variable-buffer-local 'wl-thread-entity-list) ; ".wl-thread-entity-list" -(make-variable-buffer-local 'wl-thread-entity-cur) -(make-variable-buffer-local 'wl-thread-indent-regexp) ;;; global flag (defvar wl-thread-insert-force-opened nil) ;;;;;; each entity is (number opened-or-not children parent) ;;;;;;; -(defun wl-meaning-of-mark (mark) - (if (not (elmo-folder-plugged-p wl-summary-buffer-folder-name)) - (cond - ((string= mark wl-summary-unread-cached-mark) - 'unread) - ((string= mark wl-summary-important-mark) - 'important)) - (cond - ((string= mark wl-summary-new-mark) - 'new) - ((or (string= mark wl-summary-unread-uncached-mark) - (string= mark wl-summary-unread-cached-mark)) - 'unread) - ((string= mark wl-summary-important-mark) - 'important)))) - -(defun wl-thread-next-mark-p (mark next) - (cond ((not (elmo-folder-plugged-p wl-summary-buffer-folder-name)) - (or (string= mark wl-summary-unread-cached-mark) - (string= mark wl-summary-important-mark))) - ((eq next 'new) - (string= mark wl-summary-new-mark)) - ((eq next 'unread) - (or (string= mark wl-summary-unread-uncached-mark) - (string= mark wl-summary-unread-cached-mark) - (string= mark wl-summary-new-mark))) - (t - (or (string= mark wl-summary-unread-uncached-mark) - (string= mark wl-summary-unread-cached-mark) - (string= mark wl-summary-new-mark) - (string= mark wl-summary-important-mark))))) - -(defun wl-thread-next-failure-mark-p (mark next) - (cond ((not (elmo-folder-plugged-p wl-summary-buffer-folder-name)) - (string= mark wl-summary-unread-cached-mark)) - ((or (eq next 'new) - (eq next 'unread)) - (or (string= mark wl-summary-unread-uncached-mark) - (string= mark wl-summary-unread-cached-mark) - (string= mark wl-summary-new-mark) - (string= mark wl-summary-important-mark))) - (t t))) - (defun wl-thread-resume-entity (fld) (let (entities top-list) (setq entities (wl-summary-load-file-object (expand-file-name wl-thread-entity-file - (elmo-msgdb-expand-path fld)))) + (elmo-folder-msgdb-path fld)))) (setq top-list (wl-summary-load-file-object (expand-file-name wl-thread-entity-list-file - (elmo-msgdb-expand-path fld)))) - (current-buffer) + (elmo-folder-msgdb-path fld)))) (message "Resuming thread structure...") ;; set obarray value. (setq wl-thread-entity-hashtb (elmo-make-hash (* (length entities) 2))) @@ -116,8 +70,48 @@ (elmo-set-hash-val (format "#%d" (car (car entities))) (car entities) wl-thread-entity-hashtb) (setq entities (cdr entities))) + (wl-thread-make-number-list) (message "Resuming thread structure...done"))) +(defun wl-thread-make-number-list () + "Make `wl-summary-buffer-number-list', a list of message numbers." + (let* ((node (wl-thread-get-entity (car wl-thread-entity-list))) + (children (wl-thread-entity-get-children node)) + parent sibling) + (setq wl-summary-buffer-number-list (list (car wl-thread-entity-list))) + (while children + (wl-thread-entity-make-number-list-from-children + (wl-thread-get-entity (car children))) + (setq children (cdr children))) + (while node + (setq parent (wl-thread-entity-get-parent-entity node) + sibling (wl-thread-entity-get-younger-brothers + node parent)) + (while sibling + (wl-thread-entity-make-number-list-from-children + (wl-thread-get-entity (car sibling))) + (setq sibling (cdr sibling))) + (setq node parent)) + (setq wl-summary-buffer-number-list (nreverse + wl-summary-buffer-number-list)))) + +(defun wl-thread-entity-make-number-list-from-children (entity) + (let ((msgs (list (car entity))) + msgs-stack children) + (while msgs + (setq wl-summary-buffer-number-list (cons (car entity) + wl-summary-buffer-number-list)) + (setq msgs (cdr msgs)) + (setq children (wl-thread-entity-get-children entity)) + (if children + (progn + (wl-push msgs msgs-stack) + (setq msgs children)) + (unless msgs + (while (and (null msgs) msgs-stack) + (setq msgs (wl-pop msgs-stack))))) + (setq entity (wl-thread-get-entity (car msgs)))))) + (defun wl-thread-save-entity (dir) (wl-thread-save-entities dir) (wl-thread-save-top-list dir)) @@ -125,7 +119,8 @@ (defun wl-thread-save-top-list (dir) (let ((top-file (expand-file-name wl-thread-entity-list-file dir)) (entity wl-thread-entity-list) - (tmp-buffer (get-buffer-create " *wl-thread-save-top-list*"))) + (tmp-buffer (get-buffer-create " *wl-thread-save-top-list*")) + print-length) (save-excursion (set-buffer tmp-buffer) (erase-buffer) @@ -138,7 +133,8 @@ (defun wl-thread-save-entities (dir) (let ((top-file (expand-file-name wl-thread-entity-file dir)) (entities wl-thread-entities) - (tmp-buffer (get-buffer-create " *wl-thread-save-entities*"))) + (tmp-buffer (get-buffer-create " *wl-thread-save-entities*")) + print-length print-level) (save-excursion (set-buffer tmp-buffer) (erase-buffer) @@ -192,11 +188,24 @@ (car entity)) (wl-append wl-thread-entity-list (list (car entity))) (setq wl-thread-entities (cons entity wl-thread-entities)) + (setq wl-summary-buffer-number-list + (nconc wl-summary-buffer-number-list (list (car entity)))) (elmo-set-hash-val (format "#%d" (car entity)) entity wl-thread-entity-hashtb))) (defsubst wl-thread-entity-insert-as-children (to entity) - (let ((children (nth 2 to))) + (let ((children (wl-thread-entity-get-children to)) + curp curc) + (setq curp to) + (elmo-list-insert wl-summary-buffer-number-list + (wl-thread-entity-get-number entity) + (progn + (while (setq curc + (wl-thread-entity-get-children curp)) + (setq curp (wl-thread-get-entity + (nth (- (length curc) 1) + curc)))) + (wl-thread-entity-get-number curp))) (setcar (cddr to) (wl-append children (list (car entity)))) (setq wl-thread-entities (cons entity wl-thread-entities)) @@ -252,96 +261,15 @@ "If parent of ENTITY is invisible, the top invisible ancestor entity of ENTITY is returned." (let ((cur-entity entity) - ret-val) + top) (catch 'done (while (setq cur-entity (wl-thread-entity-get-parent-entity cur-entity)) (if (null (wl-thread-entity-get-number cur-entity)) - ;; top!! - (progn - ;;(setq ret-val nil) - (throw 'done nil)) + (throw 'done nil) (when (not (wl-thread-entity-get-opened cur-entity)) - ;; not opened!! - (setq ret-val cur-entity))))) - ;; top of closed entity in the path. - ret-val)) - -(defun wl-thread-entity-get-mark (number) - (let ((mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb)) - mark) - (setq mark (cadr (assq number mark-alist))) - (if (string= mark wl-summary-read-uncached-mark) - () - mark))) - -(defun wl-thread-meaning-alist-get-result (meaning-alist) - (let ((malist meaning-alist) - ret-val) - (catch 'done - (while malist - (if (setq ret-val (cdr (car malist))) - (throw 'done ret-val)) - (setq malist (cdr malist)))))) - -(defun wl-thread-entity-check-prev-mark (entity prev-marks) - "Check prev mark. Result is stored in PREV-MARK." - (let ((msgs (list (car entity))) - (succeed-list (car prev-marks)) - (failure-list (cdr prev-marks)) - msgs-stack children - mark meaning success failure parents) - (catch 'done - (while msgs - (if (and (not (memq (car msgs) parents)) - (setq children (reverse (wl-thread-entity-get-children entity)))) - (progn - (wl-append parents (list (car msgs))) - (wl-push msgs msgs-stack) - (setq msgs children)) - (if (setq mark (wl-thread-entity-get-mark (car entity))) - (if (setq meaning (wl-meaning-of-mark mark)) - (if (setq success (assq meaning succeed-list)) - (progn - (setcdr success entity) - (throw 'done nil)) - (setq failure (assq meaning failure-list)) - (unless (cdr failure) - (setcdr (assq meaning failure-list) entity))))) - (setq msgs (cdr msgs))) - (unless msgs - (while (and (null msgs) msgs-stack) - (setq msgs (wl-pop msgs-stack)))) - (setq entity (wl-thread-get-entity (car msgs))))))) - -(defun wl-thread-entity-check-next-mark (entity next-marks) - "Check next mark. Result is stored in NEXT-MARK." - (let ((msgs (list (car entity))) - (succeed-list (car next-marks)) - (failure-list (cdr next-marks)) - msgs-stack children - mark meaning success failure) - (catch 'done - (while msgs - (if (setq mark (wl-thread-entity-get-mark (car entity))) - (if (setq meaning (wl-meaning-of-mark mark)) - (if (setq success (assq meaning succeed-list)) - (progn - (setcdr success entity) - (throw 'done nil)) - (setq failure (assq meaning failure-list)) - (unless (cdr failure) - (setcdr (assq meaning failure-list) entity))))) - (setq msgs (cdr msgs)) - (setq children (wl-thread-entity-get-children entity)) - (if children - (progn - (wl-push msgs msgs-stack) - (setq msgs children)) - (unless msgs - (while (and (null msgs) msgs-stack) - (setq msgs (wl-pop msgs-stack))))) - (setq entity (wl-thread-get-entity (car msgs))))))) + (setq top cur-entity))))) + top)) (defun wl-thread-entity-get-nearly-older-brother (entity &optional parent) (let ((brothers (wl-thread-entity-get-older-brothers entity parent))) @@ -349,12 +277,11 @@ ENTITY is returned." (car (last brothers))))) (defun wl-thread-entity-get-older-brothers (entity &optional parent) - (let* ((parent (or parent - (wl-thread-entity-get-parent-entity entity))) - (brothers (wl-thread-entity-get-children parent)) - ret-val) + (let ((parent (or parent + (wl-thread-entity-get-parent-entity entity))) + brothers ret-val) (if parent - brothers + (setq brothers (wl-thread-entity-get-children parent)) (setq brothers wl-thread-entity-list)) (while (and brothers (not (eq (wl-thread-entity-get-number entity) @@ -373,282 +300,70 @@ ENTITY is returned." ;; top!! (cdr (memq (car entity) wl-thread-entity-list))))) -(defun wl-thread-entity-check-prev-mark-from-older-brother (entity prev-marks) - (let* (older-brother) - (catch 'done - (while entity - (setq older-brother - (reverse (wl-thread-entity-get-older-brothers entity))) - ;; check itself - (let ((succeed-list (car prev-marks)) - (failure-list (cdr prev-marks)) - mark meaning success failure) - (if (setq mark (wl-thread-entity-get-mark (car entity))) - (if (setq meaning (wl-meaning-of-mark mark)) - (if (setq success (assq meaning succeed-list)) - (progn - (setcdr success entity) - (throw 'done nil)) - (setq failure (assq meaning failure-list)) - (unless (cdr failure) - (setcdr (assq meaning failure-list) entity)))))) - ;; check older brothers - (while older-brother - (wl-thread-entity-check-prev-mark (wl-thread-get-entity - (car older-brother)) - prev-marks) - (if (wl-thread-meaning-alist-get-result - (car prev-marks)) - (throw 'done nil)) - (setq older-brother (cdr older-brother))) - (setq entity (wl-thread-entity-get-parent-entity entity)))))) - -(defun wl-thread-entity-get-prev-marked-entity (entity prev-marks) - (let ((older-brothers (reverse - (wl-thread-entity-get-older-brothers entity))) - marked) - (or (catch 'done - (while older-brothers - (wl-thread-entity-check-prev-mark - (wl-thread-get-entity (car older-brothers)) prev-marks) - (if (setq marked - (wl-thread-meaning-alist-get-result - (car prev-marks))) - (throw 'done marked)) - (setq older-brothers (cdr older-brothers)))) - (wl-thread-entity-check-prev-mark-from-older-brother - (wl-thread-entity-get-parent-entity entity) prev-marks) - (if (setq marked - (wl-thread-meaning-alist-get-result - (car prev-marks))) - marked - (if (setq marked - (wl-thread-meaning-alist-get-result - (cdr prev-marks))) - marked))))) - -(defun wl-thread-get-prev-unread (msg &optional hereto) - (let ((cur-entity (wl-thread-get-entity msg)) - (prev-marks (cond ((eq wl-summary-move-order 'new) - (cons (list (cons 'new nil)) - (list (cons 'unread nil) - (cons 'important nil)))) - ((eq wl-summary-move-order 'unread) - (cons (list (cons 'unread nil) - (cons 'new nil)) - (list (cons 'important nil)))) - (t - (cons (list (cons 'unread nil) - (cons 'new nil) - (cons 'important nil)) - nil)))) - mark ret-val) - (if hereto - (when (wl-thread-next-mark-p (setq mark - (wl-thread-entity-get-mark - (car cur-entity))) - (caaar prev-marks)) - ;;(setq mark (cons cur-entity - ;;(wl-thread-entity-get-mark cur-entity))) - (setq ret-val msg))) - (when (and (not ret-val) - (or (setq cur-entity - (wl-thread-entity-get-prev-marked-entity - cur-entity prev-marks)) - (and hereto mark))) - (if (and hereto - (catch 'done - (let ((success-list (car prev-marks))) - (while success-list - (if (cdr (car success-list)) - (throw 'done nil)) - (setq success-list (cdr success-list))) - t)) - (wl-thread-next-failure-mark-p mark (caaar prev-marks))) - (setq ret-val msg) - (when cur-entity - (setq ret-val (car cur-entity))))) - ret-val)) - -(defun wl-thread-jump-to-prev-unread (&optional hereto) - "If prev unread is a children of a closed message. -The closed parent will be opened." - (interactive "P") - (let ((msg (wl-thread-get-prev-unread - (wl-summary-message-number) hereto))) - (when msg - (wl-thread-entity-force-open (wl-thread-get-entity msg)) - (wl-summary-jump-to-msg msg) - t))) - (defun wl-thread-jump-to-msg (&optional number) (interactive) (let ((num (or number - (string-to-int - (read-from-minibuffer "Jump to Message(No.): "))))) + (string-to-int + (read-from-minibuffer "Jump to Message(No.): "))))) (wl-thread-entity-force-open (wl-thread-get-entity num)) (wl-summary-jump-to-msg num))) -(defun wl-thread-get-next-unread (msg &optional hereto) - (let ((cur-entity (wl-thread-get-entity msg)) - (next-marks (cond ((not (elmo-folder-plugged-p - wl-summary-buffer-folder-name)) - (cons (list (cons 'unread nil)) - (list (cons 'important nil)))) - ((eq wl-summary-move-order 'new) - (cons (list (cons 'new nil)) - (list (cons 'unread nil) - (cons 'important nil)))) - ((eq wl-summary-move-order 'unread) - (cons (list (cons 'unread nil) - (cons 'new nil)) - (list (cons 'important nil)))) - (t - (cons (list (cons 'unread nil) - (cons 'new nil) - (cons 'important nil)) - nil)))) - mark ret-val) - (if hereto - (when (wl-thread-next-mark-p (setq mark - (wl-thread-entity-get-mark - (car cur-entity))) - (caaar next-marks)) - (setq ret-val msg))) - (when (and (not ret-val) - (or (setq cur-entity - (wl-thread-entity-get-next-marked-entity - cur-entity next-marks)) - (and hereto mark))) - (if (and hereto - ;; all success-list is nil - (catch 'done - (let ((success-list (car next-marks))) - (while success-list - (if (cdr (car success-list)) - (throw 'done nil)) - (setq success-list (cdr success-list))) - t)) - (wl-thread-next-failure-mark-p mark (caaar next-marks))) - (setq ret-val msg) - (when cur-entity - (setq ret-val (car cur-entity))))) - ret-val)) - -(defun wl-thread-jump-to-next-unread (&optional hereto) - "If next unread is a children of a closed message. -The closed parent will be opened." - (interactive "P") - (let ((msg (wl-thread-get-next-unread - (wl-summary-message-number) hereto))) - (when msg - (wl-thread-entity-force-open (wl-thread-get-entity msg)) - (wl-summary-jump-to-msg msg) - t))) - (defun wl-thread-close-all () "Close all top threads." (interactive) (message "Closing all threads...") - (let ((entities wl-thread-entity-list) - (cur 0) - (len (length wl-thread-entity-list))) - (while entities - (when (and (wl-thread-entity-get-opened (wl-thread-get-entity - (car entities))) - (wl-thread-entity-get-children (wl-thread-get-entity - (car entities)))) - (wl-summary-jump-to-msg (car entities)) - (wl-thread-open-close)) - (when (> len elmo-display-progress-threshold) - (setq cur (1+ cur)) - (if (or (zerop (% cur 5)) (= cur len)) - (elmo-display-progress - 'wl-thread-close-all "Closing all threads..." - (/ (* cur 100) len)))) - (setq entities (cdr entities)))) - (message "Closing all threads...done") - (goto-char (point-max))) + (save-excursion + (let ((entities wl-thread-entity-list) + (cur 0) + (len (length wl-thread-entity-list))) + (while entities + (when (and (wl-thread-entity-get-opened (wl-thread-get-entity + (car entities))) + (wl-thread-entity-get-children (wl-thread-get-entity + (car entities)))) + (wl-summary-jump-to-msg (car entities)) + (wl-thread-open-close)) + (when (> len elmo-display-progress-threshold) + (setq cur (1+ cur)) + (if (or (zerop (% cur 5)) (= cur len)) + (elmo-display-progress + 'wl-thread-close-all "Closing all threads..." + (/ (* cur 100) len)))) + (setq entities (cdr entities))))) + (message "Closing all threads...done")) (defun wl-thread-open-all () "Open all threads." (interactive) (message "Opening all threads...") - (let ((entities wl-thread-entity-list) - (cur 0) - (len (length wl-thread-entity-list))) - (while entities - (if (not (wl-thread-entity-get-opened (wl-thread-get-entity - (car entities)))) - (wl-thread-entity-force-open (wl-thread-get-entity - (car entities)))) - (when (> len elmo-display-progress-threshold) - (setq cur (1+ cur)) - (if (or (zerop (% cur 5)) (= cur len)) - (elmo-display-progress - 'wl-thread-open-all "Opening all threads..." - (/ (* cur 100) len)))) - (setq entities (cdr entities)))) - (message "Opening all threads...done") - (goto-char (point-max))) + (save-excursion + (goto-char (point-min)) + (let ((len (count-lines (point-min) (point-max))) + (cur 0) + entity) + (while (not (eobp)) + (if (wl-thread-entity-get-opened + (setq entity (wl-thread-get-entity + (wl-summary-message-number)))) + (forward-line 1) + (wl-thread-force-open) + (wl-thread-goto-bottom-of-sub-thread)) + (when (> len elmo-display-progress-threshold) + (setq cur (1+ cur)) + (elmo-display-progress + 'wl-thread-open-all "Opening all threads..." + (/ (* cur 100) len))))) + ;; Make sure to be 100%. + (elmo-display-progress + 'wl-thread-open-all "Opening all threads..." + 100)) + (message "Opening all threads...done")) (defun wl-thread-open-all-unread () (interactive) - (let ((mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb)) - mark) - (while mark-alist - (if (setq mark (nth 1 (car mark-alist))) - (if (or (string= mark wl-summary-unread-uncached-mark) - (string= mark wl-summary-unread-cached-mark) - (string= mark wl-summary-new-mark) - (string= mark wl-summary-important-mark)) - (wl-thread-entity-force-open (wl-thread-get-entity - (nth 0 (car mark-alist)))))) - (setq mark-alist (cdr mark-alist))))) - -;;; a subroutine for wl-thread-entity-get-next-marked-entity. -(defun wl-thread-entity-check-next-mark-from-younger-brother - (entity next-marks) - (let* (parent younger-brother) - (catch 'done - (while entity - (setq parent (wl-thread-entity-get-parent-entity entity) - younger-brother - (wl-thread-entity-get-younger-brothers entity parent)) - ;; check my brother! - (while younger-brother - (wl-thread-entity-check-next-mark - (wl-thread-get-entity (car younger-brother)) - next-marks) - (if (wl-thread-meaning-alist-get-result - (car next-marks)) - (throw 'done nil)) - (setq younger-brother (cdr younger-brother))) - (setq entity parent))))) - -(defun wl-thread-entity-get-next-marked-entity (entity next-marks) - (let ((children (wl-thread-entity-get-children entity)) - marked) - (or (catch 'done - (while children - (wl-thread-entity-check-next-mark - (wl-thread-get-entity (car children)) next-marks) - (if (setq marked - (wl-thread-meaning-alist-get-result - (car next-marks))) - (throw 'done marked)) - (setq children (cdr children)))) - ;; check younger brother - (wl-thread-entity-check-next-mark-from-younger-brother - entity next-marks) - (if (setq marked - (wl-thread-meaning-alist-get-result - (car next-marks))) - marked - (if (setq marked - (wl-thread-meaning-alist-get-result - (cdr next-marks))) - marked))))) + (dolist (number (elmo-folder-list-flagged wl-summary-buffer-elmo-folder + 'digest 'in-msgdb)) + (wl-thread-entity-force-open (wl-thread-get-entity number)))) (defsubst wl-thread-maybe-get-children-num (msg) (let ((entity (wl-thread-get-entity msg))) @@ -658,50 +373,48 @@ The closed parent will be opened." (defsubst wl-thread-update-line-on-buffer-sub (entity msg &optional parent-msg) (let* ((entity (or entity (wl-thread-get-entity msg))) (parent-msg (or parent-msg (wl-thread-entity-get-parent entity))) - (overview (elmo-msgdb-get-overview wl-summary-buffer-msgdb)) - (mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb)) (buffer-read-only nil) (inhibit-read-only t) - overview-entity temp-mark summary-line invisible-top) + message-entity temp-mark summary-line invisible-top dest-pair) (if (wl-thread-delete-line-from-buffer msg) (progn - (if (memq msg wl-summary-buffer-delete-list) - (setq temp-mark "D")) - (if (memq msg wl-summary-buffer-target-mark-list) - (setq temp-mark "*")) - (if (assq msg wl-summary-buffer-refile-list) - (setq temp-mark "o")) - (if (assq msg wl-summary-buffer-copy-list) - (setq temp-mark "O")) - (unless temp-mark - (setq temp-mark (wl-summary-get-score-mark msg))) - (when (setq overview-entity - (elmo-msgdb-overview-get-entity - msg wl-summary-buffer-msgdb)) - (setq summary-line - (wl-summary-overview-create-summary-line - msg - overview-entity - (elmo-msgdb-overview-get-entity - parent-msg wl-summary-buffer-msgdb) - nil - mark-alist - (if wl-thread-insert-force-opened - nil - (wl-thread-maybe-get-children-num msg)) - temp-mark entity)) - (wl-summary-insert-line summary-line))) + (cond + ((memq msg wl-summary-buffer-target-mark-list) + (setq temp-mark "*")) + ((setq temp-mark (wl-summary-registered-temp-mark msg)) + (setq dest-pair (cons (nth 0 temp-mark)(nth 2 temp-mark)) + temp-mark (nth 1 temp-mark))) + (t (setq temp-mark (wl-summary-get-score-mark msg)))) + (when (setq message-entity + (elmo-message-entity wl-summary-buffer-elmo-folder + msg)) + (wl-summary-insert-line + (wl-summary-create-line + message-entity + (elmo-message-entity wl-summary-buffer-elmo-folder + parent-msg) + temp-mark + (elmo-message-flags wl-summary-buffer-elmo-folder + msg) + (elmo-message-cached-p wl-summary-buffer-elmo-folder + msg) + (if wl-thread-insert-force-opened + nil + (wl-thread-maybe-get-children-num msg)) + (wl-thread-make-indent-string entity) + (wl-thread-entity-get-linked entity))) + (if dest-pair + (wl-summary-print-argument (car dest-pair) + (cdr dest-pair))))) ;; insert thread (moving thread) (if (not (setq invisible-top (wl-thread-entity-parent-invisible-p entity))) (wl-summary-update-thread - (elmo-msgdb-overview-get-entity msg wl-summary-buffer-msgdb) - overview - mark-alist + (elmo-message-entity wl-summary-buffer-elmo-folder msg) entity (and parent-msg - (elmo-msgdb-overview-get-entity - parent-msg wl-summary-buffer-msgdb))) + (elmo-message-entity wl-summary-buffer-elmo-folder + parent-msg))) ;; currently invisible.. update closed line. (wl-thread-update-children-number invisible-top))))) @@ -777,14 +490,14 @@ The closed parent will be opened." wl-thread-entity-hashtb)) (setq msgs (cdr msgs))))) -(defun wl-thread-get-exist-children (msg) +(defun wl-thread-get-exist-children (msg &optional include-self) (let ((msgs (list msg)) msgs-stack children entity ret-val) (while msgs (setq children (wl-thread-entity-get-children (setq entity (wl-thread-get-entity (car msgs))))) - (when (elmo-msgdb-overview-get-entity (car msgs) wl-summary-buffer-msgdb) + (when (elmo-message-entity wl-summary-buffer-elmo-folder (car msgs)) (wl-append ret-val (list (car msgs))) (setq children nil)) (setq msgs (cdr msgs)) @@ -793,83 +506,80 @@ The closed parent will be opened." (setq msgs (wl-pop msgs-stack))) (wl-push msgs msgs-stack) (setq msgs children))) + (unless include-self (setq ret-val (delq msg ret-val))) ret-val)) (defun wl-thread-delete-message (msg &optional deep update) "Delete MSG from entity and buffer." (save-excursion - (let* ((entity (wl-thread-get-entity msg)) - children older-brothers younger-brothers top-child ;;grandchildren - top-entity parent update-msgs beg invisible-top) + (let ((entity (wl-thread-get-entity msg)) + top-child top-entity update-msgs invisible-top) + (setq wl-summary-buffer-number-list + (delq msg wl-summary-buffer-number-list)) (when entity - (setq parent (wl-thread-entity-get-parent-entity entity)) - (if parent - (progn -;;; has parent. -;;; (setq brothers (wl-thread-entity-get-children parent)) - (setq older-brothers (wl-thread-entity-get-older-brothers - entity parent)) - (setq younger-brothers (wl-thread-entity-get-younger-brothers - entity parent)) - ;; - (unless deep - (setq children (wl-thread-entity-get-children entity)) - (wl-thread-reparent-children - children (wl-thread-entity-get-number parent)) - (setq update-msgs - (apply (function nconc) - update-msgs - (mapcar - (function - (lambda (message) - (wl-thread-get-children-msgs message t))) - children)))) - (wl-thread-entity-set-children - parent (append older-brothers children younger-brothers)) - ;; If chidren and younger-brothers not exists, - ;; update nearly older brother. - (when (and older-brothers - (not younger-brothers) - (not children)) - (wl-append - update-msgs - (wl-thread-get-children-msgs (car (last older-brothers)))))) - - ;; top...oldest child becomes top. - (unless deep - (setq children (wl-thread-entity-get-children entity)) - (when children - (setq top-child (car children) - children (cdr children)) - (setq top-entity (wl-thread-get-entity top-child)) - (wl-thread-entity-set-parent top-entity nil) - (wl-thread-entity-set-linked top-entity nil) - (wl-append update-msgs - (wl-thread-get-children-msgs top-child t))) - (when children - (wl-thread-entity-set-children - top-entity - (append - (wl-thread-entity-get-children top-entity) - children)) - (wl-thread-reparent-children children top-child) - (wl-append update-msgs children))) - ;; delete myself from top list. - (setq older-brothers (wl-thread-entity-get-older-brothers - entity nil)) - (setq younger-brothers (wl-thread-entity-get-younger-brothers - entity nil)) - (setq wl-thread-entity-list - (append (append older-brothers - (and top-child (list top-child))) - younger-brothers)))) - + (let ((parent (wl-thread-entity-get-parent-entity entity))) + (if parent + ;; has parent. + (let (children + (older-brothers (wl-thread-entity-get-older-brothers + entity parent)) + (younger-brothers (wl-thread-entity-get-younger-brothers + entity parent))) + (unless deep + (setq children (wl-thread-entity-get-children entity)) + (wl-thread-reparent-children + children (wl-thread-entity-get-number parent)) + (setq update-msgs + (apply (function nconc) + update-msgs + (mapcar + (function + (lambda (message) + (wl-thread-get-children-msgs message t))) + children)))) + (wl-thread-entity-set-children + parent (append older-brothers children younger-brothers)) + ;; If chidren and younger-brothers do not exist, + ;; update nearly older brother. + (when (and older-brothers + (not younger-brothers) + (not children)) + (wl-append + update-msgs + (wl-thread-get-children-msgs (car (last older-brothers)))))) + ;; top...oldest child becomes top. + (unless deep + (let ((children (wl-thread-entity-get-children entity))) + (when children + (setq top-child (car children) + children (cdr children)) + (setq top-entity (wl-thread-get-entity top-child)) + (wl-thread-entity-set-parent top-entity nil) + (wl-thread-entity-set-linked top-entity nil) + (wl-append update-msgs + (wl-thread-get-children-msgs top-child t))) + (when children + (wl-thread-entity-set-children + top-entity + (append + (wl-thread-entity-get-children top-entity) + children)) + (wl-thread-reparent-children children top-child) + (wl-append update-msgs children)))) + ;; delete myself from top list. + (let ((match (memq msg wl-thread-entity-list))) + (when match + (if top-child + (setcar match top-child) + (setq wl-thread-entity-list + (delq msg wl-thread-entity-list)))))))) + ;; (if deep ;; delete thread on buffer (when (wl-summary-jump-to-msg msg) - (setq beg (point)) - (wl-thread-goto-bottom-of-sub-thread) - (delete-region beg (point))) + (let ((beg (point))) + (wl-thread-goto-bottom-of-sub-thread) + (delete-region beg (point)))) ;; delete myself from buffer. (unless (wl-thread-delete-line-from-buffer msg) ;; jump to suitable point. @@ -885,10 +595,11 @@ The closed parent will be opened." ;; insert children if thread is closed or delete top. (when (or top-child (not (wl-thread-entity-get-opened entity))) - (let* (next-top insert-msgs ent e grandchildren) + (let (next-top insert-msgs ent grandchildren) (if top-child (progn - (setq insert-msgs (wl-thread-get-exist-children top-child)) + (setq insert-msgs (wl-thread-get-exist-children + top-child 'include-self)) (setq next-top (car insert-msgs)) (setq ent (wl-thread-get-entity next-top)) (when (and @@ -916,13 +627,13 @@ The closed parent will be opened." ent entity nil)) (setq insert-msgs (cdr insert-msgs)))))) (if update - ;; modify buffer. + ;; modify buffer. (while update-msgs (wl-thread-update-line-on-buffer-sub nil (pop update-msgs))) - ;; don't update buffer + ;; don't update buffer update-msgs)))) ; return value -(defun wl-thread-insert-message (overview-entity overview mark-alist +(defun wl-thread-insert-message (message-entity msg parent-msg &optional update linked) "Insert MSG to the entity. When optional argument UPDATE is non-nil, @@ -933,11 +644,21 @@ Message is inserted to the summary buffer." ;;; (when force-insert ;;; (if parent ;;; (wl-thread-entity-force-open parent)) + (when (and wl-summary-max-thread-depth parent) + (let ((cur parent) + (depth 0)) + (while cur + (incf depth) + (setq cur (wl-thread-entity-get-parent-entity cur))) + (when (> depth wl-summary-max-thread-depth) + (setq parent nil + parent-msg nil)))) (if parent ;; insert as children. (wl-thread-entity-insert-as-children parent - (setq child-entity (wl-thread-create-entity msg (nth 0 parent) nil linked))) + (setq child-entity (wl-thread-create-entity + msg (nth 0 parent) nil linked))) ;; insert as top message. (wl-thread-entity-insert-as-top (wl-thread-create-entity msg nil))) @@ -947,18 +668,15 @@ Message is inserted to the summary buffer." ;; visible. (progn (wl-summary-update-thread - overview-entity - overview - mark-alist + message-entity child-entity - (elmo-msgdb-overview-get-entity - parent-msg wl-summary-buffer-msgdb)) + (elmo-message-entity wl-summary-buffer-elmo-folder + parent-msg)) (when parent ;; use thread structure. - (wl-thread-entity-get-nearly-older-brother - child-entity parent))) ; return value -;;; (wl-thread-entity-get-number -;;; (wl-thread-entity-get-top-entity parent)))) ; return value; + ;;(wl-thread-entity-get-nearly-older-brother + ;; child-entity parent))) ; return value + (wl-thread-entity-get-number parent))) ; return value ;;; (setq beg (point)) ;;; (wl-thread-goto-bottom-of-sub-thread) ;;; (wl-thread-update-indent-string-region beg (point))) @@ -992,50 +710,9 @@ Message is inserted to the summary buffer." (defun wl-thread-update-children-number (entity) "Update the children number." - (save-excursion - (wl-summary-jump-to-msg (wl-thread-entity-get-number entity)) - (beginning-of-line) - (let ((text-prop (get-text-property (point) 'face)) - from from-end beg str) - (cond - ((looking-at (concat "^" wl-summary-buffer-number-regexp - "..../..\(.*\)..:.. [" - wl-thread-indent-regexp - "]*[[<]\\+\\([0-9]+\\):")) - (delete-region (match-beginning 1)(match-end 1)) - (goto-char (match-beginning 1)) - (setq str (format "%s" (wl-thread-entity-get-children-num entity))) - (if wl-summary-highlight - (put-text-property 0 (length str) 'face text-prop str)) - (insert str)) - ((looking-at (concat "^" wl-summary-buffer-number-regexp - "..../..\(.*\)..:.. [" - wl-thread-indent-regexp - "]*[[<]")) - (goto-char (match-end 0)) - (setq beg (current-column)) - (setq from-end (save-excursion - (move-to-column (+ 1 beg wl-from-width)) - (point))) - (setq from (buffer-substring (match-end 0) from-end)) - (delete-region (match-end 0) from-end) - (setq str (wl-set-string-width - (1+ wl-from-width) - (format - "+%s:%s" - (wl-thread-entity-get-children-num - entity) - from))) - (if wl-summary-highlight - (put-text-property 0 (length str) 'face text-prop str)) - (insert str) - (condition-case nil ; it's dangerous, so ignore error. - (run-hooks 'wl-thread-update-children-number-hook) - (error - (ding) - (message "Error in wl-thread-update-children-number-hook.")))))))) - -;; + (wl-thread-update-line-on-buffer (wl-thread-entity-get-number entity))) + +;; ;; Thread oriented commands. ;; (defun wl-thread-call-region-func (func &optional arg) @@ -1051,21 +728,6 @@ Message is inserted to the summary buffer." (interactive "P") (wl-thread-call-region-func 'wl-summary-prefetch-region arg)) -(defun wl-thread-msg-mark-as-important (msg) - "Set mark as important for invisible MSG. Modeline is not changed." - (let* ((msgdb wl-summary-buffer-msgdb) - (mark-alist (elmo-msgdb-get-mark-alist msgdb)) - cur-mark) - (setq cur-mark (cadr (assq msg mark-alist))) - (setq mark-alist - (elmo-msgdb-mark-set mark-alist - msg - (if (string= cur-mark wl-summary-important-mark) - nil - wl-summary-important-mark))) - (elmo-msgdb-set-mark-alist msgdb mark-alist) - (wl-summary-set-mark-modified))) - (defun wl-thread-mark-as-read (&optional arg) (interactive "P") (wl-thread-call-region-func 'wl-summary-mark-as-read-region arg)) @@ -1078,36 +740,13 @@ Message is inserted to the summary buffer." (interactive "P") (wl-thread-call-region-func 'wl-summary-mark-as-important-region arg)) -(defun wl-thread-copy (&optional arg) - (interactive "P") - (wl-thread-call-region-func 'wl-summary-copy-region arg)) - -(defun wl-thread-refile (&optional arg) +(defun wl-thread-set-flags (&optional arg) (interactive "P") - (condition-case err - (progn - (wl-thread-call-region-func 'wl-summary-refile-region arg) - (if arg - (wl-summary-goto-top-of-current-thread)) - (wl-thread-goto-bottom-of-sub-thread)) - (error - (elmo-display-error err t) - nil))) - -(defun wl-thread-delete (&optional arg) - (interactive "P") - (wl-thread-call-region-func 'wl-summary-delete-region arg) - (if arg - (wl-summary-goto-top-of-current-thread)) - (if (not wl-summary-move-direction-downward) - (wl-summary-prev) - (wl-thread-goto-bottom-of-sub-thread) - (if wl-summary-buffer-disp-msg - (wl-summary-redisplay)))) + (wl-thread-call-region-func 'wl-summary-set-flags-region arg)) -(defun wl-thread-target-mark (&optional arg) +(defun wl-thread-mark-as-answered (&optional arg) (interactive "P") - (wl-thread-call-region-func 'wl-summary-target-mark-region arg)) + (wl-thread-call-region-func 'wl-summary-mark-as-answered-region arg)) (defun wl-thread-unmark (&optional arg) (interactive "P") @@ -1155,45 +794,42 @@ Message is inserted to the summary buffer." (setq cur (1+ cur)) (if (or (zerop (% cur 2)) (= cur len)) (elmo-display-progress - 'wl-thread-insert-top "Inserting thread..." + 'wl-thread-insert-top "Inserting message..." (/ (* cur 100) len))))))) (defsubst wl-thread-insert-entity-sub (indent entity parent-entity all) - (let ((mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb)) - msg-num - overview-entity + (let (msg-num + message-entity temp-mark summary-line) (when (setq msg-num (wl-thread-entity-get-number entity)) (unless all ; all...means no temp-mark. - (cond ((memq msg-num wl-summary-buffer-delete-list) - (setq temp-mark "D")) - ((memq msg-num wl-summary-buffer-target-mark-list) + (cond ((memq msg-num wl-summary-buffer-target-mark-list) (setq temp-mark "*")) - ((assq msg-num wl-summary-buffer-refile-list) - (setq temp-mark "o")) - ((assq msg-num wl-summary-buffer-copy-list) - (setq temp-mark "O")))) + ((setq temp-mark (wl-summary-registered-temp-mark msg-num)) + (setq temp-mark (nth 1 temp-mark))))) (unless temp-mark (setq temp-mark (wl-summary-get-score-mark msg-num))) - (setq overview-entity - (elmo-msgdb-overview-get-entity - (nth 0 entity) wl-summary-buffer-msgdb)) + (setq message-entity + (elmo-message-entity wl-summary-buffer-elmo-folder + (nth 0 entity))) ;;; (wl-delete-all-overlays) - (when overview-entity - (setq summary-line - (wl-summary-overview-create-summary-line - msg-num - overview-entity - (elmo-msgdb-overview-get-entity - (nth 0 parent-entity) wl-summary-buffer-msgdb) - (1+ indent) - mark-alist - (if wl-thread-insert-force-opened - nil - (wl-thread-maybe-get-children-num msg-num)) - temp-mark entity)) - (wl-summary-insert-line summary-line))))) + (when message-entity + (wl-summary-insert-line + (wl-summary-create-line + message-entity + (elmo-message-entity wl-summary-buffer-elmo-folder + (nth 0 parent-entity)) + temp-mark + (elmo-message-flags wl-summary-buffer-elmo-folder + msg-num) + (elmo-message-cached-p wl-summary-buffer-elmo-folder + msg-num) + (if wl-thread-insert-force-opened + nil + (wl-thread-maybe-get-children-num msg-num)) + (wl-thread-make-indent-string entity) + (wl-thread-entity-get-linked entity))))))) (defun wl-thread-insert-entity (indent entity parent-entity all) "Insert thread entity in current buffer." @@ -1252,30 +888,29 @@ Message is inserted to the summary buffer." (forward-line 1)) (beginning-of-line))) -(defun wl-thread-remove-destination-region (beg end) +(defun wl-thread-remove-argument-region (beg end) (save-excursion (save-restriction (narrow-to-region beg end) (goto-char (point-min)) (while (not (eobp)) - (let ((num (wl-summary-message-number))) - (if (assq num wl-summary-buffer-refile-list) - (wl-summary-remove-destination))) + (wl-summary-remove-argument) (forward-line 1))))) -(defun wl-thread-print-destination-region (beg end) - (if (or wl-summary-buffer-refile-list - wl-summary-buffer-copy-list) +(defun wl-thread-print-argument-region (beg end) + (if wl-summary-buffer-temp-mark-list (save-excursion (save-restriction (narrow-to-region beg end) (goto-char (point-min)) (while (not (eobp)) (let ((num (wl-summary-message-number)) - pair) - (if (or (setq pair (assq num wl-summary-buffer-refile-list)) - (setq pair (assq num wl-summary-buffer-copy-list))) - (wl-summary-print-destination (car pair) (cdr pair)))) + temp-mark pair) + (when (and (setq temp-mark + (wl-summary-registered-temp-mark num)) + (nth 2 temp-mark) + (setq pair (cons (nth 0 temp-mark)(nth 2 temp-mark)))) + (wl-summary-print-argument (car pair) (cdr pair)))) (forward-line 1)))))) (defsubst wl-thread-get-children-msgs (msg &optional visible-only) @@ -1299,20 +934,20 @@ Message is inserted to the summary buffer." (defun wl-thread-get-children-msgs-uncached (msg &optional uncached-marks) (let ((children-msgs (wl-thread-get-children-msgs msg)) - (mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb)) - (number-alist (elmo-msgdb-get-number-alist wl-summary-buffer-msgdb)) - mark - uncached-list) + mark uncached-list) (while children-msgs (if (and (not (eq msg (car children-msgs))) ; except itself (or (and uncached-marks - (setq mark (cadr (assq (car children-msgs) - mark-alist))) + (setq mark (wl-summary-message-mark + wl-summary-buffer-elmo-folder + (car children-msgs))) (member mark uncached-marks)) (and (not uncached-marks) - (null (elmo-cache-exists-p - (cdr (assq (car children-msgs) - number-alist))))))) + (null (elmo-file-cache-exists-p + (elmo-message-field + wl-summary-buffer-elmo-folder + (car children-msgs) + 'message-id)))))) (wl-append uncached-list (list (car children-msgs)))) (setq children-msgs (cdr children-msgs))) uncached-list)) @@ -1341,8 +976,8 @@ Message is inserted to the summary buffer." (beginning-of-line) (setq beg (point)) (wl-thread-goto-bottom-of-sub-thread) - (wl-thread-remove-destination-region beg - (point)) + (wl-thread-remove-argument-region beg + (point)) (forward-char -1) ;; needed for mouse-face. (delete-region beg (point)) (wl-thread-insert-entity (- depth 1) @@ -1351,7 +986,7 @@ Message is inserted to the summary buffer." (nth 3 entity)) nil) (delete-char 1) ; delete '\n' - (wl-thread-print-destination-region beg (point)))) + (wl-thread-print-argument-region beg (point)))) (defun wl-thread-open (entity) (let (depth beg) @@ -1366,7 +1001,7 @@ Message is inserted to the summary buffer." (wl-thread-get-entity (nth 3 entity)) nil) (delete-char 1) ; delete '\n' - (wl-thread-print-destination-region beg (point)))) + (wl-thread-print-argument-region beg (point)))) (defun wl-thread-open-close (&optional force-open) (interactive "P") @@ -1402,31 +1037,27 @@ Message is inserted to the summary buffer." (wl-summary-jump-to-msg msg) (wl-thread-close (wl-thread-get-entity (wl-summary-message-number))))))) + (when wl-summary-lazy-highlight + (wl-highlight-summary-window)) (wl-summary-set-message-modified) (set-buffer-modified-p nil)))) - (defun wl-thread-get-depth-of-current-line () - (interactive) - (save-excursion - (beginning-of-line) - (let ((depth 0)) - (if (re-search-forward (concat "^" wl-summary-buffer-number-regexp - "..../..\(.*\)..:.. ") - nil t) - (while (string-match wl-thread-indent-regexp - (char-to-string - (char-after (point)))) - (setq depth (1+ depth)) - (forward-char))) - (/ depth wl-thread-indent-level-internal)))) - + (let ((entity (wl-thread-get-entity (wl-summary-message-number))) + (depth 0) + number) + (while (setq number (wl-thread-entity-get-parent entity)) + (incf depth) + (setq entity (wl-thread-get-entity number))) + depth)) + (defun wl-thread-update-indent-string-region (beg end) (interactive "r") (save-excursion (goto-char beg) (while (< (point) end) - (wl-thread-update-indent-string) + (save-excursion + (wl-thread-update-line-on-buffer-sub nil (wl-summary-message-number))) (forward-line 1)))) (defsubst wl-thread-make-indent-string (entity) @@ -1457,35 +1088,6 @@ Message is inserted to the summary buffer." (setq cur (wl-thread-entity-get-parent-entity cur)))) ret-val)) -(defun wl-thread-update-indent-string () - "Update indent string of current line." - (interactive) - (save-excursion - (beginning-of-line) - (let ((inhibit-read-only t) - (buffer-read-only nil) - thr-str) - (when (looking-at (concat "^ *\\([0-9]+\\)" - "..../..\(.*\)..:.. \\(" - wl-highlight-thread-indent-string-regexp - "\\)[[<]")) - (goto-char (match-beginning 2)) - (delete-region (match-beginning 2) - (match-end 2)) - (setq thr-str - (wl-thread-make-indent-string - (wl-thread-get-entity (string-to-int (wl-match-buffer 1))))) - (if (and wl-summary-width - wl-summary-indent-length-limit - (< wl-summary-indent-length-limit - (string-width thr-str))) - (setq thr-str (wl-set-string-width - wl-summary-indent-length-limit - thr-str))) - (insert thr-str) - (if wl-summary-highlight - (wl-highlight-summary-current-line)))))) - (defun wl-thread-set-parent (&optional parent-number) "Set current message's parent interactively." (interactive) @@ -1529,6 +1131,7 @@ Message is inserted to the summary buffer." (setq update-msgs (elmo-uniq-list update-msgs)) (wl-thread-entity-set-parent entity dst-parent) ;; update thread on buffer + (wl-thread-make-number-list) (wl-thread-update-line-msgs update-msgs t)))) (require 'product)