Fix mail address
[elisp/wanderlust.git] / wl / wl-thread.el
1 ;;; wl-thread.el --- Thread display modules for Wanderlust.
2
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 1998,1999,2000 Masahiro MURATA  <muse@ba2.so-net.ne.jp>
5
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;;      Masahiro MURATA  <muse@ba2.so-net.ne.jp>
8 ;; Keywords: mail, net news
9
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
11
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16 ;;
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21 ;;
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26 ;;
27
28 ;;; Commentary:
29 ;;
30
31 ;;; Code:
32 ;;
33
34 (require 'wl-summary)
35 (require 'wl-highlight)
36 (eval-when-compile (require 'cl))
37
38 ;; buffer local variables.
39 ;;(defvar wl-thread-top-entity '(nil t nil nil)) ; top entity
40 (defvar wl-thread-tops nil)             ; top number list (number)
41 (defvar wl-thread-entities nil)
42 (defvar wl-thread-entity-list nil)      ; entity list
43 (defvar wl-thread-entity-hashtb nil)    ; obarray
44
45 (make-variable-buffer-local 'wl-thread-entity-hashtb)
46 (make-variable-buffer-local 'wl-thread-entities)     ; ".wl-thread-entity"
47 (make-variable-buffer-local 'wl-thread-entity-list)  ; ".wl-thread-entity-list"
48
49 ;;; global flag
50 (defvar wl-thread-insert-force-opened nil)
51
52 ;;;;;; each entity is (number opened-or-not children parent) ;;;;;;;
53
54 (defun wl-thread-resume-entity (fld)
55   (let (entities top-list)
56     (setq entities (wl-summary-load-file-object
57                     (expand-file-name wl-thread-entity-file
58                                       (elmo-folder-msgdb-path fld))))
59     (setq top-list
60           (wl-summary-load-file-object
61            (expand-file-name wl-thread-entity-list-file
62                              (elmo-folder-msgdb-path fld))))
63     (message "Resuming thread structure...")
64     ;; set obarray value.
65     (setq wl-thread-entity-hashtb (elmo-make-hash (* (length entities) 2)))
66     ;; set buffer local variables.
67     (setq wl-thread-entities entities)
68     (setq wl-thread-entity-list top-list)
69     (while entities
70       (elmo-set-hash-val (format "#%d" (car (car entities))) (car entities)
71                          wl-thread-entity-hashtb)
72       (setq entities (cdr entities)))
73     (wl-thread-make-number-list)
74     (message "Resuming thread structure...done")))
75
76 (defun wl-thread-make-number-list ()
77   "Make `wl-summary-buffer-number-list', a list of message numbers."
78   (let* ((node (wl-thread-get-entity (car wl-thread-entity-list)))
79          (children (wl-thread-entity-get-children node))
80          parent sibling)
81     (setq wl-summary-buffer-number-list (list (car wl-thread-entity-list)))
82     (while children
83       (wl-thread-entity-make-number-list-from-children
84        (wl-thread-get-entity (car children)))
85       (setq children (cdr children)))
86     (while node
87       (setq parent (wl-thread-entity-get-parent-entity node)
88             sibling (wl-thread-entity-get-younger-brothers
89                      node parent))
90       (while sibling
91         (wl-thread-entity-make-number-list-from-children
92          (wl-thread-get-entity (car sibling)))
93         (setq sibling (cdr sibling)))
94       (setq node parent))
95     (setq wl-summary-buffer-number-list (nreverse
96                                          wl-summary-buffer-number-list))))
97
98 (defun wl-thread-entity-make-number-list-from-children (entity)
99   (let ((msgs (list (car entity)))
100         msgs-stack children)
101     (while msgs
102       (setq wl-summary-buffer-number-list (cons (car entity)
103                                                 wl-summary-buffer-number-list))
104       (setq msgs (cdr msgs))
105       (setq children (wl-thread-entity-get-children entity))
106       (if children
107           (progn
108             (wl-push msgs msgs-stack)
109             (setq msgs children))
110         (unless msgs
111           (while (and (null msgs) msgs-stack)
112             (setq msgs (wl-pop msgs-stack)))))
113       (setq entity (wl-thread-get-entity (car msgs))))))
114
115 (defun wl-thread-save-entity (dir)
116   (wl-thread-save-entities dir)
117   (wl-thread-save-top-list dir))
118
119 (defun wl-thread-save-top-list (dir)
120   (let ((top-file (expand-file-name wl-thread-entity-list-file dir))
121         (entity wl-thread-entity-list)
122         print-length)
123     (with-temp-buffer
124       (when (file-writable-p top-file)
125         (prin1 entity (current-buffer))
126         (princ "\n" (current-buffer))
127         (write-region (point-min) (point-max) top-file nil 'no-msg)))))
128
129 (defun wl-thread-save-entities (dir)
130   (let ((top-file (expand-file-name wl-thread-entity-file dir))
131         (entities wl-thread-entities)
132         print-length print-level)
133     (with-temp-buffer
134       (when (file-writable-p top-file)
135         (prin1 entities (current-buffer))
136         (princ "\n" (current-buffer))
137         (write-region (point-min) (point-max) top-file nil 'no-msg)))))
138
139 (defsubst wl-thread-entity-get-number (entity)
140   (nth 0 entity))
141 (defsubst wl-thread-entity-get-opened (entity)
142   (nth 1 entity))
143 (defsubst wl-thread-entity-get-children (entity)
144   (nth 2 entity))
145 (defsubst wl-thread-entity-get-parent (entity)
146   (nth 3 entity))
147 (defsubst wl-thread-entity-get-linked (entity)
148   (nth 4 entity))
149
150 (defsubst wl-thread-create-entity (num parent &optional opened linked)
151   (list num (or opened wl-thread-insert-opened) nil parent linked))
152
153 (defsubst wl-thread-get-entity (num)
154   (and num
155        (elmo-get-hash-val (format "#%d" num) wl-thread-entity-hashtb)))
156
157 (defsubst wl-thread-entity-set-parent (entity parent)
158   (setcar (cdddr entity) parent)
159   entity)
160
161 (defsubst wl-thread-entity-set-children (entity children)
162   (setcar (cddr entity) children))
163
164 (defsubst wl-thread-entity-set-linked (entity linked)
165   (if (cddddr entity)
166       (setcar (cddddr entity) linked)
167     (nconc entity (list linked)))
168   entity)
169
170 (defsubst wl-thread-reparent-children (children parent)
171   (while children
172     (wl-thread-entity-set-parent
173      (wl-thread-get-entity (car children)) parent)
174     (wl-thread-entity-set-linked
175      (wl-thread-get-entity (car children)) t)
176     (setq children (cdr children))))
177
178 (defsubst wl-thread-entity-insert-as-top (entity)
179   (when (and entity
180              (car entity))
181     (wl-append wl-thread-entity-list (list (car entity)))
182     (setq wl-thread-entities (cons entity wl-thread-entities))
183     (setq wl-summary-buffer-number-list
184           (nconc wl-summary-buffer-number-list (list (car entity))))
185     (elmo-set-hash-val (format "#%d" (car entity)) entity
186                        wl-thread-entity-hashtb)))
187
188 (defsubst wl-thread-entity-insert-as-children (to entity)
189   (let ((children (wl-thread-entity-get-children to))
190         curp curc)
191     (setq curp to)
192     (elmo-list-insert wl-summary-buffer-number-list
193                       (wl-thread-entity-get-number entity)
194                       (progn
195                         (while (setq curc
196                                      (wl-thread-entity-get-children curp))
197                           (setq curp (wl-thread-get-entity
198                                       (nth (- (length curc) 1)
199                                            curc))))
200                         (wl-thread-entity-get-number curp)))
201     (setcar (cddr to) (wl-append children
202                                  (list (car entity))))
203     (setq wl-thread-entities (cons entity wl-thread-entities))
204     (elmo-set-hash-val (format "#%d" (car entity)) entity
205                        wl-thread-entity-hashtb)))
206
207 (defsubst wl-thread-entity-set-opened (entity opened)
208   (setcar (cdr entity) opened))
209
210 (defsubst wl-thread-entity-get-children-num (entity)
211   (let (children
212         ret-val msgs-stack
213         (msgs (list (car entity))))
214    (while msgs
215      (setq msgs (cdr msgs))
216      (setq children (wl-thread-entity-get-children entity))
217      (if (null children)
218          (while (and (null msgs) msgs-stack)
219            (setq msgs (wl-pop msgs-stack)))
220        (setq ret-val (+ (or ret-val 0) (length children)))
221        (wl-push msgs msgs-stack)
222        (setq msgs children))
223      (setq entity (wl-thread-get-entity (car msgs))))
224    ret-val))
225
226 (defun wl-thread-entity-get-descendant (entity)
227   (let (children
228         ret-val msgs-stack
229         (msgs (list (car entity))))
230    (while msgs
231      (setq msgs (cdr msgs))
232      (setq children (wl-thread-entity-get-children entity))
233      (if (null children)
234          (while (and (null msgs) msgs-stack)
235            (setq msgs (wl-pop msgs-stack)))
236        (setq ret-val (nconc ret-val (copy-sequence children)))
237        (wl-push msgs msgs-stack)
238        (setq msgs children))
239      (setq entity (wl-thread-get-entity (car msgs))))
240    ret-val))
241
242 (defsubst wl-thread-entity-get-parent-entity (entity)
243   (wl-thread-get-entity (wl-thread-entity-get-parent entity)))
244
245 (defun wl-thread-entity-get-top-entity (entity)
246   (let ((cur-entity entity)
247         p-num)
248     (while (setq p-num (wl-thread-entity-get-parent cur-entity))
249       (setq cur-entity (wl-thread-get-entity p-num)))
250     cur-entity))
251
252 (defun wl-thread-entity-parent-invisible-p (entity)
253   "If parent of ENTITY is invisible, the top invisible ancestor entity of
254 ENTITY is returned."
255   (let ((cur-entity entity)
256         top)
257     (catch 'done
258       (while (setq cur-entity (wl-thread-entity-get-parent-entity
259                                cur-entity))
260         (if (null (wl-thread-entity-get-number cur-entity))
261             (throw 'done nil)
262           (when (not (wl-thread-entity-get-opened cur-entity))
263             (setq top cur-entity)))))
264     top))
265
266 (defun wl-thread-entity-get-nearly-older-brother (entity &optional parent)
267   (let ((brothers (wl-thread-entity-get-older-brothers entity parent)))
268     (when brothers
269       (car (last brothers)))))
270
271 (defun wl-thread-entity-get-older-brothers (entity &optional parent)
272   (let ((parent (or parent
273                     (wl-thread-entity-get-parent-entity entity)))
274         brothers ret-val)
275     (if parent
276         (setq brothers (wl-thread-entity-get-children parent))
277       (setq brothers wl-thread-entity-list))
278     (while (and brothers
279                 (not (eq (wl-thread-entity-get-number entity)
280                          (car brothers))))
281       (wl-append ret-val (list (car brothers)))
282       (setq brothers (cdr brothers)))
283     ret-val))
284
285 (defun wl-thread-entity-get-younger-brothers (entity &optional parent)
286   (let* ((parent (or parent
287                      (wl-thread-entity-get-parent-entity entity)))
288          (brothers (wl-thread-entity-get-children parent)))
289     (if parent
290         (cdr (memq (wl-thread-entity-get-number entity)
291                    brothers))
292       ;; top!!
293       (cdr (memq (car entity) wl-thread-entity-list)))))
294
295 (defun wl-thread-jump-to-msg (&optional number)
296   (interactive)
297   (let ((num (or number
298                  (string-to-int
299                   (read-from-minibuffer "Jump to Message(No.): ")))))
300     (wl-thread-entity-force-open (wl-thread-get-entity num))
301     (wl-summary-jump-to-msg num)))
302
303 (defun wl-thread-close-all ()
304   "Close all top threads."
305   (interactive)
306   (message "Closing all threads...")
307   (save-excursion
308     (let ((entities wl-thread-entity-list)
309           (cur 0)
310           (len (length wl-thread-entity-list)))
311       (while entities
312         (when (and (wl-thread-entity-get-opened (wl-thread-get-entity
313                                                  (car entities)))
314                    (wl-thread-entity-get-children (wl-thread-get-entity
315                                                    (car entities))))
316           (wl-summary-jump-to-msg (car entities))
317           (wl-thread-open-close))
318         (when (> len elmo-display-progress-threshold)
319           (setq cur (1+ cur))
320           (if (or (zerop (% cur 5)) (= cur len))
321               (elmo-display-progress
322                'wl-thread-close-all "Closing all threads..."
323                (/ (* cur 100) len))))
324         (setq entities (cdr entities)))))
325   (message "Closing all threads...done"))
326
327 (defun wl-thread-open-all ()
328   "Open all threads."
329   (interactive)
330   (message "Opening all threads...")
331   (save-excursion
332     (goto-char (point-min))
333     (let ((len (count-lines (point-min) (point-max)))
334           (cur 0)
335           entity)
336       (while (not (eobp))
337         (if (wl-thread-entity-get-opened
338              (setq entity (wl-thread-get-entity
339                            (wl-summary-message-number))))
340             (forward-line 1)
341           (wl-thread-force-open)
342           (wl-thread-goto-bottom-of-sub-thread))
343         (when (> len elmo-display-progress-threshold)
344           (setq cur (1+ cur))
345           (elmo-display-progress
346            'wl-thread-open-all "Opening all threads..."
347            (/ (* cur 100) len)))))
348     ;; Make sure to be 100%.
349     (elmo-display-progress
350      'wl-thread-open-all "Opening all threads..."
351      100))
352   (message "Opening all threads...done"))
353
354 (defun wl-thread-open-all-unread ()
355   (interactive)
356   (dolist (number (elmo-folder-list-flagged wl-summary-buffer-elmo-folder
357                                             'digest 'in-msgdb))
358     (wl-thread-entity-force-open (wl-thread-get-entity number))))
359
360 (defsubst wl-thread-maybe-get-children-num (msg)
361   (let ((entity (wl-thread-get-entity msg)))
362     (if (not (wl-thread-entity-get-opened entity))
363         (wl-thread-entity-get-children-num entity))))
364
365 (defsubst wl-thread-update-line-on-buffer-sub (entity msg &optional parent-msg)
366   (let* ((entity (or entity (wl-thread-get-entity msg)))
367          (parent-msg (or parent-msg (wl-thread-entity-get-parent entity)))
368          (buffer-read-only nil)
369          (inhibit-read-only t)
370          message-entity temp-mark summary-line invisible-top)
371     (if (wl-thread-delete-line-from-buffer msg)
372         (progn
373           (cond
374            ((memq msg wl-summary-buffer-target-mark-list)
375             (setq temp-mark "*"))
376            ((setq temp-mark (wl-summary-registered-temp-mark msg))
377             (setq temp-mark (nth 1 temp-mark)))
378            (t (setq temp-mark (wl-summary-get-score-mark msg))))
379           (when (setq message-entity
380                       (elmo-message-entity wl-summary-buffer-elmo-folder
381                                            msg))
382             (wl-summary-insert-line
383              (wl-summary-create-line
384               message-entity
385               (elmo-message-entity wl-summary-buffer-elmo-folder
386                                    parent-msg)
387               temp-mark
388               (elmo-message-flags wl-summary-buffer-elmo-folder
389                                   msg)
390               (elmo-message-cached-p wl-summary-buffer-elmo-folder
391                                      msg)
392               (if wl-thread-insert-force-opened
393                   nil
394                 (wl-thread-maybe-get-children-num msg))
395               (wl-thread-make-indent-string entity)
396               (wl-thread-entity-get-linked entity)))))
397       ;; insert thread (moving thread)
398       (if (not (setq invisible-top
399                      (wl-thread-entity-parent-invisible-p entity)))
400           (wl-summary-update-thread
401            (elmo-message-entity wl-summary-buffer-elmo-folder msg)
402            entity
403            (and parent-msg
404                 (elmo-message-entity wl-summary-buffer-elmo-folder
405                                      parent-msg)))
406         ;; currently invisible.. update closed line.
407         (wl-thread-update-children-number invisible-top)))))
408
409 (defun wl-thread-update-line-on-buffer (&optional msg parent-msg updates)
410   (interactive)
411   (let ((msgs (list (or msg (wl-summary-message-number))))
412         entity children msgs-stack)
413    (while msgs
414     (setq msg (wl-pop msgs))
415     (setq updates (and updates (delete msg updates)))
416     (setq entity (wl-thread-get-entity msg))
417     (wl-thread-update-line-on-buffer-sub entity msg parent-msg)
418     ;;
419     (setq children (wl-thread-entity-get-children entity))
420     (if children
421         ;; update children
422         (when (wl-thread-entity-get-opened entity)
423           (wl-push msgs msgs-stack)
424           (setq parent-msg msg
425                 msgs children))
426       (unless msgs
427         (while (and (null msgs) msgs-stack)
428           (setq msgs (wl-pop msgs-stack)))
429         (when msgs
430           (setq parent-msg
431                 (wl-thread-entity-get-number
432                  (wl-thread-entity-get-parent-entity
433                   (wl-thread-get-entity (car msgs)))))))))
434    updates))
435
436 (defun wl-thread-update-line-msgs (msgs &optional no-msg)
437   (wl-delete-all-overlays)
438   (let ((i 0)
439         (updates msgs)
440         len)
441 ;;; (while msgs
442 ;;;   (setq updates
443 ;;;         (append updates
444 ;;;                 (wl-thread-get-children-msgs (car msgs))))
445 ;;;   (setq msgs (cdr msgs)))
446 ;;; (setq updates (elmo-uniq-list updates))
447     (setq len (length updates))
448     (while updates
449       (wl-thread-update-line-on-buffer-sub nil (car updates))
450       (setq updates (cdr updates))
451       (when (and (not no-msg)
452                  (> len elmo-display-progress-threshold))
453         (setq i (1+ i))
454         (if (or (zerop (% i 5)) (= i len))
455             (elmo-display-progress
456              'wl-thread-update-line-msgs "Updating deleted thread..."
457              (/ (* i 100) len)))))))
458
459 (defun wl-thread-delete-line-from-buffer (msg)
460   "Simply delete msg line."
461   (let (beg)
462     (if (wl-summary-jump-to-msg msg)
463         (progn
464           (setq beg (point))
465           (forward-line 1)
466           (delete-region beg (point))
467           t)
468       nil)))
469
470 (defun wl-thread-cleanup-symbols (msgs)
471   (let (entity)
472     (while msgs
473       (when (setq entity (wl-thread-get-entity (car msgs)))
474         ;; delete entity.
475         (setq wl-thread-entities (delq entity wl-thread-entities))
476         ;; free symbol.
477         (elmo-clear-hash-val (format "#%d" (car msgs))
478                              wl-thread-entity-hashtb))
479       (setq msgs (cdr msgs)))))
480
481 (defun wl-thread-get-exist-children (msg &optional include-self)
482   (let ((msgs (list msg))
483         msgs-stack children
484         entity ret-val)
485     (while msgs
486       (setq children (wl-thread-entity-get-children
487                       (setq entity (wl-thread-get-entity (car msgs)))))
488       (when (elmo-message-entity wl-summary-buffer-elmo-folder (car msgs))
489         (wl-append ret-val (list (car msgs)))
490         (setq children nil))
491       (setq msgs (cdr msgs))
492       (if (null children)
493           (while (and (null msgs) msgs-stack)
494             (setq msgs (wl-pop msgs-stack)))
495         (wl-push msgs msgs-stack)
496         (setq msgs children)))
497     (unless include-self (setq ret-val (delq msg ret-val)))
498     ret-val))
499
500 (defun wl-thread-delete-message (msg &optional deep update)
501   "Delete MSG from entity and buffer."
502   (save-excursion
503     (let ((entity (wl-thread-get-entity msg))
504           top-child top-entity update-msgs invisible-top)
505       (setq wl-summary-buffer-number-list
506             (delq msg wl-summary-buffer-number-list))
507       (when entity
508         (when deep
509           (setq wl-summary-buffer-number-list
510                 (elmo-list-delete
511                  (wl-thread-entity-get-descendant entity)
512                  wl-summary-buffer-number-list
513                  #'delq)))
514         (let ((parent (wl-thread-entity-get-parent-entity entity)))
515           (if parent
516               ;; has parent.
517               (let (children
518                     (older-brothers (wl-thread-entity-get-older-brothers
519                                      entity parent))
520                     (younger-brothers (wl-thread-entity-get-younger-brothers
521                                        entity parent)))
522                 (unless deep
523                   (setq children (wl-thread-entity-get-children entity))
524                   (wl-thread-reparent-children
525                    children (wl-thread-entity-get-number parent))
526                   (setq update-msgs
527                         (apply (function nconc)
528                                update-msgs
529                                (mapcar
530                                 (function
531                                  (lambda (message)
532                                    (wl-thread-get-children-msgs message t)))
533                                 children))))
534                 (wl-thread-entity-set-children
535                  parent (append older-brothers children younger-brothers))
536                 ;; If chidren and younger-brothers do not exist,
537                 ;; update nearly older brother.
538                 (when (and older-brothers
539                            (not younger-brothers)
540                            (not children))
541                   (wl-append
542                    update-msgs
543                    (wl-thread-get-children-msgs (car (last older-brothers))))))
544             ;; top...oldest child becomes top.
545             (unless deep
546               (let ((children (wl-thread-entity-get-children entity)))
547                 (when children
548                   (setq top-child (car children)
549                         children (cdr children))
550                   (setq top-entity (wl-thread-get-entity top-child))
551                   (wl-thread-entity-set-parent top-entity nil)
552                   (wl-thread-entity-set-linked top-entity nil)
553                   (wl-append update-msgs
554                              (wl-thread-get-children-msgs top-child t)))
555                 (when children
556                   (wl-thread-entity-set-children
557                    top-entity
558                    (append
559                     (wl-thread-entity-get-children top-entity)
560                     children))
561                   (wl-thread-reparent-children children top-child)
562                   (wl-append update-msgs children))))
563             ;; delete myself from top list.
564             (let ((match (memq msg wl-thread-entity-list)))
565               (when match
566                 (if top-child
567                     (setcar match top-child)
568                   (setq wl-thread-entity-list
569                         (delq msg wl-thread-entity-list))))))))
570       ;;
571       (if deep
572           ;; delete thread on buffer
573           (when (wl-summary-jump-to-msg msg)
574             (let ((beg (point)))
575               (wl-thread-goto-bottom-of-sub-thread)
576               (delete-region beg (point))))
577         ;; delete myself from buffer.
578         (unless (wl-thread-delete-line-from-buffer msg)
579           ;; jump to suitable point.
580           ;; just upon the oldest younger-brother of my top.
581           (setq invisible-top
582                 (car (wl-thread-entity-parent-invisible-p entity)))
583           (if invisible-top
584               (progn
585                 (wl-append update-msgs (list invisible-top))
586                 (wl-summary-jump-to-msg invisible-top))
587             (goto-char (point-max))))
588
589         ;; insert children if thread is closed or delete top.
590         (when (or top-child
591                   (not (wl-thread-entity-get-opened entity)))
592           (let (next-top insert-msgs ent grandchildren)
593             (if top-child
594                 (progn
595                   (setq insert-msgs (wl-thread-get-exist-children
596                                      top-child 'include-self))
597                   (setq next-top (car insert-msgs))
598                   (setq ent (wl-thread-get-entity next-top))
599                   (when (and
600                          (wl-thread-entity-get-opened entity) ;; open
601                          (not (wl-thread-entity-get-opened ent)) ;; close
602                          (setq grandchildren
603                                (wl-thread-entity-get-children ent))
604                          (wl-summary-jump-to-msg next-top))
605                     (forward-line 1)
606                     (setq insert-msgs (append (cdr insert-msgs) grandchildren)))
607                   (when top-entity (wl-thread-entity-set-opened top-entity t))
608                   (when ent (wl-thread-entity-set-opened ent t)))
609               (when (not invisible-top)
610                 (setq insert-msgs (wl-thread-get-exist-children msg))
611                 ;; First msg always opened, because first msg maybe becomes top.
612                 (if (setq ent (wl-thread-get-entity (car insert-msgs)))
613                     (wl-thread-entity-set-opened ent t))))
614             ;; insert children
615             (while insert-msgs
616               ;; if no exists in summary, insert entity.
617               (when (and (car insert-msgs)
618                          (not (wl-summary-jump-to-msg (car insert-msgs))))
619                 (setq ent (wl-thread-get-entity (car insert-msgs)))
620                 (wl-thread-insert-entity 0 ; no mean now...
621                                          ent entity nil))
622               (setq insert-msgs (cdr insert-msgs))))))
623       (if update
624           ;; modify buffer.
625           (while update-msgs
626             (wl-thread-update-line-on-buffer-sub nil (pop update-msgs)))
627         ;; don't update buffer
628         update-msgs)))) ; return value
629
630 (defun wl-thread-insert-message (message-entity
631                                  msg parent-msg &optional update linked)
632   "Insert MSG to the entity.
633 When optional argument UPDATE is non-nil,
634 Message is inserted to the summary buffer."
635   (let ((parent (wl-thread-get-entity parent-msg))
636         child-entity invisible-top)
637 ;;; Update the thread view...not implemented yet.
638 ;;;  (when force-insert
639 ;;;    (if parent
640 ;;;       (wl-thread-entity-force-open parent))
641     (when (and wl-summary-max-thread-depth parent)
642       (let ((cur parent)
643             (depth 0))
644         (while cur
645           (incf depth)
646           (setq cur (wl-thread-entity-get-parent-entity cur)))
647         (when (> depth wl-summary-max-thread-depth)
648           (setq parent nil
649                 parent-msg nil))))
650     (if parent
651         ;; insert as children.
652         (wl-thread-entity-insert-as-children
653          parent
654          (setq child-entity (wl-thread-create-entity
655                              msg (nth 0 parent) nil linked)))
656       ;; insert as top message.
657       (wl-thread-entity-insert-as-top
658        (wl-thread-create-entity msg nil)))
659     (if update
660         (if (not (setq invisible-top
661                        (wl-thread-entity-parent-invisible-p child-entity)))
662             ;; visible.
663             (progn
664               (wl-summary-update-thread
665                message-entity
666                child-entity
667                (elmo-message-entity wl-summary-buffer-elmo-folder
668                                     parent-msg))
669               (when parent
670                 ;; use thread structure.
671                 ;;(wl-thread-entity-get-nearly-older-brother
672                 ;; child-entity parent))) ; return value
673                 (wl-thread-entity-get-number parent))) ; return value
674 ;;;           (setq beg (point))
675 ;;;           (wl-thread-goto-bottom-of-sub-thread)
676 ;;;           (wl-thread-update-indent-string-region beg (point)))
677           ;; currently invisible.. update closed line.
678           (wl-thread-update-children-number invisible-top)
679           nil))))
680
681 ;(defun wl-thread-get-parent-list (msgs)
682 ;  ;; return ancestors
683 ;  (let* ((msgs2 msgs)
684 ;        myself)
685 ;    (while msgs2
686 ;      (setq myself (car msgs2)
687 ;           msgs2 (cdr msgs2))
688 ;      (while (not (eq myself (car msgs2)))
689 ;       (if (wl-thread-descendant-p myself (car msgs2))
690 ;           (setq msgs (delq (car msgs2) msgs)))
691 ;       (setq msgs2 (or (cdr msgs2) msgs)))
692 ;      (setq msgs2 (cdr msgs2)))
693 ;    msgs))
694
695 (defun wl-thread-get-parent-list (msgs)
696   ;; return connected ancestors
697   (let ((ptr msgs)
698         parent ret)
699     (while (car ptr)
700       (setq parent (wl-thread-entity-get-parent (wl-thread-get-entity (car ptr))))
701       (when (or (not parent)
702                 (not (memq parent msgs)))
703         (setq ret (append ret (list (car ptr)))))
704       (setq ptr (cdr ptr)))
705     ret))
706
707 (defun wl-thread-update-indent-string-thread (top-list)
708   (let* ((top-list (wl-thread-get-parent-list top-list))
709          (num (length top-list))
710          (i 0)
711          beg)
712     (while top-list
713       (when (> num elmo-display-progress-threshold)
714         (setq i (1+ i))
715         (when (or (zerop (% i 5)) (= i num))
716           (elmo-display-progress
717            'wl-thread-update-indent-string-thread
718            "Updating thread indent..."
719            (/ (* i 100) num))))
720       (when (car top-list)
721         (wl-summary-jump-to-msg (car top-list))
722         (setq beg (point))
723         (wl-thread-goto-bottom-of-sub-thread)
724         (wl-thread-update-indent-string-region beg (point)))
725       (setq top-list (cdr top-list)))
726     (message "Updating thread indent...done")))
727
728 (defun wl-thread-update-children-number (entity)
729   "Update the children number."
730   (wl-thread-update-line-on-buffer (wl-thread-entity-get-number entity)))
731
732 ;;
733 ;; Thread oriented commands.
734 ;;
735 (defun wl-thread-call-region-func (func &optional arg)
736   (save-excursion
737     (if arg
738         (wl-summary-goto-top-of-current-thread)
739       (beginning-of-line))
740     (let ((beg (point)))
741       (wl-thread-goto-bottom-of-sub-thread)
742       (funcall func beg (point)))))
743
744 (defun wl-thread-prefetch (&optional arg)
745   (interactive "P")
746   (wl-thread-call-region-func 'wl-summary-prefetch-region arg))
747
748 (defun wl-thread-mark-as-read (&optional arg)
749   (interactive "P")
750   (wl-thread-call-region-func 'wl-summary-mark-as-read-region arg))
751
752 (defun wl-thread-mark-as-unread (&optional arg)
753   (interactive "P")
754   (wl-thread-call-region-func 'wl-summary-mark-as-unread-region arg))
755
756 (defun wl-thread-mark-as-important (&optional arg)
757   (interactive "P")
758   (wl-thread-call-region-func 'wl-summary-mark-as-important-region arg))
759
760 (defun wl-thread-set-flags (&optional arg)
761   (interactive "P")
762   (wl-thread-call-region-func 'wl-summary-set-flags-region arg))
763
764 (defun wl-thread-mark-as-answered (&optional arg)
765   (interactive "P")
766   (wl-thread-call-region-func 'wl-summary-mark-as-answered-region arg))
767
768 (defun wl-thread-unmark (&optional arg)
769   (interactive "P")
770   (wl-thread-call-region-func 'wl-summary-unmark-region arg))
771
772 (defun wl-thread-exec (&optional arg)
773   (interactive "P")
774   (wl-thread-call-region-func 'wl-summary-exec-region arg))
775
776 (defun wl-thread-save (&optional arg)
777   (interactive "P")
778   (wl-thread-call-region-func 'wl-summary-save-region arg))
779
780 (defun wl-thread-force-open (&optional msg-num)
781   "force open current folder"
782   (if msg-num
783       (wl-summary-jump-to-msg msg-num))
784   (let ((wl-thread-insert-force-opened t))
785     (wl-thread-open-close)))
786
787 (defun wl-thread-entity-force-open (entity)
788   (let ((wl-thread-insert-force-opened t)
789         notopen)
790     (if (null (wl-thread-entity-get-parent entity))
791         ;; top!!
792         (if (and (not (wl-thread-entity-get-opened entity))
793                  (wl-thread-entity-get-children entity))
794             (wl-thread-force-open (wl-thread-entity-get-number entity)))
795       (if (setq notopen (wl-thread-entity-parent-invisible-p entity))
796           (wl-thread-force-open (wl-thread-entity-get-number notopen))))))
797
798 (defun wl-thread-insert-top ()
799   (let ((elist wl-thread-entity-list)
800         (len (length wl-thread-entity-list))
801         (cur 0))
802     (wl-delete-all-overlays)
803     (while elist
804       (wl-thread-insert-entity
805        0
806        (wl-thread-get-entity (car elist))
807        nil
808        len)
809       (setq elist (cdr elist))
810       (when (> len elmo-display-progress-threshold)
811         (setq cur (1+ cur))
812         (if (or (zerop (% cur 2)) (= cur len))
813             (elmo-display-progress
814              'wl-thread-insert-top "Inserting message..."
815              (/ (* cur 100) len)))))))
816
817 (defsubst wl-thread-insert-entity-sub (indent entity parent-entity all)
818   (let (msg-num
819         message-entity
820         temp-mark
821         summary-line)
822     (when (setq msg-num (wl-thread-entity-get-number entity))
823       (unless all ; all...means no temp-mark.
824         (cond ((memq msg-num wl-summary-buffer-target-mark-list)
825                (setq temp-mark "*"))
826               ((setq temp-mark (wl-summary-registered-temp-mark msg-num))
827                (setq temp-mark (nth 1 temp-mark)))))
828       (unless temp-mark
829         (setq temp-mark (wl-summary-get-score-mark msg-num)))
830       (setq message-entity
831             (elmo-message-entity wl-summary-buffer-elmo-folder
832                                  (nth 0 entity)))
833 ;;;   (wl-delete-all-overlays)
834       (when message-entity
835         (wl-summary-insert-line
836          (wl-summary-create-line
837           message-entity
838           (elmo-message-entity wl-summary-buffer-elmo-folder
839                                (nth 0 parent-entity))
840           temp-mark
841           (elmo-message-flags wl-summary-buffer-elmo-folder
842                               msg-num)
843           (elmo-message-cached-p wl-summary-buffer-elmo-folder
844                                  msg-num)
845           (if wl-thread-insert-force-opened
846               nil
847             (wl-thread-maybe-get-children-num msg-num))
848           (wl-thread-make-indent-string entity)
849           (wl-thread-entity-get-linked entity)))))))
850
851 (defun wl-thread-insert-entity (indent entity parent-entity all)
852   "Insert thread entity in current buffer."
853   (let ((msgs (list (car entity)))
854         children msgs-stack)
855     (while msgs
856       (wl-thread-insert-entity-sub indent entity parent-entity all)
857       (setq msgs (cdr msgs))
858       (setq children (nth 2 entity))
859       (if children
860           ;; insert children
861           (when (or wl-thread-insert-force-opened
862                     (wl-thread-entity-get-opened entity))
863             (wl-thread-entity-set-opened entity t)
864             (wl-push msgs msgs-stack)
865             (setq msgs children
866                   indent (1+ indent)
867                   parent-entity entity)))
868       (unless msgs
869         (while (and (null msgs) msgs-stack)
870           (setq msgs (wl-pop msgs-stack))
871           (setq indent (1- indent)))
872         (when msgs
873           (setq entity (wl-thread-get-entity (car msgs)))
874           (setq parent-entity (wl-thread-entity-get-parent-entity entity))))
875       (setq entity (wl-thread-get-entity (car msgs))))))
876
877 (defun wl-thread-descendant-p (mynumber number)
878   (let ((cur (wl-thread-get-entity number))
879         num)
880     (catch 'done
881       (while cur
882         (setq cur (wl-thread-entity-get-parent-entity cur))
883         (if (null (setq num (wl-thread-entity-get-number cur))) ; top!
884             (throw 'done nil))
885         (if (and num
886                  (eq mynumber (wl-thread-entity-get-number cur)))
887             (throw 'done t)))
888       nil)))
889
890 ;; (defun wl-thread-goto-bottom-of-sub-thread ()
891 ;;   (interactive)
892 ;;   (let ((depth (wl-thread-get-depth-of-current-line)))
893 ;;     (forward-line 1)
894 ;;     (while (and (not (eobp))
895 ;;              (> (wl-thread-get-depth-of-current-line)
896 ;;                 depth))
897 ;;       (forward-line 1))
898 ;;     (beginning-of-line)))
899
900 (defun wl-thread-goto-bottom-of-sub-thread (&optional msg)
901   (interactive)
902   (let ((mynumber (or msg (wl-summary-message-number))))
903     (forward-line 1)
904     (while (wl-thread-descendant-p mynumber (wl-summary-message-number))
905       (forward-line 1))
906     (beginning-of-line)))
907
908 (defun wl-thread-remove-argument-region (beg end)
909   (save-excursion
910     (save-restriction
911       (narrow-to-region beg end)
912       (goto-char (point-min))
913       (while (not (eobp))
914         (wl-summary-remove-argument)
915         (forward-line 1)))))
916
917 (defun wl-thread-print-argument-region (beg end)
918   (if wl-summary-buffer-temp-mark-list
919       (save-excursion
920         (save-restriction
921           (narrow-to-region beg end)
922           (goto-char (point-min))
923           (while (not (eobp))
924             (let ((num (wl-summary-message-number))
925                   temp-mark pair)
926               (when (and (setq temp-mark
927                                (wl-summary-registered-temp-mark num))
928                          (nth 2 temp-mark)
929                          (setq pair (cons (nth 0 temp-mark)(nth 2 temp-mark))))
930                 (wl-summary-print-argument (car pair) (cdr pair))))
931             (forward-line 1))))))
932
933 (defsubst wl-thread-get-children-msgs (msg &optional visible-only)
934   (let ((msgs (list msg))
935         msgs-stack children
936         entity ret-val)
937     (while msgs
938       (wl-append ret-val (list (car msgs)))
939       (setq children (wl-thread-entity-get-children
940                       (setq entity (wl-thread-get-entity (car msgs)))))
941       (if (and visible-only
942                (not (wl-thread-entity-get-opened entity)))
943           (setq children nil))
944       (setq msgs (cdr msgs))
945       (if (null children)
946           (while (and (null msgs) msgs-stack)
947             (setq msgs (wl-pop msgs-stack)))
948         (wl-push msgs msgs-stack)
949         (setq msgs children)))
950     ret-val))
951
952 (defun wl-thread-get-children-msgs-uncached (msg &optional uncached-marks)
953   (let ((children-msgs (wl-thread-get-children-msgs msg))
954         mark uncached-list)
955     (while children-msgs
956       (if (and (not (eq msg (car children-msgs))) ; except itself
957                (or (and uncached-marks
958                         (setq mark (wl-summary-message-mark
959                                     wl-summary-buffer-elmo-folder
960                                     (car children-msgs)))
961                         (member mark uncached-marks))
962                    (and (not uncached-marks)
963                         (null (elmo-file-cache-exists-p
964                                (elmo-message-field
965                                 wl-summary-buffer-elmo-folder
966                                 (car children-msgs)
967                                 'message-id))))))
968           (wl-append uncached-list (list (car children-msgs))))
969       (setq children-msgs (cdr children-msgs)))
970     uncached-list))
971
972 (defun wl-thread-get-children-msgs-with-mark (msg mark)
973   (let ((children-msgs (wl-thread-get-children-msgs msg))
974         (check-func (cond ((string= mark "o")
975                            'wl-summary-msg-marked-as-refiled)
976                           ((string= mark "O")
977                            'wl-summary-msg-marked-as-copied)
978                           ((string= mark "D")
979                            'wl-summary-msg-marked-as-deleted)
980                           ((string= mark "*")
981                            'wl-summary-msg-marked-as-target)))
982         ret-val)
983     (while children-msgs
984       (if (funcall check-func (car children-msgs))
985           (wl-append ret-val (list (car children-msgs))))
986       (setq children-msgs (cdr children-msgs)))
987     ret-val))
988
989 (defun wl-thread-close (entity)
990   (let (depth beg)
991     (wl-thread-entity-set-opened entity nil)
992     (setq depth (wl-thread-get-depth-of-current-line))
993     (beginning-of-line)
994     (setq beg (point))
995     (wl-thread-goto-bottom-of-sub-thread)
996     (wl-thread-remove-argument-region beg
997                                       (point))
998     (forward-char -1)   ;; needed for mouse-face.
999     (delete-region beg (point))
1000     (wl-thread-insert-entity (- depth 1)
1001                              entity
1002                              (wl-thread-get-entity
1003                               (nth 3 entity))
1004                              nil)
1005     (delete-char 1) ; delete '\n'
1006     (wl-thread-print-argument-region beg (point))))
1007
1008 (defun wl-thread-open (entity)
1009   (let (depth beg)
1010     (beginning-of-line)
1011     (setq beg (point))
1012     (setq depth (wl-thread-get-depth-of-current-line))
1013     (end-of-line)
1014     (delete-region beg (point))
1015     (wl-thread-entity-set-opened entity t)
1016     (wl-thread-insert-entity depth ;(- depth 1)
1017                              entity
1018                              (wl-thread-get-entity
1019                               (nth 3 entity)) nil)
1020     (delete-char 1) ; delete '\n'
1021     (wl-thread-print-argument-region beg (point))))
1022
1023 (defun wl-thread-open-close (&optional force-open)
1024   (interactive "P")
1025   (when (eq wl-summary-buffer-view 'thread)
1026 ;;; (if (equal wl-thread-top-entity '(nil t nil nil))
1027 ;;;     (error "There's no thread structure"))
1028     (save-excursion
1029       (let ((inhibit-read-only t)
1030             (buffer-read-only nil)
1031             (wl-thread-insert-force-opened
1032              (or wl-thread-insert-force-opened
1033                  force-open))
1034             msg entity parent)
1035         (setq msg (wl-summary-message-number))
1036         (setq entity (wl-thread-get-entity msg))
1037         (if (wl-thread-entity-get-opened entity)
1038             ;; if already opened, close its child!
1039           (if (wl-thread-entity-get-children entity)
1040               (wl-thread-close entity)
1041             ;; opened, but has no children, close its parent!
1042             (when (setq parent (wl-thread-entity-get-parent entity))
1043               (wl-summary-jump-to-msg parent)
1044               (wl-thread-close
1045                (wl-thread-get-entity (wl-summary-message-number)))))
1046           ;; if closed (or it is just a thread bottom message)
1047           ;; has children, open it!
1048           (if (wl-thread-entity-get-children entity)
1049               (wl-thread-open entity)
1050             ;; closed, and has no children, close its parent!
1051             (setq msg (or (wl-thread-entity-get-parent entity)
1052                           (wl-thread-entity-get-number entity)))
1053             (when msg
1054               (wl-summary-jump-to-msg msg)
1055               (wl-thread-close
1056                (wl-thread-get-entity (wl-summary-message-number)))))))
1057       (when wl-summary-lazy-highlight
1058         (wl-highlight-summary-window))
1059       (wl-summary-set-message-modified)
1060       (set-buffer-modified-p nil))))
1061
1062 (defun wl-thread-get-depth-of-current-line ()
1063   (let ((entity (wl-thread-get-entity (wl-summary-message-number)))
1064         (depth 0)
1065         number)
1066     (while (setq number (wl-thread-entity-get-parent entity))
1067       (incf depth)
1068       (setq entity (wl-thread-get-entity number)))
1069     depth))
1070
1071 (defun wl-thread-update-indent-string-region (beg end)
1072   (interactive "r")
1073   (save-excursion
1074     (goto-char beg)
1075     (while (< (point) end)
1076       (save-excursion
1077         (wl-thread-update-line-on-buffer-sub nil (wl-summary-message-number)))
1078       (forward-line 1))))
1079
1080 (defsubst wl-thread-make-indent-string (entity)
1081   (let ((cur entity)
1082         (ret-val "")
1083         (space-str (wl-repeat-string wl-thread-space-str-internal
1084                                      (- wl-thread-indent-level-internal 1)))
1085         parent)
1086     (when (wl-thread-entity-get-number
1087            (setq parent (wl-thread-entity-get-parent-entity cur)))
1088       (if (wl-thread-entity-get-younger-brothers cur)
1089           (setq ret-val wl-thread-have-younger-brother-str-internal)
1090         (setq ret-val wl-thread-youngest-child-str-internal))
1091       (setq ret-val (concat ret-val
1092                             (wl-repeat-string
1093                              wl-thread-horizontal-str-internal
1094                              (- wl-thread-indent-level-internal 1))))
1095       (setq cur parent)
1096       (while (wl-thread-entity-get-number
1097               (wl-thread-entity-get-parent-entity cur))
1098         (if (wl-thread-entity-get-younger-brothers cur)
1099             (setq ret-val (concat wl-thread-vertical-str-internal
1100                                   space-str
1101                                   ret-val))
1102           (setq ret-val (concat wl-thread-space-str-internal
1103                                 space-str
1104                                 ret-val)))
1105         (setq cur (wl-thread-entity-get-parent-entity cur))))
1106     ret-val))
1107
1108 (defun wl-thread-set-parent (&optional parent-number)
1109   "Set current message's parent interactively."
1110   (interactive)
1111   (let ((number (wl-summary-message-number))
1112         (dst-parent (if (interactive-p)
1113                         (read-from-minibuffer "Parent Message (No.): ")))
1114         entity dst-parent-entity src-parent children
1115         update-msgs
1116         buffer-read-only)
1117     (if (string= dst-parent "")
1118         (setq dst-parent nil)
1119       (if (interactive-p)
1120           (setq dst-parent (string-to-int dst-parent))
1121         (setq dst-parent parent-number)))
1122     (if (and dst-parent
1123              (memq dst-parent (wl-thread-get-children-msgs number)))
1124         (error "Parent is children or myself"))
1125     (setq entity (wl-thread-get-entity number))
1126     (when (and number entity)
1127       ;; delete thread
1128       (setq update-msgs (wl-thread-delete-message number 'deep))
1129       ;; insert as child at new parent
1130       (setq dst-parent-entity (wl-thread-get-entity dst-parent))
1131       (if dst-parent-entity
1132           (progn
1133             (if (setq children
1134                       (wl-thread-entity-get-children dst-parent-entity))
1135                 (wl-append update-msgs
1136                            (wl-thread-get-children-msgs
1137                             (car (last children)) t)))
1138             (wl-thread-entity-set-children
1139              dst-parent-entity
1140              (append children (list number)))
1141             (wl-thread-entity-set-linked
1142              entity
1143              (let ((parent (elmo-message-entity-parent
1144                             wl-summary-buffer-elmo-folder
1145                             (elmo-message-entity
1146                              wl-summary-buffer-elmo-folder
1147                              number))))
1148                (or (null parent)
1149                    (/= parent-number (elmo-message-entity-number parent))))))
1150         ;; insert as top
1151         (wl-append wl-thread-entity-list (list number))
1152         (wl-thread-entity-set-linked entity nil))
1153
1154       ;; update my thread
1155       (wl-append update-msgs (wl-thread-get-children-msgs number t))
1156       (setq update-msgs (elmo-uniq-list update-msgs))
1157       (wl-thread-entity-set-parent entity dst-parent)
1158       ;; update thread on buffer
1159       (wl-thread-make-number-list)
1160       (wl-thread-update-line-msgs update-msgs t))))
1161
1162 (require 'product)
1163 (product-provide (provide 'wl-thread) (require 'wl-version))
1164
1165 ;;; wl-thread.el ends here