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