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-folder-name))
  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-folder-name))
  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-folder-name))
  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-msgdb-expand-path fld))))
 104     (setq top-list
 105           (wl-summary-load-file-object
 106            (expand-file-name wl-thread-entity-list-file
 107                              (elmo-msgdb-expand-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-folder-name))
 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         (unless (wl-thread-entity-get-opened
 584                  (setq entity (wl-thread-get-entity
 585                                (wl-summary-message-number))))
 586           (wl-thread-entity-force-open entity))
 587         (wl-thread-goto-bottom-of-sub-thread)
 588         (when (> len elmo-display-progress-threshold)
 589           (setq cur (1+ cur))
 590           (elmo-display-progress
 591            'wl-thread-open-all "Opening all threads..."
 592            (/ (* cur 100) len)))))
 593     ;; Make sure to be 100%.
 594     (elmo-display-progress
 595      'wl-thread-open-all "Opening all threads..."
 596      100))
 597   (message "Opening all threads...done"))
 598
 599 (defun wl-thread-open-all-unread ()
 600   (interactive)
 601   (let ((mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb))
 602         mark)
 603     (while mark-alist
 604       (if (setq mark (nth 1 (car mark-alist)))
 605           (if (or (string= mark wl-summary-unread-uncached-mark)
 606                   (string= mark wl-summary-unread-cached-mark)
 607                   (string= mark wl-summary-new-mark)
 608                   (string= mark wl-summary-important-mark))
 609               (wl-thread-entity-force-open (wl-thread-get-entity
 610                                             (nth 0 (car mark-alist))))))
 611       (setq mark-alist (cdr mark-alist)))))
 612
 613 ;;; a subroutine for wl-thread-entity-get-next-marked-entity.
 614 (defun wl-thread-entity-check-next-mark-from-younger-brother
 615   (entity next-marks)
 616   (let* (parent younger-brother)
 617     (catch 'done
 618       (while entity
 619         (setq parent (wl-thread-entity-get-parent-entity entity)
 620               younger-brother
 621               (wl-thread-entity-get-younger-brothers entity parent))
 622         ;; check my brother!
 623         (while younger-brother
 624           (wl-thread-entity-check-next-mark
 625            (wl-thread-get-entity (car younger-brother))
 626            next-marks)
 627           (if  (wl-thread-meaning-alist-get-result
 628                 (car next-marks))
 629               (throw 'done nil))
 630           (setq younger-brother (cdr younger-brother)))
 631         (setq entity parent)))))
 632
 633 (defun wl-thread-entity-get-next-marked-entity (entity next-marks)
 634   (let ((children (wl-thread-entity-get-children entity))
 635         marked)
 636     (or (catch 'done
 637           (while children
 638             (wl-thread-entity-check-next-mark
 639              (wl-thread-get-entity (car children)) next-marks)
 640             (if (setq marked
 641                       (wl-thread-meaning-alist-get-result
 642                        (car next-marks)))
 643                 (throw 'done marked))
 644             (setq children (cdr children))))
 645         ;; check younger brother
 646         (wl-thread-entity-check-next-mark-from-younger-brother
 647          entity next-marks)
 648         (if (setq marked
 649                   (wl-thread-meaning-alist-get-result
 650                    (car next-marks)))
 651             marked
 652           (if (setq marked
 653                     (wl-thread-meaning-alist-get-result
 654                      (cdr next-marks)))
 655               marked)))))
 656
 657 (defsubst wl-thread-maybe-get-children-num (msg)
 658   (let ((entity (wl-thread-get-entity msg)))
 659     (if (not (wl-thread-entity-get-opened entity))
 660         (wl-thread-entity-get-children-num entity))))
 661
 662 (defsubst wl-thread-update-line-on-buffer-sub (entity msg &optional parent-msg)
 663   (let* ((entity (or entity (wl-thread-get-entity msg)))
 664          (parent-msg (or parent-msg (wl-thread-entity-get-parent entity)))
 665          (overview (elmo-msgdb-get-overview wl-summary-buffer-msgdb))
 666          (mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb))
 667          (buffer-read-only nil)
 668          (inhibit-read-only t)
 669          overview-entity temp-mark summary-line invisible-top dest-pair)
 670     (if (wl-thread-delete-line-from-buffer msg)
 671         (progn
 672           (cond
 673            ((memq msg wl-summary-buffer-delete-list)
 674             (setq temp-mark "D"))
 675            ((memq msg wl-summary-buffer-target-mark-list)
 676             (setq temp-mark "*"))
 677            ((setq dest-pair (assq msg wl-summary-buffer-refile-list))
 678             (setq temp-mark "o"))
 679            ((setq dest-pair (assq msg wl-summary-buffer-copy-list))
 680             (setq temp-mark "O"))
 681            (t (setq temp-mark (wl-summary-get-score-mark msg))))
 682           (when (setq overview-entity
 683                       (elmo-msgdb-overview-get-entity
 684                        msg wl-summary-buffer-msgdb))
 685             (setq summary-line
 686                   (wl-summary-overview-create-summary-line
 687                    msg
 688                    overview-entity
 689                    (elmo-msgdb-overview-get-entity
 690                     parent-msg wl-summary-buffer-msgdb)
 691                    nil
 692                    mark-alist
 693                    (if wl-thread-insert-force-opened
 694                        nil
 695                      (wl-thread-maybe-get-children-num msg))
 696                    temp-mark entity))
 697             (save-excursion
 698               (wl-summary-insert-line summary-line))
 699             (if dest-pair
 700                 (wl-summary-print-destination (car dest-pair)
 701                                               (cdr dest-pair)))))
 702       ;; insert thread (moving thread)
 703       (if (not (setq invisible-top
 704                      (wl-thread-entity-parent-invisible-p entity)))
 705           (wl-summary-update-thread
 706            (elmo-msgdb-overview-get-entity msg wl-summary-buffer-msgdb)
 707            overview
 708            mark-alist
 709            entity
 710            (and parent-msg
 711                 (elmo-msgdb-overview-get-entity
 712                  parent-msg wl-summary-buffer-msgdb)))
 713         ;; currently invisible.. update closed line.
 714         (wl-thread-update-children-number invisible-top)))))
 715
 716 (defun wl-thread-update-line-on-buffer (&optional msg parent-msg updates)
 717   (interactive)
 718   (let ((msgs (list (or msg (wl-summary-message-number))))
 719         entity children msgs-stack)
 720    (while msgs
 721     (setq msg (wl-pop msgs))
 722     (setq updates (and updates (delete msg updates)))
 723     (setq entity (wl-thread-get-entity msg))
 724     (wl-thread-update-line-on-buffer-sub entity msg parent-msg)
 725     ;;
 726     (setq children (wl-thread-entity-get-children entity))
 727     (if children
 728         ;; update children
 729         (when (wl-thread-entity-get-opened entity)
 730           (wl-push msgs msgs-stack)
 731           (setq parent-msg msg
 732                 msgs children))
 733       (unless msgs
 734         (while (and (null msgs) msgs-stack)
 735           (setq msgs (wl-pop msgs-stack)))
 736         (when msgs
 737           (setq parent-msg
 738                 (wl-thread-entity-get-number
 739                  (wl-thread-entity-get-parent-entity
 740                   (wl-thread-get-entity (car msgs)))))))))
 741    updates))
 742
 743 (defun wl-thread-update-line-msgs (msgs &optional no-msg)
 744   (wl-delete-all-overlays)
 745   (let ((i 0)
 746         (updates msgs)
 747         len)
 748 ;;; (while msgs
 749 ;;;   (setq updates
 750 ;;;         (append updates
 751 ;;;                 (wl-thread-get-children-msgs (car msgs))))
 752 ;;;   (setq msgs (cdr msgs)))
 753 ;;; (setq updates (elmo-uniq-list updates))
 754     (setq len (length updates))
 755     (while updates
 756       (wl-thread-update-line-on-buffer-sub nil (car updates))
 757       (setq updates (cdr updates))
 758       (when (and (not no-msg)
 759                  (> len elmo-display-progress-threshold))
 760         (setq i (1+ i))
 761         (if (or (zerop (% i 5)) (= i len))
 762             (elmo-display-progress
 763              'wl-thread-update-line-msgs "Updating deleted thread..."
 764              (/ (* i 100) len)))))))
 765
 766 (defun wl-thread-delete-line-from-buffer (msg)
 767   "Simply delete msg line."
 768   (let (beg)
 769     (if (wl-summary-jump-to-msg msg)
 770         (progn
 771           (setq beg (point))
 772           (forward-line 1)
 773           (delete-region beg (point))
 774           t)
 775       nil)))
 776
 777 (defun wl-thread-cleanup-symbols (msgs)
 778   (let (entity)
 779     (while msgs
 780       (when (setq entity (wl-thread-get-entity (car msgs)))
 781         ;; delete entity.
 782         (setq wl-thread-entities (delq entity wl-thread-entities))
 783         ;; free symbol.
 784         (elmo-clear-hash-val (format "#%d" (car msgs))
 785                              wl-thread-entity-hashtb))
 786       (setq msgs (cdr msgs)))))
 787
 788 (defun wl-thread-get-exist-children (msg)
 789   (let ((msgs (list msg))
 790         msgs-stack children
 791         entity ret-val)
 792     (while msgs
 793       (setq children (wl-thread-entity-get-children
 794                       (setq entity (wl-thread-get-entity (car msgs)))))
 795       (when (elmo-msgdb-overview-get-entity (car msgs) wl-summary-buffer-msgdb)
 796         (wl-append ret-val (list (car msgs)))
 797         (setq children nil))
 798       (setq msgs (cdr msgs))
 799       (if (null children)
 800           (while (and (null msgs) msgs-stack)
 801             (setq msgs (wl-pop msgs-stack)))
 802         (wl-push msgs msgs-stack)
 803         (setq msgs children)))
 804     ret-val))
 805
 806 (defun wl-thread-delete-message (msg &optional deep update)
 807   "Delete MSG from entity and buffer."
 808   (save-excursion
 809     (let* ((entity (wl-thread-get-entity msg))
 810            children older-brothers younger-brothers top-child ;;grandchildren
 811            top-entity parent update-msgs beg invisible-top)
 812       (when entity
 813         (setq parent (wl-thread-entity-get-parent-entity entity))
 814         (if parent
 815             (progn
 816 ;;; has parent.
 817 ;;;           (setq brothers (wl-thread-entity-get-children parent))
 818               (setq older-brothers (wl-thread-entity-get-older-brothers
 819                                     entity parent))
 820               (setq younger-brothers (wl-thread-entity-get-younger-brothers
 821                                       entity parent))
 822               ;;
 823               (unless deep
 824                 (setq children (wl-thread-entity-get-children entity))
 825                 (wl-thread-reparent-children
 826                  children (wl-thread-entity-get-number parent))
 827                 (setq update-msgs
 828                       (apply (function nconc)
 829                              update-msgs
 830                              (mapcar
 831                               (function
 832                                (lambda (message)
 833                                  (wl-thread-get-children-msgs message t)))
 834                               children))))
 835               (wl-thread-entity-set-children
 836                parent (append older-brothers children younger-brothers))
 837               ;; If chidren and younger-brothers not exists,
 838               ;; update nearly older brother.
 839               (when (and older-brothers
 840                          (not younger-brothers)
 841                          (not children))
 842                 (wl-append
 843                  update-msgs
 844                  (wl-thread-get-children-msgs (car (last older-brothers))))))
 845
 846           ;; top...oldest child becomes top.
 847           (unless deep
 848             (setq children (wl-thread-entity-get-children entity))
 849             (when children
 850               (setq top-child (car children)
 851                     children (cdr children))
 852               (setq top-entity (wl-thread-get-entity top-child))
 853               (wl-thread-entity-set-parent top-entity nil)
 854               (wl-thread-entity-set-linked top-entity nil)
 855               (wl-append update-msgs
 856                          (wl-thread-get-children-msgs top-child t)))
 857             (when children
 858               (wl-thread-entity-set-children
 859                top-entity
 860                (append
 861                 (wl-thread-entity-get-children top-entity)
 862                 children))
 863               (wl-thread-reparent-children children top-child)
 864               (wl-append update-msgs children)))
 865           ;; delete myself from top list.
 866           (setq older-brothers (wl-thread-entity-get-older-brothers
 867                                 entity nil))
 868           (setq younger-brothers (wl-thread-entity-get-younger-brothers
 869                                   entity nil))
 870           (setq wl-thread-entity-list
 871                 (append (append older-brothers
 872                                 (and top-child (list top-child)))
 873                         younger-brothers))))
 874
 875       (if deep
 876           ;; delete thread on buffer
 877           (when (wl-summary-jump-to-msg msg)
 878             (setq beg (point))
 879             (wl-thread-goto-bottom-of-sub-thread)
 880             (delete-region beg (point)))
 881         ;; delete myself from buffer.
 882         (unless (wl-thread-delete-line-from-buffer msg)
 883           ;; jump to suitable point.
 884           ;; just upon the oldest younger-brother of my top.
 885           (setq invisible-top
 886                 (car (wl-thread-entity-parent-invisible-p entity)))
 887           (if invisible-top
 888               (progn
 889                 (wl-append update-msgs (list invisible-top))
 890                 (wl-summary-jump-to-msg invisible-top))
 891             (goto-char (point-max))))
 892
 893         ;; insert children if thread is closed or delete top.
 894         (when (or top-child
 895                   (not (wl-thread-entity-get-opened entity)))
 896           (let* (next-top insert-msgs ent e grandchildren)
 897             (if top-child
 898                 (progn
 899                   (setq insert-msgs (wl-thread-get-exist-children top-child))
 900                   (setq next-top (car insert-msgs))
 901                   (setq ent (wl-thread-get-entity next-top))
 902                   (when (and
 903                          (wl-thread-entity-get-opened entity) ;; open
 904                          (not (wl-thread-entity-get-opened ent)) ;; close
 905                          (setq grandchildren
 906                                (wl-thread-entity-get-children ent))
 907                          (wl-summary-jump-to-msg next-top))
 908                     (forward-line 1)
 909                     (setq insert-msgs (append (cdr insert-msgs) grandchildren)))
 910                   (when top-entity (wl-thread-entity-set-opened top-entity t))
 911                   (when ent (wl-thread-entity-set-opened ent t)))
 912               (when (not invisible-top)
 913                 (setq insert-msgs (wl-thread-get-exist-children msg))
 914                 ;; First msg always opened, because first msg maybe becomes top.
 915                 (if (setq ent (wl-thread-get-entity (car insert-msgs)))
 916                     (wl-thread-entity-set-opened ent t))))
 917             ;; insert children
 918             (while insert-msgs
 919               ;; if no exists in summary, insert entity.
 920               (when (and (car insert-msgs)
 921                          (not (wl-summary-jump-to-msg (car insert-msgs))))
 922                 (setq ent (wl-thread-get-entity (car insert-msgs)))
 923                 (wl-thread-insert-entity 0 ; no mean now...
 924                                          ent entity nil))
 925               (setq insert-msgs (cdr insert-msgs))))))
 926       (if update
 927           ;; modify buffer.
 928           (while update-msgs
 929             (wl-thread-update-line-on-buffer-sub nil (pop update-msgs)))
 930         ;; don't update buffer
 931         update-msgs)))) ; return value
 932
 933 (defun wl-thread-insert-message (overview-entity overview mark-alist
 934                                  msg parent-msg &optional update linked)
 935   "Insert MSG to the entity.
 936 When optional argument UPDATE is non-nil,
 937 Message is inserted to the summary buffer."
 938   (let ((parent (wl-thread-get-entity parent-msg))
 939         child-entity invisible-top)
 940 ;;; Update the thread view...not implemented yet.
 941 ;;;  (when force-insert
 942 ;;;    (if parent
 943 ;;;       (wl-thread-entity-force-open parent))
 944     (if parent
 945         ;; insert as children.
 946         (wl-thread-entity-insert-as-children
 947          parent
 948          (setq child-entity (wl-thread-create-entity msg (nth 0 parent) nil linked)))
 949       ;; insert as top message.
 950       (wl-thread-entity-insert-as-top
 951        (wl-thread-create-entity msg nil)))
 952     (if update
 953         (if (not (setq invisible-top
 954                        (wl-thread-entity-parent-invisible-p child-entity)))
 955             ;; visible.
 956             (progn
 957               (wl-summary-update-thread
 958                overview-entity
 959                overview
 960                mark-alist
 961                child-entity
 962                (elmo-msgdb-overview-get-entity
 963                 parent-msg wl-summary-buffer-msgdb))
 964               (when parent
 965                 ;; use thread structure.
 966                 (wl-thread-entity-get-nearly-older-brother
 967                  child-entity parent))) ; return value
 968 ;;;             (wl-thread-entity-get-number
 969 ;;;              (wl-thread-entity-get-top-entity parent)))) ; return value;
 970 ;;;           (setq beg (point))
 971 ;;;           (wl-thread-goto-bottom-of-sub-thread)
 972 ;;;           (wl-thread-update-indent-string-region beg (point)))
 973           ;; currently invisible.. update closed line.
 974           (wl-thread-update-children-number invisible-top)
 975           nil))))
 976
 977 (defun wl-thread-get-parent-list (msgs)
 978   (let* ((msgs2 msgs)
 979          myself)
 980     (while msgs2
 981       (setq myself (car msgs2)
 982             msgs2 (cdr msgs2))
 983       (while (not (eq myself (car msgs2)))
 984         (if (wl-thread-descendant-p myself (car msgs2))
 985             (setq msgs (delq (car msgs2) msgs)))
 986         (setq msgs2 (or (cdr msgs2) msgs)))
 987       (setq msgs2 (cdr msgs2)))
 988     msgs))
 989
 990 (defun wl-thread-update-indent-string-thread (top-list)
 991   (let ((top-list (wl-thread-get-parent-list top-list))
 992         beg)
 993     (while top-list
 994       (when (car top-list)
 995         (wl-summary-jump-to-msg (car top-list))
 996         (setq beg (point))
 997         (wl-thread-goto-bottom-of-sub-thread)
 998         (wl-thread-update-indent-string-region beg (point)))
 999       (setq top-list (cdr top-list)))))
1000
1001 (defun wl-thread-update-children-number (entity)
1002   "Update the children number."
1003   (save-excursion
1004     (wl-summary-jump-to-msg (wl-thread-entity-get-number entity))
1005     (beginning-of-line)
1006     (let ((text-prop (get-text-property (point) 'face))
1007           from from-end beg str)
1008       (cond
1009        ((looking-at (concat "^" wl-summary-buffer-number-regexp
1010                             "..../..\(.*\)..:.. ["
1011                             wl-thread-indent-regexp
1012                             "]*[[<]\\+\\([0-9]+\\):"))
1013         (delete-region (match-beginning 1)(match-end 1))
1014         (goto-char (match-beginning 1))
1015         (setq str (format "%s" (wl-thread-entity-get-children-num entity)))
1016         (if wl-summary-highlight
1017             (put-text-property 0 (length str) 'face text-prop str))
1018         (insert str))
1019        ((looking-at (concat "^" wl-summary-buffer-number-regexp
1020                             "..../..\(.*\)..:.. ["
1021                             wl-thread-indent-regexp
1022                             "]*[[<]"))
1023         (goto-char (match-end 0))
1024         (setq beg (current-column))
1025         (setq from-end (save-excursion
1026                          (move-to-column (+ 1 beg wl-from-width))
1027                          (point)))
1028         (setq from (buffer-substring (match-end 0) from-end))
1029         (delete-region (match-end 0) from-end)
1030         (setq str (wl-set-string-width
1031                    (1+ wl-from-width)
1032                    (format
1033                     "+%s:%s"
1034                     (wl-thread-entity-get-children-num
1035                      entity)
1036                     from)))
1037         (if wl-summary-highlight
1038             (put-text-property 0 (length str) 'face text-prop str))
1039         (insert str)
1040         (condition-case nil ; it's dangerous, so ignore error.
1041             (run-hooks 'wl-thread-update-children-number-hook)
1042           (error
1043            (ding)
1044            (message "Error in wl-thread-update-children-number-hook."))))))))
1045
1046 ;;
1047 ;; Thread oriented commands.
1048 ;;
1049 (defun wl-thread-call-region-func (func &optional arg)
1050   (save-excursion
1051     (if arg
1052         (wl-summary-goto-top-of-current-thread)
1053       (beginning-of-line))
1054     (let ((beg (point)))
1055       (wl-thread-goto-bottom-of-sub-thread)
1056       (funcall func beg (point)))))
1057
1058 (defun wl-thread-prefetch (&optional arg)
1059   (interactive "P")
1060   (wl-thread-call-region-func 'wl-summary-prefetch-region arg))
1061
1062 (defun wl-thread-msg-mark-as-important (msg)
1063   "Set mark as important for invisible MSG. Modeline is not changed."
1064   (let* ((msgdb wl-summary-buffer-msgdb)
1065          (mark-alist (elmo-msgdb-get-mark-alist msgdb))
1066          cur-mark)
1067     (setq cur-mark (cadr (assq msg mark-alist)))
1068     (setq mark-alist
1069           (elmo-msgdb-mark-set mark-alist
1070                                msg
1071                                (if (string= cur-mark wl-summary-important-mark)
1072                                    nil
1073                                  wl-summary-important-mark)))
1074     (elmo-msgdb-set-mark-alist msgdb mark-alist)
1075     (wl-summary-set-mark-modified)))
1076
1077 (defun wl-thread-mark-as-read (&optional arg)
1078   (interactive "P")
1079   (wl-thread-call-region-func 'wl-summary-mark-as-read-region arg))
1080
1081 (defun wl-thread-mark-as-unread (&optional arg)
1082   (interactive "P")
1083   (wl-thread-call-region-func 'wl-summary-mark-as-unread-region arg))
1084
1085 (defun wl-thread-mark-as-important (&optional arg)
1086   (interactive "P")
1087   (wl-thread-call-region-func 'wl-summary-mark-as-important-region arg))
1088
1089 (defun wl-thread-copy (&optional arg)
1090   (interactive "P")
1091   (wl-thread-call-region-func 'wl-summary-copy-region arg))
1092
1093 (defun wl-thread-refile (&optional arg)
1094   (interactive "P")
1095   (condition-case err
1096       (progn
1097         (wl-thread-call-region-func 'wl-summary-refile-region arg)
1098         (if arg
1099             (wl-summary-goto-top-of-current-thread))
1100         (wl-thread-goto-bottom-of-sub-thread))
1101     (error
1102      (elmo-display-error err t)
1103      nil)))
1104
1105 (defun wl-thread-delete (&optional arg)
1106   (interactive "P")
1107   (wl-thread-call-region-func 'wl-summary-delete-region arg)
1108   (if arg
1109       (wl-summary-goto-top-of-current-thread))
1110   (if (not wl-summary-move-direction-downward)
1111       (wl-summary-prev)
1112     (wl-thread-goto-bottom-of-sub-thread)
1113     (if wl-summary-buffer-disp-msg
1114         (wl-summary-redisplay))))
1115
1116 (defun wl-thread-target-mark (&optional arg)
1117   (interactive "P")
1118   (wl-thread-call-region-func 'wl-summary-target-mark-region arg))
1119
1120 (defun wl-thread-unmark (&optional arg)
1121   (interactive "P")
1122   (wl-thread-call-region-func 'wl-summary-unmark-region arg))
1123
1124 (defun wl-thread-exec (&optional arg)
1125   (interactive "P")
1126   (wl-thread-call-region-func 'wl-summary-exec-region arg))
1127
1128 (defun wl-thread-save (&optional arg)
1129   (interactive "P")
1130   (wl-thread-call-region-func 'wl-summary-save-region arg))
1131
1132 (defun wl-thread-force-open (&optional msg-num)
1133   "force open current folder"
1134   (if msg-num
1135       (wl-summary-jump-to-msg msg-num))
1136   (let ((wl-thread-insert-force-opened t))
1137     (wl-thread-open-close)))
1138
1139 (defun wl-thread-entity-force-open (entity)
1140   (let ((wl-thread-insert-force-opened t)
1141         notopen)
1142     (if (null (wl-thread-entity-get-parent entity))
1143         ;; top!!
1144         (if (and (not (wl-thread-entity-get-opened entity))
1145                  (wl-thread-entity-get-children entity))
1146             (wl-thread-force-open (wl-thread-entity-get-number entity)))
1147       (if (setq notopen (wl-thread-entity-parent-invisible-p entity))
1148           (wl-thread-force-open (wl-thread-entity-get-number notopen))))))
1149
1150 (defun wl-thread-insert-top ()
1151   (let ((elist wl-thread-entity-list)
1152         (len (length wl-thread-entity-list))
1153         (cur 0))
1154     (wl-delete-all-overlays)
1155     (while elist
1156       (wl-thread-insert-entity
1157        0
1158        (wl-thread-get-entity (car elist))
1159        nil
1160        len)
1161       (setq elist (cdr elist))
1162       (when (> len elmo-display-progress-threshold)
1163         (setq cur (1+ cur))
1164         (if (or (zerop (% cur 2)) (= cur len))
1165             (elmo-display-progress
1166              'wl-thread-insert-top "Inserting thread..."
1167              (/ (* cur 100) len)))))))
1168
1169 (defsubst wl-thread-insert-entity-sub (indent entity parent-entity all)
1170   (let ((mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb))
1171         msg-num
1172         overview-entity
1173         temp-mark
1174         summary-line)
1175     (when (setq msg-num (wl-thread-entity-get-number entity))
1176       (unless all ; all...means no temp-mark.
1177         (cond ((memq msg-num wl-summary-buffer-delete-list)
1178                (setq temp-mark "D"))
1179               ((memq msg-num wl-summary-buffer-target-mark-list)
1180                (setq temp-mark "*"))
1181               ((assq msg-num wl-summary-buffer-refile-list)
1182                (setq temp-mark "o"))
1183               ((assq msg-num wl-summary-buffer-copy-list)
1184                (setq temp-mark "O"))))
1185       (unless temp-mark
1186         (setq temp-mark (wl-summary-get-score-mark msg-num)))
1187       (setq overview-entity
1188             (elmo-msgdb-overview-get-entity
1189              (nth 0 entity) wl-summary-buffer-msgdb))
1190 ;;;   (wl-delete-all-overlays)
1191       (when overview-entity
1192         (setq summary-line
1193               (wl-summary-overview-create-summary-line
1194                msg-num
1195                overview-entity
1196                (elmo-msgdb-overview-get-entity
1197                 (nth 0 parent-entity) wl-summary-buffer-msgdb)
1198                (1+ indent)
1199                mark-alist
1200                (if wl-thread-insert-force-opened
1201                    nil
1202                  (wl-thread-maybe-get-children-num msg-num))
1203                temp-mark entity))
1204         (wl-summary-insert-line summary-line)))))
1205
1206 (defun wl-thread-insert-entity (indent entity parent-entity all)
1207   "Insert thread entity in current buffer."
1208   (let ((msgs (list (car entity)))
1209         children msgs-stack)
1210     (while msgs
1211       (wl-thread-insert-entity-sub indent entity parent-entity all)
1212       (setq msgs (cdr msgs))
1213       (setq children (nth 2 entity))
1214       (if children
1215           ;; insert children
1216           (when (or wl-thread-insert-force-opened
1217                     (wl-thread-entity-get-opened entity))
1218             (wl-thread-entity-set-opened entity t)
1219             (wl-push msgs msgs-stack)
1220             (setq msgs children
1221                   indent (1+ indent)
1222                   parent-entity entity)))
1223       (unless msgs
1224         (while (and (null msgs) msgs-stack)
1225           (setq msgs (wl-pop msgs-stack))
1226           (setq indent (1- indent)))
1227         (when msgs
1228           (setq entity (wl-thread-get-entity (car msgs)))
1229           (setq parent-entity (wl-thread-entity-get-parent-entity entity))))
1230       (setq entity (wl-thread-get-entity (car msgs))))))
1231
1232 (defun wl-thread-descendant-p (mynumber number)
1233   (let ((cur (wl-thread-get-entity number))
1234         num)
1235     (catch 'done
1236       (while cur
1237         (setq cur (wl-thread-entity-get-parent-entity cur))
1238         (if (null (setq num (wl-thread-entity-get-number cur))) ; top!
1239             (throw 'done nil))
1240         (if (and num
1241                  (eq mynumber (wl-thread-entity-get-number cur)))
1242             (throw 'done t)))
1243       nil)))
1244
1245 ;; (defun wl-thread-goto-bottom-of-sub-thread ()
1246 ;;   (interactive)
1247 ;;   (let ((depth (wl-thread-get-depth-of-current-line)))
1248 ;;     (forward-line 1)
1249 ;;     (while (and (not (eobp))
1250 ;;              (> (wl-thread-get-depth-of-current-line)
1251 ;;                 depth))
1252 ;;       (forward-line 1))
1253 ;;     (beginning-of-line)))
1254
1255 (defun wl-thread-goto-bottom-of-sub-thread (&optional msg)
1256   (interactive)
1257   (let ((mynumber (or msg (wl-summary-message-number))))
1258     (forward-line 1)
1259     (while (wl-thread-descendant-p mynumber (wl-summary-message-number))
1260       (forward-line 1))
1261     (beginning-of-line)))
1262
1263 (defun wl-thread-remove-destination-region (beg end)
1264   (save-excursion
1265     (save-restriction
1266       (narrow-to-region beg end)
1267       (goto-char (point-min))
1268       (while (not (eobp))
1269         (let ((num (wl-summary-message-number)))
1270           (if (assq num wl-summary-buffer-refile-list)
1271               (wl-summary-remove-destination)))
1272         (forward-line 1)))))
1273
1274 (defun wl-thread-print-destination-region (beg end)
1275   (if (or wl-summary-buffer-refile-list
1276           wl-summary-buffer-copy-list)
1277       (save-excursion
1278         (save-restriction
1279           (narrow-to-region beg end)
1280           (goto-char (point-min))
1281           (while (not (eobp))
1282             (let ((num (wl-summary-message-number))
1283                   pair)
1284               (if (or (setq pair (assq num wl-summary-buffer-refile-list))
1285                       (setq pair (assq num wl-summary-buffer-copy-list)))
1286                   (wl-summary-print-destination (car pair) (cdr pair))))
1287             (forward-line 1))))))
1288
1289 (defsubst wl-thread-get-children-msgs (msg &optional visible-only)
1290   (let ((msgs (list msg))
1291         msgs-stack children
1292         entity ret-val)
1293     (while msgs
1294       (wl-append ret-val (list (car msgs)))
1295       (setq children (wl-thread-entity-get-children
1296                       (setq entity (wl-thread-get-entity (car msgs)))))
1297       (if (and visible-only
1298                (not (wl-thread-entity-get-opened entity)))
1299           (setq children nil))
1300       (setq msgs (cdr msgs))
1301       (if (null children)
1302           (while (and (null msgs) msgs-stack)
1303             (setq msgs (wl-pop msgs-stack)))
1304         (wl-push msgs msgs-stack)
1305         (setq msgs children)))
1306     ret-val))
1307
1308 (defun wl-thread-get-children-msgs-uncached (msg &optional uncached-marks)
1309   (let ((children-msgs (wl-thread-get-children-msgs msg))
1310         (mark-alist (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb))
1311         (number-alist (elmo-msgdb-get-number-alist wl-summary-buffer-msgdb))
1312         mark
1313         uncached-list)
1314     (while children-msgs
1315       (if (and (not (eq msg (car children-msgs))) ; except itself
1316                (or (and uncached-marks
1317                         (setq mark (cadr (assq (car children-msgs)
1318                                                mark-alist)))
1319                         (member mark uncached-marks))
1320                    (and (not uncached-marks)
1321                         (null (elmo-cache-exists-p
1322                                (cdr (assq (car children-msgs)
1323                                           number-alist)))))))
1324           (wl-append uncached-list (list (car children-msgs))))
1325       (setq children-msgs (cdr children-msgs)))
1326     uncached-list))
1327
1328 (defun wl-thread-get-children-msgs-with-mark (msg mark)
1329   (let ((children-msgs (wl-thread-get-children-msgs msg))
1330         (check-func (cond ((string= mark "o")
1331                            'wl-summary-msg-marked-as-refiled)
1332                           ((string= mark "O")
1333                            'wl-summary-msg-marked-as-copied)
1334                           ((string= mark "D")
1335                            'wl-summary-msg-marked-as-deleted)
1336                           ((string= mark "*")
1337                            'wl-summary-msg-marked-as-target)))
1338         ret-val)
1339     (while children-msgs
1340       (if (funcall check-func (car children-msgs))
1341           (wl-append ret-val (list (car children-msgs))))
1342       (setq children-msgs (cdr children-msgs)))
1343     ret-val))
1344
1345 (defun wl-thread-close (entity)
1346   (let (depth beg)
1347     (wl-thread-entity-set-opened entity nil)
1348     (setq depth (wl-thread-get-depth-of-current-line))
1349     (beginning-of-line)
1350     (setq beg (point))
1351     (wl-thread-goto-bottom-of-sub-thread)
1352     (wl-thread-remove-destination-region beg
1353                                          (point))
1354     (forward-char -1)   ;; needed for mouse-face.
1355     (delete-region beg (point))
1356     (wl-thread-insert-entity (- depth 1)
1357                              entity
1358                              (wl-thread-get-entity
1359                               (nth 3 entity))
1360                              nil)
1361     (delete-char 1) ; delete '\n'
1362     (wl-thread-print-destination-region beg (point))))
1363
1364 (defun wl-thread-open (entity)
1365   (let (depth beg)
1366     (beginning-of-line)
1367     (setq beg (point))
1368     (setq depth (wl-thread-get-depth-of-current-line))
1369     (end-of-line)
1370     (delete-region beg (point))
1371     (wl-thread-entity-set-opened entity t)
1372     (wl-thread-insert-entity depth ;(- depth 1)
1373                              entity
1374                              (wl-thread-get-entity
1375                               (nth 3 entity)) nil)
1376     (delete-char 1) ; delete '\n'
1377     (wl-thread-print-destination-region beg (point))))
1378
1379 (defun wl-thread-open-close (&optional force-open)
1380   (interactive "P")
1381   (when (eq wl-summary-buffer-view 'thread)
1382 ;;; (if (equal wl-thread-top-entity '(nil t nil nil))
1383 ;;;     (error "There's no thread structure"))
1384     (save-excursion
1385       (let ((inhibit-read-only t)
1386             (buffer-read-only nil)
1387             (wl-thread-insert-force-opened
1388              (or wl-thread-insert-force-opened
1389                  force-open))
1390             msg entity parent)
1391         (setq msg (wl-summary-message-number))
1392         (setq entity (wl-thread-get-entity msg))
1393         (if (wl-thread-entity-get-opened entity)
1394             ;; if already opened, close its child!
1395           (if (wl-thread-entity-get-children entity)
1396               (wl-thread-close entity)
1397             ;; opened, but has no children, close its parent!
1398             (when (setq parent (wl-thread-entity-get-parent entity))
1399               (wl-summary-jump-to-msg parent)
1400               (wl-thread-close
1401                (wl-thread-get-entity (wl-summary-message-number)))))
1402           ;; if closed (or it is just a thread bottom message)
1403           ;; has children, open it!
1404           (if (wl-thread-entity-get-children entity)
1405               (wl-thread-open entity)
1406             ;; closed, and has no children, close its parent!
1407             (setq msg (or (wl-thread-entity-get-parent entity)
1408                           (wl-thread-entity-get-number entity)))
1409             (when msg
1410               (wl-summary-jump-to-msg msg)
1411               (wl-thread-close
1412                (wl-thread-get-entity (wl-summary-message-number)))))))
1413       (wl-summary-set-message-modified)
1414       (set-buffer-modified-p nil))))
1415
1416
1417 (defun wl-thread-get-depth-of-current-line ()
1418   (interactive)
1419   (save-excursion
1420     (beginning-of-line)
1421     (let ((depth 0))
1422       (if (re-search-forward (concat "^" wl-summary-buffer-number-regexp
1423                                      "..../..\(.*\)..:.. ")
1424                              nil t)
1425           (while (string-match wl-thread-indent-regexp
1426                                (char-to-string
1427                                 (char-after (point))))
1428             (setq depth (1+ depth))
1429             (forward-char)))
1430       (/ depth wl-thread-indent-level-internal))))
1431
1432 (defun wl-thread-update-indent-string-region (beg end)
1433   (interactive "r")
1434   (save-excursion
1435     (goto-char beg)
1436     (while (< (point) end)
1437       (wl-thread-update-indent-string)
1438       (forward-line 1))))
1439
1440 (defsubst wl-thread-make-indent-string (entity)
1441   (let ((cur entity)
1442         (ret-val "")
1443         (space-str (wl-repeat-string wl-thread-space-str-internal
1444                                      (- wl-thread-indent-level-internal 1)))
1445         parent)
1446     (when (wl-thread-entity-get-number
1447            (setq parent (wl-thread-entity-get-parent-entity cur)))
1448       (if (wl-thread-entity-get-younger-brothers cur)
1449           (setq ret-val wl-thread-have-younger-brother-str-internal)
1450         (setq ret-val wl-thread-youngest-child-str-internal))
1451       (setq ret-val (concat ret-val
1452                             (wl-repeat-string
1453                              wl-thread-horizontal-str-internal
1454                              (- wl-thread-indent-level-internal 1))))
1455       (setq cur parent)
1456       (while (wl-thread-entity-get-number
1457               (wl-thread-entity-get-parent-entity cur))
1458         (if (wl-thread-entity-get-younger-brothers cur)
1459             (setq ret-val (concat wl-thread-vertical-str-internal
1460                                   space-str
1461                                   ret-val))
1462           (setq ret-val (concat wl-thread-space-str-internal
1463                                 space-str
1464                                 ret-val)))
1465         (setq cur (wl-thread-entity-get-parent-entity cur))))
1466     ret-val))
1467
1468 (defun wl-thread-update-indent-string ()
1469   "Update indent string of current line."
1470   (interactive)
1471   (save-excursion
1472     (beginning-of-line)
1473     (let ((inhibit-read-only t)
1474           (buffer-read-only nil)
1475           thr-str)
1476       (when (looking-at (concat "^ *\\([0-9]+\\)"
1477                                 "..../..\(.*\)..:.. \\("
1478                                 wl-highlight-thread-indent-string-regexp
1479                                 "\\)[[<]"))
1480         (goto-char (match-beginning 2))
1481         (delete-region (match-beginning 2)
1482                        (match-end 2))
1483         (setq thr-str
1484               (wl-thread-make-indent-string
1485                (wl-thread-get-entity (string-to-int (wl-match-buffer 1)))))
1486         (if (and wl-summary-width
1487                  wl-summary-indent-length-limit
1488                  (< wl-summary-indent-length-limit
1489                     (string-width thr-str)))
1490             (setq thr-str (wl-set-string-width
1491                            wl-summary-indent-length-limit
1492                            thr-str)))
1493         (insert thr-str)
1494         (if wl-summary-highlight
1495             (wl-highlight-summary-current-line))))))
1496
1497 (defun wl-thread-set-parent (&optional parent-number)
1498   "Set current message's parent interactively."
1499   (interactive)
1500   (let ((number (wl-summary-message-number))
1501         (dst-parent (if (interactive-p)
1502                         (read-from-minibuffer "Parent Message (No.): ")))
1503         entity dst-parent-entity src-parent children
1504         update-msgs
1505         buffer-read-only)
1506     (if (string= dst-parent "")
1507         (setq dst-parent nil)
1508       (if (interactive-p)
1509           (setq dst-parent (string-to-int dst-parent))
1510         (setq dst-parent parent-number)))
1511     (if (and dst-parent
1512              (memq dst-parent (wl-thread-get-children-msgs number)))
1513         (error "Parent is children or myself"))
1514     (setq entity (wl-thread-get-entity number))
1515     (when (and number entity)
1516       ;; delete thread
1517       (setq update-msgs (wl-thread-delete-message number 'deep))
1518       ;; insert as child at new parent
1519       (setq dst-parent-entity (wl-thread-get-entity dst-parent))
1520       (if dst-parent-entity
1521           (progn
1522             (if (setq children
1523                       (wl-thread-entity-get-children dst-parent-entity))
1524                 (wl-append update-msgs
1525                            (wl-thread-get-children-msgs
1526                             (car (last children)) t)))
1527             (wl-thread-entity-set-children
1528              dst-parent-entity
1529              (append children (list number)))
1530             (wl-thread-entity-set-linked entity t))
1531         ;; insert as top
1532         (wl-append wl-thread-entity-list (list number))
1533         (wl-thread-entity-set-linked entity nil))
1534
1535       ;; update my thread
1536       (wl-append update-msgs (wl-thread-get-children-msgs number t))
1537       (setq update-msgs (elmo-uniq-list update-msgs))
1538       (wl-thread-entity-set-parent entity dst-parent)
1539       ;; update thread on buffer
1540       (wl-thread-update-line-msgs update-msgs t))))
1541
1542 (require 'product)
1543 (product-provide (provide 'wl-thread) (require 'wl-version))
1544
1545 ;;; wl-thread.el ends here