wl/wl-thread.el

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