wl/wl-thread.el

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