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