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