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