wl/wl-thread.el

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