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