* wl-thread.el (wl-thread-force-open): Arranged.
[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   "Jump to the message with specified number in the current summary."
297   (interactive)
298   (let ((num (or number
299                  (string-to-int
300                   (read-from-minibuffer "Jump to Message(No.): ")))))
301     (wl-thread-entity-force-open (wl-thread-get-entity num))
302     (wl-summary-jump-to-msg num)))
303
304 (defun wl-thread-close-all ()
305   "Close all top threads."
306   (interactive)
307   (message "Closing all threads...")
308   (save-excursion
309     (let ((entities wl-thread-entity-list)
310           (cur 0)
311           (len (length wl-thread-entity-list)))
312       (while entities
313         (when (and (wl-thread-entity-get-opened (wl-thread-get-entity
314                                                  (car entities)))
315                    (wl-thread-entity-get-children (wl-thread-get-entity
316                                                    (car entities))))
317           (wl-summary-jump-to-msg (car entities))
318           (wl-thread-open-close))
319         (when (> len elmo-display-progress-threshold)
320           (setq cur (1+ cur))
321           (if (or (zerop (% cur 5)) (= cur len))
322               (elmo-display-progress
323                'wl-thread-close-all "Closing all threads..."
324                (/ (* cur 100) len))))
325         (setq entities (cdr entities)))))
326   (message "Closing all threads...done"))
327
328 (defun wl-thread-open-all ()
329   "Open all threads."
330   (interactive)
331   (message "Opening all threads...")
332   (save-excursion
333     (goto-char (point-min))
334     (let ((len (count-lines (point-min) (point-max)))
335           (cur 0)
336           entity)
337       (while (not (eobp))
338         (if (wl-thread-entity-get-opened
339              (setq entity (wl-thread-get-entity
340                            (wl-summary-message-number))))
341             (forward-line 1)
342           (wl-thread-force-open)
343           (wl-thread-goto-bottom-of-sub-thread))
344         (when (> len elmo-display-progress-threshold)
345           (setq cur (1+ cur))
346           (elmo-display-progress
347            'wl-thread-open-all "Opening all threads..."
348            (/ (* cur 100) len)))))
349     ;; Make sure to be 100%.
350     (elmo-display-progress
351      'wl-thread-open-all "Opening all threads..."
352      100))
353   (message "Opening all threads...done"))
354
355 (defun wl-thread-open-all-unread ()
356   (interactive)
357   (dolist (number (elmo-folder-list-flagged wl-summary-buffer-elmo-folder
358                                             'digest 'in-msgdb))
359     (wl-thread-entity-force-open (wl-thread-get-entity number))))
360
361 (defsubst wl-thread-maybe-get-children-num (msg)
362   (let ((entity (wl-thread-get-entity msg)))
363     (if (not (wl-thread-entity-get-opened entity))
364         (wl-thread-entity-get-children-num entity))))
365
366 (defsubst wl-thread-update-line-on-buffer-sub (entity msg &optional parent-msg)
367   (let* ((entity (or entity (wl-thread-get-entity msg)))
368          (parent-msg (or parent-msg (wl-thread-entity-get-parent entity)))
369          (buffer-read-only nil)
370          (inhibit-read-only t)
371          message-entity temp-mark summary-line invisible-top)
372     (if (wl-thread-delete-line-from-buffer msg)
373         (progn
374           (cond
375            ((memq msg wl-summary-buffer-target-mark-list)
376             (setq temp-mark "*"))
377            ((setq temp-mark (wl-summary-registered-temp-mark msg))
378             (setq temp-mark (nth 1 temp-mark)))
379            (t (setq temp-mark (wl-summary-get-score-mark msg))))
380           (when (setq message-entity
381                       (elmo-message-entity wl-summary-buffer-elmo-folder
382                                            msg))
383             (wl-summary-insert-line
384              (wl-summary-create-line
385               message-entity
386               (elmo-message-entity wl-summary-buffer-elmo-folder
387                                    parent-msg)
388               temp-mark
389               (elmo-message-status wl-summary-buffer-elmo-folder msg)
390               (if wl-thread-insert-force-opened
391                   nil
392                 (wl-thread-maybe-get-children-num msg))
393               (wl-thread-make-indent-string entity)
394               (wl-thread-entity-get-linked entity)))))
395       ;; insert thread (moving thread)
396       (if (not (setq invisible-top
397                      (wl-thread-entity-parent-invisible-p entity)))
398           (wl-summary-update-thread
399            (elmo-message-entity wl-summary-buffer-elmo-folder msg)
400            entity
401            (and parent-msg
402                 (elmo-message-entity wl-summary-buffer-elmo-folder
403                                      parent-msg)))
404         ;; currently invisible.. update closed line.
405         (wl-thread-update-children-number invisible-top)))))
406
407 (defun wl-thread-update-line-on-buffer (&optional msg parent-msg updates)
408   (interactive)
409   (let ((msgs (list (or msg (wl-summary-message-number))))
410         entity children msgs-stack)
411    (while msgs
412     (setq msg (wl-pop msgs))
413     (setq updates (and updates (delete msg updates)))
414     (setq entity (wl-thread-get-entity msg))
415     (wl-thread-update-line-on-buffer-sub entity msg parent-msg)
416     ;;
417     (setq children (wl-thread-entity-get-children entity))
418     (if children
419         ;; update children
420         (when (wl-thread-entity-get-opened entity)
421           (wl-push msgs msgs-stack)
422           (setq parent-msg msg
423                 msgs children))
424       (unless msgs
425         (while (and (null msgs) msgs-stack)
426           (setq msgs (wl-pop msgs-stack)))
427         (when msgs
428           (setq parent-msg
429                 (wl-thread-entity-get-number
430                  (wl-thread-entity-get-parent-entity
431                   (wl-thread-get-entity (car msgs)))))))))
432    updates))
433
434 (defun wl-thread-update-line-msgs (msgs &optional no-msg)
435   (wl-delete-all-overlays)
436   (let ((i 0)
437         (updates msgs)
438         len)
439 ;;; (while msgs
440 ;;;   (setq updates
441 ;;;         (append updates
442 ;;;                 (wl-thread-get-children-msgs (car msgs))))
443 ;;;   (setq msgs (cdr msgs)))
444 ;;; (setq updates (elmo-uniq-list updates))
445     (setq len (length updates))
446     (while updates
447       (wl-thread-update-line-on-buffer-sub nil (car updates))
448       (setq updates (cdr updates))
449       (when (and (not no-msg)
450                  (> len elmo-display-progress-threshold))
451         (setq i (1+ i))
452         (if (or (zerop (% i 5)) (= i len))
453             (elmo-display-progress
454              'wl-thread-update-line-msgs "Updating deleted thread..."
455              (/ (* i 100) len)))))))
456
457 (defun wl-thread-delete-line-from-buffer (msg)
458   "Simply delete msg line."
459   (let (beg)
460     (if (wl-summary-jump-to-msg msg)
461         (progn
462           (setq beg (point))
463           (forward-line 1)
464           (delete-region beg (point))
465           t)
466       nil)))
467
468 (defun wl-thread-cleanup-symbols (msgs)
469   (let (entity)
470     (while msgs
471       (when (setq entity (wl-thread-get-entity (car msgs)))
472         ;; delete entity.
473         (setq wl-thread-entities (delq entity wl-thread-entities))
474         ;; free symbol.
475         (elmo-clear-hash-val (format "#%d" (car msgs))
476                              wl-thread-entity-hashtb))
477       (setq msgs (cdr msgs)))))
478
479 (defun wl-thread-get-exist-children (msg &optional include-self)
480   (let ((msgs (list msg))
481         msgs-stack children
482         entity ret-val)
483     (while msgs
484       (setq children (wl-thread-entity-get-children
485                       (setq entity (wl-thread-get-entity (car msgs)))))
486       (when (elmo-message-entity wl-summary-buffer-elmo-folder (car msgs))
487         (wl-append ret-val (list (car msgs)))
488         (setq children nil))
489       (setq msgs (cdr msgs))
490       (if (null children)
491           (while (and (null msgs) msgs-stack)
492             (setq msgs (wl-pop msgs-stack)))
493         (wl-push msgs msgs-stack)
494         (setq msgs children)))
495     (unless include-self (setq ret-val (delq msg ret-val)))
496     ret-val))
497
498 (defun wl-thread-delete-message (msg &optional deep update)
499   "Delete MSG from entity and buffer."
500   (save-excursion
501     (let ((entity (wl-thread-get-entity msg))
502           top-child top-entity update-msgs invisible-top)
503       (setq wl-summary-buffer-number-list
504             (delq msg wl-summary-buffer-number-list))
505       (when entity
506         (when deep
507           (setq wl-summary-buffer-number-list
508                 (elmo-list-delete
509                  (wl-thread-entity-get-descendant entity)
510                  wl-summary-buffer-number-list
511                  #'delq)))
512         (let ((parent (wl-thread-entity-get-parent-entity entity)))
513           (if parent
514               ;; has parent.
515               (let (children
516                     (older-brothers (wl-thread-entity-get-older-brothers
517                                      entity parent))
518                     (younger-brothers (wl-thread-entity-get-younger-brothers
519                                        entity parent)))
520                 (unless deep
521                   (setq children (wl-thread-entity-get-children entity))
522                   (wl-thread-reparent-children
523                    children (wl-thread-entity-get-number parent))
524                   (setq update-msgs
525                         (apply (function nconc)
526                                update-msgs
527                                (mapcar
528                                 (function
529                                  (lambda (message)
530                                    (wl-thread-get-children-msgs message t)))
531                                 children))))
532                 (wl-thread-entity-set-children
533                  parent (append older-brothers children younger-brothers))
534                 ;; If chidren and younger-brothers do not exist,
535                 ;; update nearly older brother.
536                 (when (and older-brothers
537                            (not younger-brothers)
538                            (not children))
539                   (wl-append
540                    update-msgs
541                    (wl-thread-get-children-msgs (car (last older-brothers))))))
542             ;; top...oldest child becomes top.
543             (unless deep
544               (let ((children (wl-thread-entity-get-children entity)))
545                 (when children
546                   (setq top-child (car children)
547                         children (cdr children))
548                   (setq top-entity (wl-thread-get-entity top-child))
549                   (wl-thread-entity-set-parent top-entity nil)
550                   (wl-thread-entity-set-linked top-entity nil)
551                   (wl-append update-msgs
552                              (wl-thread-get-children-msgs top-child t)))
553                 (when children
554                   (wl-thread-entity-set-children
555                    top-entity
556                    (append
557                     (wl-thread-entity-get-children top-entity)
558                     children))
559                   (wl-thread-reparent-children children top-child)
560                   (wl-append update-msgs children))))
561             ;; delete myself from top list.
562             (let ((match (memq msg wl-thread-entity-list)))
563               (when match
564                 (if top-child
565                     (setcar match top-child)
566                   (setq wl-thread-entity-list
567                         (delq msg wl-thread-entity-list))))))))
568       ;;
569       (if deep
570           ;; delete thread on buffer
571           (when (wl-summary-jump-to-msg msg)
572             (let ((beg (point)))
573               (wl-thread-goto-bottom-of-sub-thread)
574               (delete-region beg (point))))
575         ;; delete myself from buffer.
576         (unless (wl-thread-delete-line-from-buffer msg)
577           ;; jump to suitable point.
578           ;; just upon the oldest younger-brother of my top.
579           (setq invisible-top
580                 (car (wl-thread-entity-parent-invisible-p entity)))
581           (if invisible-top
582               (progn
583                 (wl-append update-msgs (list invisible-top))
584                 (wl-summary-jump-to-msg invisible-top))
585             (goto-char (point-max))))
586
587         ;; insert children if thread is closed or delete top.
588         (when (or top-child
589                   (not (wl-thread-entity-get-opened entity)))
590           (let (next-top insert-msgs ent grandchildren)
591             (if top-child
592                 (progn
593                   (setq insert-msgs (wl-thread-get-exist-children
594                                      top-child 'include-self))
595                   (setq next-top (car insert-msgs))
596                   (setq ent (wl-thread-get-entity next-top))
597                   (when (and
598                          (wl-thread-entity-get-opened entity) ;; open
599                          (not (wl-thread-entity-get-opened ent)) ;; close
600                          (setq grandchildren
601                                (wl-thread-entity-get-children ent))
602                          (wl-summary-jump-to-msg next-top))
603                     (forward-line 1)
604                     (setq insert-msgs (append (cdr insert-msgs) grandchildren)))
605                   (when top-entity (wl-thread-entity-set-opened top-entity t))
606                   (when ent (wl-thread-entity-set-opened ent t)))
607               (when (not invisible-top)
608                 (setq insert-msgs (wl-thread-get-exist-children msg))
609                 ;; First msg always opened, because first msg maybe becomes top.
610                 (if (setq ent (wl-thread-get-entity (car insert-msgs)))
611                     (wl-thread-entity-set-opened ent t))))
612             ;; insert children
613             (while insert-msgs
614               ;; if no exists in summary, insert entity.
615               (when (and (car insert-msgs)
616                          (not (wl-summary-jump-to-msg (car insert-msgs))))
617                 (setq ent (wl-thread-get-entity (car insert-msgs)))
618                 (wl-thread-insert-entity 0 ; no mean now...
619                                          ent entity nil))
620               (setq insert-msgs (cdr insert-msgs))))))
621       (if update
622           ;; modify buffer.
623           (while update-msgs
624             (wl-thread-update-line-on-buffer-sub nil (pop update-msgs)))
625         ;; don't update buffer
626         update-msgs)))) ; return value
627
628 (defun wl-thread-insert-message (message-entity
629                                  msg parent-msg &optional update linked)
630   "Insert MSG to the entity.
631 When optional argument UPDATE is non-nil,
632 Message is inserted to the summary buffer."
633   (let ((parent (wl-thread-get-entity parent-msg))
634         child-entity invisible-top)
635 ;;; Update the thread view...not implemented yet.
636 ;;;  (when force-insert
637 ;;;    (if parent
638 ;;;       (wl-thread-entity-force-open parent))
639     (when (and wl-summary-max-thread-depth parent)
640       (let ((cur parent)
641             (depth 0))
642         (while cur
643           (incf depth)
644           (setq cur (wl-thread-entity-get-parent-entity cur)))
645         (when (> depth wl-summary-max-thread-depth)
646           (setq parent nil
647                 parent-msg nil))))
648     (if parent
649         ;; insert as children.
650         (wl-thread-entity-insert-as-children
651          parent
652          (setq child-entity (wl-thread-create-entity
653                              msg (nth 0 parent) nil linked)))
654       ;; insert as top message.
655       (wl-thread-entity-insert-as-top
656        (wl-thread-create-entity msg nil)))
657     (if update
658         (if (not (setq invisible-top
659                        (wl-thread-entity-parent-invisible-p child-entity)))
660             ;; visible.
661             (progn
662               (wl-summary-update-thread
663                message-entity
664                child-entity
665                (elmo-message-entity wl-summary-buffer-elmo-folder
666                                     parent-msg))
667               (when parent
668                 ;; use thread structure.
669                 ;;(wl-thread-entity-get-nearly-older-brother
670                 ;; child-entity parent))) ; return value
671                 (wl-thread-entity-get-number parent))) ; return value
672 ;;;           (setq beg (point))
673 ;;;           (wl-thread-goto-bottom-of-sub-thread)
674 ;;;           (wl-thread-update-indent-string-region beg (point)))
675           ;; currently invisible.. update closed line.
676           (wl-thread-update-children-number invisible-top)
677           nil))))
678
679 ;(defun wl-thread-get-parent-list (msgs)
680 ;  ;; return ancestors
681 ;  (let* ((msgs2 msgs)
682 ;        myself)
683 ;    (while msgs2
684 ;      (setq myself (car msgs2)
685 ;           msgs2 (cdr msgs2))
686 ;      (while (not (eq myself (car msgs2)))
687 ;       (if (wl-thread-descendant-p myself (car msgs2))
688 ;           (setq msgs (delq (car msgs2) msgs)))
689 ;       (setq msgs2 (or (cdr msgs2) msgs)))
690 ;      (setq msgs2 (cdr msgs2)))
691 ;    msgs))
692
693 (defun wl-thread-get-parent-list (msgs)
694   ;; return connected ancestors
695   (let ((ptr msgs)
696         parent ret)
697     (while (car ptr)
698       (setq parent (wl-thread-entity-get-parent (wl-thread-get-entity (car ptr))))
699       (when (or (not parent)
700                 (not (memq parent msgs)))
701         (setq ret (append ret (list (car ptr)))))
702       (setq ptr (cdr ptr)))
703     ret))
704
705 (defun wl-thread-update-indent-string-thread (top-list)
706   (let* ((top-list (wl-thread-get-parent-list top-list))
707          (num (length top-list))
708          (i 0)
709          beg)
710     (while top-list
711       (when (> num elmo-display-progress-threshold)
712         (setq i (1+ i))
713         (when (or (zerop (% i 5)) (= i num))
714           (elmo-display-progress
715            'wl-thread-update-indent-string-thread
716            "Updating thread indent..."
717            (/ (* i 100) num))))
718       (when (car top-list)
719         (wl-summary-jump-to-msg (car top-list))
720         (setq beg (point))
721         (wl-thread-goto-bottom-of-sub-thread)
722         (wl-thread-update-indent-string-region beg (point)))
723       (setq top-list (cdr top-list)))
724     (message "Updating thread indent...done")))
725
726 (defun wl-thread-update-children-number (entity)
727   "Update the children number."
728   (wl-thread-update-line-on-buffer (wl-thread-entity-get-number entity)))
729
730 ;;
731 ;; Thread oriented commands.
732 ;;
733 (defun wl-thread-call-region-func (func &optional arg)
734   (save-excursion
735     (if arg
736         (wl-summary-goto-top-of-current-thread)
737       (beginning-of-line))
738     (let ((beg (point)))
739       (wl-thread-goto-bottom-of-sub-thread)
740       (funcall func beg (point)))))
741
742 (defun wl-thread-prefetch (&optional arg)
743   (interactive "P")
744   (wl-thread-call-region-func 'wl-summary-prefetch-region arg))
745
746 (defun wl-thread-mark-as-read (&optional arg)
747   (interactive "P")
748   (wl-thread-call-region-func 'wl-summary-mark-as-read-region arg))
749
750 (defun wl-thread-mark-as-unread (&optional arg)
751   (interactive "P")
752   (wl-thread-call-region-func 'wl-summary-mark-as-unread-region arg))
753
754 (defun wl-thread-mark-as-important (&optional arg)
755   (interactive "P")
756   (wl-thread-call-region-func 'wl-summary-mark-as-important-region arg))
757
758 (defun wl-thread-set-flags (&optional arg)
759   (interactive "P")
760   (wl-thread-call-region-func 'wl-summary-set-flags-region arg))
761
762 (defun wl-thread-mark-as-answered (&optional arg)
763   (interactive "P")
764   (wl-thread-call-region-func 'wl-summary-mark-as-answered-region arg))
765
766 (defun wl-thread-recover-messages (&optional arg)
767   "Recover killed messages which are contained current thread."
768   (interactive "P")
769   (wl-thread-call-region-func 'wl-summary-recover-messages-region arg))
770
771 (defun wl-thread-unmark (&optional arg)
772   (interactive "P")
773   (wl-thread-call-region-func 'wl-summary-unmark-region arg))
774
775 (defun wl-thread-exec (&optional arg)
776   (interactive "P")
777   (wl-thread-call-region-func 'wl-summary-exec-region arg))
778
779 (defun wl-thread-save (&optional arg)
780   (interactive "P")
781   (wl-thread-call-region-func 'wl-summary-save-region arg))
782
783 (defun wl-thread-force-open (&optional msg-num)
784   "force open current folder"
785   (when msg-num
786     (wl-summary-jump-to-msg msg-num))
787   (wl-thread-open-close 'force-open))
788
789 (defun wl-thread-entity-force-open (entity)
790   (let ((wl-thread-insert-force-opened t)
791         notopen)
792     (if (null (wl-thread-entity-get-parent entity))
793         ;; top!!
794         (if (and (not (wl-thread-entity-get-opened entity))
795                  (wl-thread-entity-get-children entity))
796             (wl-thread-force-open (wl-thread-entity-get-number entity)))
797       (if (setq notopen (wl-thread-entity-parent-invisible-p entity))
798           (wl-thread-force-open (wl-thread-entity-get-number notopen))))))
799
800 (defun wl-thread-insert-top ()
801   (let ((elist wl-thread-entity-list)
802         (len (length wl-thread-entity-list))
803         (cur 0))
804     (wl-delete-all-overlays)
805     (while elist
806       (wl-thread-insert-entity
807        0
808        (wl-thread-get-entity (car elist))
809        nil
810        len)
811       (setq elist (cdr elist))
812       (when (> len elmo-display-progress-threshold)
813         (setq cur (1+ cur))
814         (if (or (zerop (% cur 2)) (= cur len))
815             (elmo-display-progress
816              'wl-thread-insert-top "Inserting message..."
817              (/ (* cur 100) len)))))))
818
819 (defsubst wl-thread-insert-entity-sub (indent entity parent-entity all)
820   (let (msg-num
821         message-entity
822         temp-mark
823         summary-line)
824     (when (setq msg-num (wl-thread-entity-get-number entity))
825       (unless all ; all...means no temp-mark.
826         (cond ((memq msg-num wl-summary-buffer-target-mark-list)
827                (setq temp-mark "*"))
828               ((setq temp-mark (wl-summary-registered-temp-mark msg-num))
829                (setq temp-mark (nth 1 temp-mark)))))
830       (unless temp-mark
831         (setq temp-mark (wl-summary-get-score-mark msg-num)))
832       (setq message-entity
833             (elmo-message-entity wl-summary-buffer-elmo-folder
834                                  (nth 0 entity)))
835 ;;;   (wl-delete-all-overlays)
836       (when message-entity
837         (wl-summary-insert-line
838          (wl-summary-create-line
839           message-entity
840           (elmo-message-entity wl-summary-buffer-elmo-folder
841                                (nth 0 parent-entity))
842           temp-mark
843           (elmo-message-status wl-summary-buffer-elmo-folder msg-num)
844           (if wl-thread-insert-force-opened
845               nil
846             (wl-thread-maybe-get-children-num msg-num))
847           (wl-thread-make-indent-string entity)
848           (wl-thread-entity-get-linked entity)))))))
849
850 (defun wl-thread-insert-entity (indent entity parent-entity all)
851   "Insert thread entity in current buffer."
852   (let ((msgs (list (car entity)))
853         children msgs-stack)
854     (while msgs
855       (wl-thread-insert-entity-sub indent entity parent-entity all)
856       (setq msgs (cdr msgs))
857       (setq children (nth 2 entity))
858       (if children
859           ;; insert children
860           (when (or wl-thread-insert-force-opened
861                     (wl-thread-entity-get-opened entity))
862             (wl-thread-entity-set-opened entity t)
863             (wl-push msgs msgs-stack)
864             (setq msgs children
865                   indent (1+ indent)
866                   parent-entity entity)))
867       (unless msgs
868         (while (and (null msgs) msgs-stack)
869           (setq msgs (wl-pop msgs-stack))
870           (setq indent (1- indent)))
871         (when msgs
872           (setq entity (wl-thread-get-entity (car msgs)))
873           (setq parent-entity (wl-thread-entity-get-parent-entity entity))))
874       (setq entity (wl-thread-get-entity (car msgs))))))
875
876 (defun wl-thread-descendant-p (mynumber number)
877   (let ((cur (wl-thread-get-entity number))
878         num)
879     (catch 'done
880       (while cur
881         (setq cur (wl-thread-entity-get-parent-entity cur))
882         (if (null (setq num (wl-thread-entity-get-number cur))) ; top!
883             (throw 'done nil))
884         (if (and num
885                  (eq mynumber (wl-thread-entity-get-number cur)))
886             (throw 'done t)))
887       nil)))
888
889 ;; (defun wl-thread-goto-bottom-of-sub-thread ()
890 ;;   (interactive)
891 ;;   (let ((depth (wl-thread-get-depth-of-current-line)))
892 ;;     (forward-line 1)
893 ;;     (while (and (not (eobp))
894 ;;              (> (wl-thread-get-depth-of-current-line)
895 ;;                 depth))
896 ;;       (forward-line 1))
897 ;;     (beginning-of-line)))
898
899 (defun wl-thread-goto-bottom-of-sub-thread (&optional msg)
900   (interactive)
901   (let ((mynumber (or msg (wl-summary-message-number))))
902     (forward-line 1)
903     (while (wl-thread-descendant-p mynumber (wl-summary-message-number))
904       (forward-line 1))
905     (beginning-of-line)))
906
907 (defun wl-thread-remove-argument-region (beg end)
908   (save-excursion
909     (save-restriction
910       (narrow-to-region beg end)
911       (goto-char (point-min))
912       (while (not (eobp))
913         (wl-summary-remove-argument)
914         (forward-line 1)))))
915
916 (defun wl-thread-print-argument-region (beg end)
917   (if wl-summary-buffer-temp-mark-list
918       (save-excursion
919         (save-restriction
920           (narrow-to-region beg end)
921           (goto-char (point-min))
922           (while (not (eobp))
923             (let ((num (wl-summary-message-number))
924                   temp-mark pair)
925               (when (and (setq temp-mark
926                                (wl-summary-registered-temp-mark num))
927                          (nth 2 temp-mark)
928                          (setq pair (cons (nth 0 temp-mark)(nth 2 temp-mark))))
929                 (wl-summary-print-argument (car pair) (cdr pair))))
930             (forward-line 1))))))
931
932 (defsubst wl-thread-get-children-msgs (msg &optional visible-only)
933   (let ((msgs (list msg))
934         msgs-stack children
935         entity ret-val)
936     (while msgs
937       (wl-append ret-val (list (car msgs)))
938       (setq children (wl-thread-entity-get-children
939                       (setq entity (wl-thread-get-entity (car msgs)))))
940       (if (and visible-only
941                (not (wl-thread-entity-get-opened entity)))
942           (setq children nil))
943       (setq msgs (cdr msgs))
944       (if (null children)
945           (while (and (null msgs) msgs-stack)
946             (setq msgs (wl-pop msgs-stack)))
947         (wl-push msgs msgs-stack)
948         (setq msgs children)))
949     ret-val))
950
951 (defun wl-thread-get-children-msgs-uncached (msg &optional uncached-marks)
952   (let ((children-msgs (wl-thread-get-children-msgs msg))
953         mark uncached-list)
954     (while children-msgs
955       (if (and (not (eq msg (car children-msgs))) ; except itself
956                (or (and uncached-marks
957                         (setq mark (wl-summary-message-mark
958                                     wl-summary-buffer-elmo-folder
959                                     (car children-msgs)))
960                         (member mark uncached-marks))
961                    (and (not uncached-marks)
962                         (null (elmo-file-cache-exists-p
963                                (elmo-message-field
964                                 wl-summary-buffer-elmo-folder
965                                 (car children-msgs)
966                                 'message-id))))))
967           (wl-append uncached-list (list (car children-msgs))))
968       (setq children-msgs (cdr children-msgs)))
969     uncached-list))
970
971 (defun wl-thread-get-children-msgs-with-mark (msg mark)
972   (let ((children-msgs (wl-thread-get-children-msgs msg))
973         (check-func (cond ((string= mark "o")
974                            'wl-summary-msg-marked-as-refiled)
975                           ((string= mark "O")
976                            'wl-summary-msg-marked-as-copied)
977                           ((string= mark "D")
978                            'wl-summary-msg-marked-as-deleted)
979                           ((string= mark "*")
980                            'wl-summary-msg-marked-as-target)))
981         ret-val)
982     (while children-msgs
983       (if (funcall check-func (car children-msgs))
984           (wl-append ret-val (list (car children-msgs))))
985       (setq children-msgs (cdr children-msgs)))
986     ret-val))
987
988 (defun wl-thread-close (entity)
989   (let (depth beg)
990     (wl-thread-entity-set-opened entity nil)
991     (setq depth (wl-thread-get-depth-of-current-line))
992     (beginning-of-line)
993     (setq beg (point))
994     (wl-thread-goto-bottom-of-sub-thread)
995     (wl-thread-remove-argument-region beg
996                                       (point))
997     (forward-char -1)   ;; needed for mouse-face.
998     (delete-region beg (point))
999     (wl-thread-insert-entity (- depth 1)
1000                              entity
1001                              (wl-thread-get-entity
1002                               (nth 3 entity))
1003                              nil)
1004     (delete-char 1) ; delete '\n'
1005     (wl-thread-print-argument-region beg (point))))
1006
1007 (defun wl-thread-open (entity)
1008   (let (depth beg)
1009     (beginning-of-line)
1010     (setq beg (point))
1011     (setq depth (wl-thread-get-depth-of-current-line))
1012     (end-of-line)
1013     (delete-region beg (point))
1014     (wl-thread-entity-set-opened entity t)
1015     (wl-thread-insert-entity depth ;(- depth 1)
1016                              entity
1017                              (wl-thread-get-entity
1018                               (nth 3 entity)) nil)
1019     (delete-char 1) ; delete '\n'
1020     (wl-thread-print-argument-region beg (point))))
1021
1022 (defun wl-thread-open-close (&optional force-open)
1023   (interactive "P")
1024   (when (eq wl-summary-buffer-view 'thread)
1025 ;;; (if (equal wl-thread-top-entity '(nil t nil nil))
1026 ;;;     (error "There's no thread structure"))
1027     (save-excursion
1028       (let ((inhibit-read-only t)
1029             (buffer-read-only nil)
1030             (wl-thread-insert-force-opened
1031              (or wl-thread-insert-force-opened
1032                  force-open))
1033             msg entity parent)
1034         (setq msg (wl-summary-message-number))
1035         (setq entity (wl-thread-get-entity msg))
1036         (if (wl-thread-entity-get-opened entity)
1037             ;; if already opened, close its child!
1038           (if (wl-thread-entity-get-children entity)
1039               (wl-thread-close entity)
1040             ;; opened, but has no children, close its parent!
1041             (when (setq parent (wl-thread-entity-get-parent entity))
1042               (wl-summary-jump-to-msg parent)
1043               (wl-thread-close
1044                (wl-thread-get-entity (wl-summary-message-number)))))
1045           ;; if closed (or it is just a thread bottom message)
1046           ;; has children, open it!
1047           (if (wl-thread-entity-get-children entity)
1048               (wl-thread-open entity)
1049             ;; closed, and has no children, close its parent!
1050             (setq msg (or (wl-thread-entity-get-parent entity)
1051                           (wl-thread-entity-get-number entity)))
1052             (when msg
1053               (wl-summary-jump-to-msg msg)
1054               (wl-thread-close
1055                (wl-thread-get-entity (wl-summary-message-number)))))))
1056       (when wl-summary-lazy-highlight
1057         (wl-highlight-summary-window))
1058       (wl-summary-set-message-modified)
1059       (set-buffer-modified-p nil))))
1060
1061 (defun wl-thread-get-depth-of-current-line ()
1062   (let ((entity (wl-thread-get-entity (wl-summary-message-number)))
1063         (depth 0)
1064         number)
1065     (while (setq number (wl-thread-entity-get-parent entity))
1066       (incf depth)
1067       (setq entity (wl-thread-get-entity number)))
1068     depth))
1069
1070 (defun wl-thread-update-indent-string-region (beg end)
1071   (interactive "r")
1072   (save-excursion
1073     (goto-char beg)
1074     (while (< (point) end)
1075       (save-excursion
1076         (wl-thread-update-line-on-buffer-sub nil (wl-summary-message-number)))
1077       (forward-line 1))))
1078
1079 (defsubst wl-thread-make-indent-string (entity)
1080   (let ((cur entity)
1081         (ret-val "")
1082         (space-str (wl-repeat-string wl-thread-space-str-internal
1083                                      (- wl-thread-indent-level-internal 1)))
1084         parent)
1085     (when (wl-thread-entity-get-number
1086            (setq parent (wl-thread-entity-get-parent-entity cur)))
1087       (if (wl-thread-entity-get-younger-brothers cur)
1088           (setq ret-val wl-thread-have-younger-brother-str-internal)
1089         (setq ret-val wl-thread-youngest-child-str-internal))
1090       (setq ret-val (concat ret-val
1091                             (wl-repeat-string
1092                              wl-thread-horizontal-str-internal
1093                              (- wl-thread-indent-level-internal 1))))
1094       (setq cur parent)
1095       (while (wl-thread-entity-get-number
1096               (wl-thread-entity-get-parent-entity cur))
1097         (if (wl-thread-entity-get-younger-brothers cur)
1098             (setq ret-val (concat wl-thread-vertical-str-internal
1099                                   space-str
1100                                   ret-val))
1101           (setq ret-val (concat wl-thread-space-str-internal
1102                                 space-str
1103                                 ret-val)))
1104         (setq cur (wl-thread-entity-get-parent-entity cur))))
1105     ret-val))
1106
1107 (defun wl-thread-set-parent (&optional parent-number)
1108   "Set current message's parent interactively."
1109   (interactive)
1110   (let ((number (wl-summary-message-number))
1111         (dst-parent (if (interactive-p)
1112                         (read-from-minibuffer "Parent Message (No.): ")))
1113         entity dst-parent-entity src-parent children
1114         update-msgs
1115         buffer-read-only)
1116     (if (string= dst-parent "")
1117         (setq dst-parent nil)
1118       (if (interactive-p)
1119           (setq dst-parent (string-to-int dst-parent))
1120         (setq dst-parent parent-number)))
1121     (if (and dst-parent
1122              (memq dst-parent (wl-thread-get-children-msgs number)))
1123         (error "Parent is children or myself"))
1124     (setq entity (wl-thread-get-entity number))
1125     (when (and number entity)
1126       ;; delete thread
1127       (setq update-msgs (wl-thread-delete-message number 'deep))
1128       ;; insert as child at new parent
1129       (setq dst-parent-entity (wl-thread-get-entity dst-parent))
1130       (if dst-parent-entity
1131           (progn
1132             (if (setq children
1133                       (wl-thread-entity-get-children dst-parent-entity))
1134                 (wl-append update-msgs
1135                            (wl-thread-get-children-msgs
1136                             (car (last children)) t)))
1137             (wl-thread-entity-set-children
1138              dst-parent-entity
1139              (append children (list number)))
1140             (wl-thread-entity-set-linked
1141              entity
1142              (let ((parent (elmo-message-entity-parent
1143                             wl-summary-buffer-elmo-folder
1144                             (elmo-message-entity
1145                              wl-summary-buffer-elmo-folder
1146                              number))))
1147                (or (null parent)
1148                    (/= parent-number (elmo-message-entity-number parent))))))
1149         ;; insert as top
1150         (wl-append wl-thread-entity-list (list number))
1151         (wl-thread-entity-set-linked entity nil))
1152
1153       ;; update my thread
1154       (wl-append update-msgs (wl-thread-get-children-msgs number t))
1155       (setq update-msgs (elmo-uniq-list update-msgs))
1156       (wl-thread-entity-set-parent entity dst-parent)
1157       ;; update thread on buffer
1158       (wl-thread-make-number-list)
1159       (wl-thread-update-line-msgs update-msgs t))))
1160
1161 (require 'product)
1162 (product-provide (provide 'wl-thread) (require 'wl-version))
1163
1164 ;;; wl-thread.el ends here