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 (eval-when-compile (require 'cl))
  37
  38 ;; buffer local variables.
  39 ;;(defvar wl-thread-top-entity '(nil t nil nil)) ; top entity
  40 (defvar wl-thread-tops nil)             ; top number list (number)
  41 (defvar wl-thread-entities nil)
  42 (defvar wl-thread-entity-list nil)      ; entity list
  43 (defvar wl-thread-entity-hashtb nil)    ; obarray
  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
  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-thread-resume-entity (fld)
  55   (let (entities top-list)
  56     (setq entities (wl-summary-load-file-object
  57                     (expand-file-name wl-thread-entity-file
  58                                       (elmo-folder-msgdb-path fld))))
  59     (setq top-list
  60           (wl-summary-load-file-object
  61            (expand-file-name wl-thread-entity-list-file
  62                              (elmo-folder-msgdb-path fld))))
  63     (message "Resuming thread structure...")
  64     ;; set obarray value.
  65     (setq wl-thread-entity-hashtb (elmo-make-hash (* (length entities) 2)))
  66     ;; set buffer local variables.
  67     (setq wl-thread-entities entities)
  68     (setq wl-thread-entity-list top-list)
  69     (while entities
  70       (elmo-set-hash-val (format "#%d" (car (car entities))) (car entities)
  71                          wl-thread-entity-hashtb)
  72       (setq entities (cdr entities)))
  73     (wl-thread-make-number-list)
  74     (message "Resuming thread structure...done")))
  75
  76 (defun wl-thread-make-number-list ()
  77   "Make `wl-summary-buffer-number-list', a list of message numbers."
  78   (let* ((node (wl-thread-get-entity (car wl-thread-entity-list)))
  79          (children (wl-thread-entity-get-children node))
  80          parent sibling)
  81     (setq wl-summary-buffer-number-list (list (car wl-thread-entity-list)))
  82     (while children
  83       (wl-thread-entity-make-number-list-from-children
  84        (wl-thread-get-entity (car children)))
  85       (setq children (cdr children)))
  86     (while node
  87       (setq parent (wl-thread-entity-get-parent-entity node)
  88             sibling (wl-thread-entity-get-younger-brothers
  89                      node parent))
  90       (while sibling
  91         (wl-thread-entity-make-number-list-from-children
  92          (wl-thread-get-entity (car sibling)))
  93         (setq sibling (cdr sibling)))
  94       (setq node parent))
  95     (setq wl-summary-buffer-number-list (nreverse
  96                                          wl-summary-buffer-number-list))))
  97
  98 (defun wl-thread-entity-make-number-list-from-children (entity)
  99   (let ((msgs (list (car entity)))
 100         msgs-stack children)
 101     (while msgs
 102       (setq wl-summary-buffer-number-list (cons (car entity)
 103                                                 wl-summary-buffer-number-list))
 104       (setq msgs (cdr msgs))
 105       (setq children (wl-thread-entity-get-children entity))
 106       (if children
 107           (progn
 108             (wl-push msgs msgs-stack)
 109             (setq msgs children))
 110         (unless msgs
 111           (while (and (null msgs) msgs-stack)
 112             (setq msgs (wl-pop msgs-stack)))))
 113       (setq entity (wl-thread-get-entity (car msgs))))))
 114
 115 (defun wl-thread-save-entity (dir)
 116   (wl-thread-save-entities dir)
 117   (wl-thread-save-top-list dir))
 118
 119 (defun wl-thread-save-top-list (dir)
 120   (let ((top-file (expand-file-name wl-thread-entity-list-file dir))
 121         (entity wl-thread-entity-list)
 122         print-length)
 123     (with-temp-buffer
 124       (when (file-writable-p top-file)
 125         (prin1 entity (current-buffer))
 126         (princ "\n" (current-buffer))
 127         (write-region (point-min) (point-max) top-file nil 'no-msg)))))
 128
 129 (defun wl-thread-save-entities (dir)
 130   (let ((top-file (expand-file-name wl-thread-entity-file dir))
 131         (entities wl-thread-entities)
 132         print-length print-level)
 133     (with-temp-buffer
 134       (when (file-writable-p top-file)
 135         (prin1 entities (current-buffer))
 136         (princ "\n" (current-buffer))
 137         (write-region (point-min) (point-max) top-file nil 'no-msg)))))
 138
 139 (defsubst wl-thread-entity-get-number (entity)
 140   (nth 0 entity))
 141 (defsubst wl-thread-entity-get-opened (entity)
 142   (nth 1 entity))
 143 (defsubst wl-thread-entity-get-children (entity)
 144   (nth 2 entity))
 145 (defsubst wl-thread-entity-get-parent (entity)
 146   (nth 3 entity))
 147 (defsubst wl-thread-entity-get-linked (entity)
 148   (nth 4 entity))
 149
 150 (defsubst wl-thread-create-entity (num parent &optional opened linked)
 151   (list num (or opened wl-thread-insert-opened) nil parent linked))
 152
 153 (defsubst wl-thread-get-entity (num)
 154   (and num
 155        (elmo-get-hash-val (format "#%d" num) wl-thread-entity-hashtb)))
 156
 157 (defsubst wl-thread-entity-set-parent (entity parent)
 158   (setcar (cdddr entity) parent)
 159   entity)
 160
 161 (defsubst wl-thread-entity-set-children (entity children)
 162   (setcar (cddr entity) children))
 163
 164 (defsubst wl-thread-entity-set-linked (entity linked)
 165   (if (cddddr entity)
 166       (setcar (cddddr entity) linked)
 167     (nconc entity (list linked)))
 168   entity)
 169
 170 (defsubst wl-thread-reparent-children (children parent)
 171   (while children
 172     (wl-thread-entity-set-parent
 173      (wl-thread-get-entity (car children)) parent)
 174     (wl-thread-entity-set-linked
 175      (wl-thread-get-entity (car children)) t)
 176     (setq children (cdr children))))
 177
 178 (defsubst wl-thread-entity-insert-as-top (entity)
 179   (when (and entity
 180              (car entity))
 181     (wl-append wl-thread-entity-list (list (car entity)))
 182     (setq wl-thread-entities (cons entity wl-thread-entities))
 183     (setq wl-summary-buffer-number-list
 184           (nconc wl-summary-buffer-number-list (list (car entity))))
 185     (elmo-set-hash-val (format "#%d" (car entity)) entity
 186                        wl-thread-entity-hashtb)))
 187
 188 (defsubst wl-thread-entity-insert-as-children (to entity)
 189   (let ((children (wl-thread-entity-get-children to))
 190         curp curc)
 191     (setq curp to)
 192     (elmo-list-insert wl-summary-buffer-number-list
 193                       (wl-thread-entity-get-number entity)
 194                       (progn
 195                         (while (setq curc
 196                                      (wl-thread-entity-get-children curp))
 197                           (setq curp (wl-thread-get-entity
 198                                       (nth (- (length curc) 1)
 199                                            curc))))
 200                         (wl-thread-entity-get-number curp)))
 201     (setcar (cddr to) (wl-append children
 202                                  (list (car entity))))
 203     (setq wl-thread-entities (cons entity wl-thread-entities))
 204     (elmo-set-hash-val (format "#%d" (car entity)) entity
 205                        wl-thread-entity-hashtb)))
 206
 207 (defsubst wl-thread-entity-set-opened (entity opened)
 208   (setcar (cdr entity) opened))
 209
 210 (defsubst wl-thread-entity-get-children-num (entity)
 211   (let (children
 212         ret-val msgs-stack
 213         (msgs (list (car entity))))
 214    (while msgs
 215      (setq msgs (cdr msgs))
 216      (setq children (wl-thread-entity-get-children entity))
 217      (if (null children)
 218          (while (and (null msgs) msgs-stack)
 219            (setq msgs (wl-pop msgs-stack)))
 220        (setq ret-val (+ (or ret-val 0) (length children)))
 221        (wl-push msgs msgs-stack)
 222        (setq msgs children))
 223      (setq entity (wl-thread-get-entity (car msgs))))
 224    ret-val))
 225
 226 (defun wl-thread-entity-get-descendant (entity)
 227   (let (children
 228         ret-val msgs-stack
 229         (msgs (list (car entity))))
 230    (while msgs
 231      (setq msgs (cdr msgs))
 232      (setq children (wl-thread-entity-get-children entity))
 233      (if (null children)
 234          (while (and (null msgs) msgs-stack)
 235            (setq msgs (wl-pop msgs-stack)))
 236        (setq ret-val (nconc ret-val (copy-sequence children)))
 237        (wl-push msgs msgs-stack)
 238        (setq msgs children))
 239      (setq entity (wl-thread-get-entity (car msgs))))
 240    ret-val))
 241
 242 (defsubst wl-thread-entity-get-parent-entity (entity)
 243   (wl-thread-get-entity (wl-thread-entity-get-parent entity)))
 244
 245 (defun wl-thread-entity-get-top-entity (entity)
 246   (let ((cur-entity entity)
 247         p-num)
 248     (while (setq p-num (wl-thread-entity-get-parent cur-entity))
 249       (setq cur-entity (wl-thread-get-entity p-num)))
 250     cur-entity))
 251
 252 (defun wl-thread-entity-parent-invisible-p (entity)
 253   "If parent of ENTITY is invisible, the top invisible ancestor entity of
 254 ENTITY is returned."
 255   (let ((cur-entity entity)
 256         top)
 257     (catch 'done
 258       (while (setq cur-entity (wl-thread-entity-get-parent-entity
 259                                cur-entity))
 260         (if (null (wl-thread-entity-get-number cur-entity))
 261             (throw 'done nil)
 262           (when (not (wl-thread-entity-get-opened cur-entity))
 263             (setq top cur-entity)))))
 264     top))
 265
 266 (defun wl-thread-entity-get-nearly-older-brother (entity &optional parent)
 267   (let ((brothers (wl-thread-entity-get-older-brothers entity parent)))
 268     (when brothers
 269       (car (last brothers)))))
 270
 271 (defun wl-thread-entity-get-older-brothers (entity &optional parent)
 272   (let ((parent (or parent
 273                     (wl-thread-entity-get-parent-entity entity)))
 274         brothers ret-val)
 275     (if parent
 276         (setq brothers (wl-thread-entity-get-children parent))
 277       (setq brothers wl-thread-entity-list))
 278     (while (and brothers
 279                 (not (eq (wl-thread-entity-get-number entity)
 280                          (car brothers))))
 281       (wl-append ret-val (list (car brothers)))
 282       (setq brothers (cdr brothers)))
 283     ret-val))
 284
 285 (defun wl-thread-entity-get-younger-brothers (entity &optional parent)
 286   (let* ((parent (or parent
 287                      (wl-thread-entity-get-parent-entity entity)))
 288          (brothers (wl-thread-entity-get-children parent)))
 289     (if parent
 290         (cdr (memq (wl-thread-entity-get-number entity)
 291                    brothers))
 292       ;; top!!
 293       (cdr (memq (car entity) wl-thread-entity-list)))))
 294
 295 (defun wl-thread-jump-to-msg (&optional number)
 296   "Jump to the message with specified number in the current summary."
 297   (interactive)
 298   (let ((num (or number
 299                  (string-to-int
 300                   (read-from-minibuffer "Jump to Message(No.): ")))))
 301     (wl-thread-entity-force-open (wl-thread-get-entity num))
 302     (wl-summary-jump-to-msg num)))
 303
 304 (defun wl-thread-close-all ()
 305   "Close all top threads."
 306   (interactive)
 307   (elmo-with-progress-display
 308       (wl-thread-close-all (length wl-thread-entity-list))
 309       "Closing all threads"
 310     (save-excursion
 311       (dolist (entity wl-thread-entity-list)
 312         (when (and (wl-thread-entity-get-opened (wl-thread-get-entity
 313                                                  entity))
 314                    (wl-thread-entity-get-children (wl-thread-get-entity
 315                                                    entity)))
 316           (wl-summary-jump-to-msg entity)
 317           (wl-thread-open-close))
 318         (elmo-progress-notify 'wl-thread-close-all)))))
 319
 320 (defun wl-thread-open-all ()
 321   "Open all threads."
 322   (interactive)
 323   (elmo-with-progress-display
 324       (wl-thread-open-all (count-lines (point-min) (point-max)))
 325       "Opening all threads"
 326     (save-excursion
 327       (goto-char (point-min))
 328       (while (not (eobp))
 329         (if (wl-thread-entity-get-opened
 330              (wl-thread-get-entity (wl-summary-message-number)))
 331             (forward-line 1)
 332           (wl-thread-force-open)
 333           (wl-thread-goto-bottom-of-sub-thread))
 334         (elmo-progress-notify 'wl-thread-open-all)))))
 335
 336 (defun wl-thread-open-all-unread ()
 337   (interactive)
 338   (dolist (number (elmo-folder-list-flagged wl-summary-buffer-elmo-folder
 339                                             'digest 'in-msgdb))
 340     (wl-thread-entity-force-open (wl-thread-get-entity number))))
 341
 342 (defsubst wl-thread-maybe-get-children-num (msg)
 343   (let ((entity (wl-thread-get-entity msg)))
 344     (if (not (wl-thread-entity-get-opened entity))
 345         (wl-thread-entity-get-children-num entity))))
 346
 347 (defsubst wl-thread-update-line-on-buffer-sub (entity msg &optional parent-msg)
 348   (let* ((entity (or entity (wl-thread-get-entity msg)))
 349          (parent-msg (or parent-msg (wl-thread-entity-get-parent entity)))
 350          (buffer-read-only nil)
 351          (inhibit-read-only t)
 352          message-entity temp-mark summary-line invisible-top)
 353     (if (wl-thread-delete-line-from-buffer msg)
 354         (progn
 355           (cond
 356            ((memq msg wl-summary-buffer-target-mark-list)
 357             (setq temp-mark "*"))
 358            ((setq temp-mark (wl-summary-registered-temp-mark msg))
 359             (setq temp-mark (nth 1 temp-mark)))
 360            (t (setq temp-mark (wl-summary-get-score-mark msg))))
 361           (when (setq message-entity
 362                       (elmo-message-entity wl-summary-buffer-elmo-folder
 363                                            msg))
 364             (wl-summary-insert-line
 365              (wl-summary-create-line
 366               message-entity
 367               (elmo-message-entity wl-summary-buffer-elmo-folder
 368                                    parent-msg)
 369               temp-mark
 370               (elmo-message-status wl-summary-buffer-elmo-folder msg)
 371               (if wl-thread-insert-force-opened
 372                   nil
 373                 (wl-thread-maybe-get-children-num msg))
 374               (wl-thread-make-indent-string entity)
 375               (wl-thread-entity-get-linked entity)))))
 376       ;; insert thread (moving thread)
 377       (if (not (setq invisible-top
 378                      (wl-thread-entity-parent-invisible-p entity)))
 379           (wl-summary-update-thread
 380            (elmo-message-entity wl-summary-buffer-elmo-folder msg)
 381            entity
 382            (and parent-msg
 383                 (elmo-message-entity wl-summary-buffer-elmo-folder
 384                                      parent-msg)))
 385         ;; currently invisible.. update closed line.
 386         (wl-thread-update-children-number invisible-top)))))
 387
 388 (defun wl-thread-update-line-on-buffer (&optional msg parent-msg updates)
 389   (interactive)
 390   (let ((msgs (list (or msg (wl-summary-message-number))))
 391         entity children msgs-stack)
 392    (while msgs
 393     (setq msg (wl-pop msgs))
 394     (setq updates (and updates (delete msg updates)))
 395     (setq entity (wl-thread-get-entity msg))
 396     (wl-thread-update-line-on-buffer-sub entity msg parent-msg)
 397     ;;
 398     (setq children (wl-thread-entity-get-children entity))
 399     (if children
 400         ;; update children
 401         (when (wl-thread-entity-get-opened entity)
 402           (wl-push msgs msgs-stack)
 403           (setq parent-msg msg
 404                 msgs children))
 405       (unless msgs
 406         (while (and (null msgs) msgs-stack)
 407           (setq msgs (wl-pop msgs-stack)))
 408         (when msgs
 409           (setq parent-msg
 410                 (wl-thread-entity-get-number
 411                  (wl-thread-entity-get-parent-entity
 412                   (wl-thread-get-entity (car msgs)))))))))
 413    updates))
 414
 415 (defun wl-thread-update-line-msgs (msgs)
 416   (wl-delete-all-overlays)
 417   (dolist (message msgs)
 418     (wl-thread-update-line-on-buffer-sub nil message)
 419     (elmo-progress-notify 'wl-thread-update-line)))
 420
 421 (defun wl-thread-delete-line-from-buffer (msg)
 422   "Simply delete msg line."
 423   (let (beg)
 424     (if (wl-summary-jump-to-msg msg)
 425         (progn
 426           (setq beg (point))
 427           (forward-line 1)
 428           (delete-region beg (point))
 429           t)
 430       nil)))
 431
 432 (defun wl-thread-cleanup-symbols (msgs)
 433   (let (entity)
 434     (while msgs
 435       (when (setq entity (wl-thread-get-entity (car msgs)))
 436         ;; delete entity.
 437         (setq wl-thread-entities (delq entity wl-thread-entities))
 438         ;; free symbol.
 439         (elmo-clear-hash-val (format "#%d" (car msgs))
 440                              wl-thread-entity-hashtb))
 441       (setq msgs (cdr msgs)))))
 442
 443 (defun wl-thread-get-exist-children (msg &optional include-self)
 444   (let ((msgs (list msg))
 445         msgs-stack children
 446         entity ret-val)
 447     (while msgs
 448       (setq children (wl-thread-entity-get-children
 449                       (setq entity (wl-thread-get-entity (car msgs)))))
 450       (when (elmo-message-entity wl-summary-buffer-elmo-folder (car msgs))
 451         (wl-append ret-val (list (car msgs)))
 452         (setq children nil))
 453       (setq msgs (cdr msgs))
 454       (if (null children)
 455           (while (and (null msgs) msgs-stack)
 456             (setq msgs (wl-pop msgs-stack)))
 457         (wl-push msgs msgs-stack)
 458         (setq msgs children)))
 459     (unless include-self (setq ret-val (delq msg ret-val)))
 460     ret-val))
 461
 462 (defun wl-thread-delete-message (msg &optional deep update)
 463   "Delete MSG from entity and buffer."
 464   (save-excursion
 465     (let ((entity (wl-thread-get-entity msg))
 466           top-child top-entity update-msgs invisible-top)
 467       (setq wl-summary-buffer-number-list
 468             (delq msg wl-summary-buffer-number-list))
 469       (when entity
 470         (when deep
 471           (setq wl-summary-buffer-number-list
 472                 (elmo-list-delete
 473                  (wl-thread-entity-get-descendant entity)
 474                  wl-summary-buffer-number-list
 475                  #'delq)))
 476         (let ((parent (wl-thread-entity-get-parent-entity entity)))
 477           (if parent
 478               ;; has parent.
 479               (let (children
 480                     (older-brothers (wl-thread-entity-get-older-brothers
 481                                      entity parent))
 482                     (younger-brothers (wl-thread-entity-get-younger-brothers
 483                                        entity parent)))
 484                 (unless deep
 485                   (setq children (wl-thread-entity-get-children entity))
 486                   (wl-thread-reparent-children
 487                    children (wl-thread-entity-get-number parent))
 488                   (setq update-msgs
 489                         (apply (function nconc)
 490                                update-msgs
 491                                (mapcar
 492                                 (function
 493                                  (lambda (message)
 494                                    (wl-thread-get-children-msgs message t)))
 495                                 children))))
 496                 (wl-thread-entity-set-children
 497                  parent (append older-brothers children younger-brothers))
 498                 ;; If chidren and younger-brothers do not exist,
 499                 ;; update nearly older brother.
 500                 (when (and older-brothers
 501                            (not younger-brothers)
 502                            (not children))
 503                   (wl-append
 504                    update-msgs
 505                    (wl-thread-get-children-msgs (car (last older-brothers))))))
 506             ;; top...oldest child becomes top.
 507             (unless deep
 508               (let ((children (wl-thread-entity-get-children entity)))
 509                 (when children
 510                   (setq top-child (car children)
 511                         children (cdr children))
 512                   (setq top-entity (wl-thread-get-entity top-child))
 513                   (wl-thread-entity-set-parent top-entity nil)
 514                   (wl-thread-entity-set-linked top-entity nil)
 515                   (wl-append update-msgs
 516                              (wl-thread-get-children-msgs top-child t)))
 517                 (when children
 518                   (wl-thread-entity-set-children
 519                    top-entity
 520                    (append
 521                     (wl-thread-entity-get-children top-entity)
 522                     children))
 523                   (wl-thread-reparent-children children top-child)
 524                   (wl-append update-msgs children))))
 525             ;; delete myself from top list.
 526             (let ((match (memq msg wl-thread-entity-list)))
 527               (when match
 528                 (if top-child
 529                     (setcar match top-child)
 530                   (setq wl-thread-entity-list
 531                         (delq msg wl-thread-entity-list))))))))
 532       ;;
 533       (if deep
 534           ;; delete thread on buffer
 535           (when (wl-summary-jump-to-msg msg)
 536             (let ((beg (point)))
 537               (wl-thread-goto-bottom-of-sub-thread)
 538               (delete-region beg (point))))
 539         ;; delete myself from buffer.
 540         (unless (wl-thread-delete-line-from-buffer msg)
 541           ;; jump to suitable point.
 542           ;; just upon the oldest younger-brother of my top.
 543           (setq invisible-top
 544                 (car (wl-thread-entity-parent-invisible-p entity)))
 545           (if invisible-top
 546               (progn
 547                 (wl-append update-msgs (list invisible-top))
 548                 (wl-summary-jump-to-msg invisible-top))
 549             (goto-char (point-max))))
 550
 551         ;; insert children if thread is closed or delete top.
 552         (when (or top-child
 553                   (not (wl-thread-entity-get-opened entity)))
 554           (let (next-top insert-msgs ent grandchildren)
 555             (if top-child
 556                 (progn
 557                   (setq insert-msgs (wl-thread-get-exist-children
 558                                      top-child 'include-self))
 559                   (setq next-top (car insert-msgs))
 560                   (setq ent (wl-thread-get-entity next-top))
 561                   (when (and
 562                          (wl-thread-entity-get-opened entity) ;; open
 563                          (not (wl-thread-entity-get-opened ent)) ;; close
 564                          (setq grandchildren
 565                                (wl-thread-entity-get-children ent))
 566                          (wl-summary-jump-to-msg next-top))
 567                     (forward-line 1)
 568                     (setq insert-msgs (append (cdr insert-msgs) grandchildren)))
 569                   (when top-entity (wl-thread-entity-set-opened top-entity t))
 570                   (when ent (wl-thread-entity-set-opened ent t)))
 571               (when (not invisible-top)
 572                 (setq insert-msgs (wl-thread-get-exist-children msg))
 573                 ;; First msg always opened, because first msg maybe becomes top.
 574                 (if (setq ent (wl-thread-get-entity (car insert-msgs)))
 575                     (wl-thread-entity-set-opened ent t))))
 576             ;; insert children
 577             (while insert-msgs
 578               ;; if no exists in summary, insert entity.
 579               (when (and (car insert-msgs)
 580                          (not (wl-summary-jump-to-msg (car insert-msgs))))
 581                 (setq ent (wl-thread-get-entity (car insert-msgs)))
 582                 (wl-thread-insert-entity 0 ; no mean now...
 583                                          ent entity nil))
 584               (setq insert-msgs (cdr insert-msgs))))))
 585       (if update
 586           ;; modify buffer.
 587           (while update-msgs
 588             (wl-thread-update-line-on-buffer-sub nil (pop update-msgs)))
 589         ;; don't update buffer
 590         update-msgs)))) ; return value
 591
 592 (defun wl-thread-insert-message (message-entity
 593                                  msg parent-msg &optional update linked)
 594   "Insert MSG to the entity.
 595 When optional argument UPDATE is non-nil,
 596 Message is inserted to the summary buffer."
 597   (let ((parent (wl-thread-get-entity parent-msg))
 598         child-entity invisible-top)
 599 ;;; Update the thread view...not implemented yet.
 600 ;;;  (when force-insert
 601 ;;;    (if parent
 602 ;;;       (wl-thread-entity-force-open parent))
 603     (when (and wl-summary-max-thread-depth parent)
 604       (let ((cur parent)
 605             (depth 0))
 606         (while cur
 607           (incf depth)
 608           (setq cur (wl-thread-entity-get-parent-entity cur)))
 609         (when (> depth wl-summary-max-thread-depth)
 610           (setq parent nil
 611                 parent-msg nil))))
 612     (if parent
 613         ;; insert as children.
 614         (wl-thread-entity-insert-as-children
 615          parent
 616          (setq child-entity (wl-thread-create-entity
 617                              msg (nth 0 parent) nil linked)))
 618       ;; insert as top message.
 619       (wl-thread-entity-insert-as-top
 620        (wl-thread-create-entity msg nil)))
 621     (if update
 622         (if (not (setq invisible-top
 623                        (wl-thread-entity-parent-invisible-p child-entity)))
 624             ;; visible.
 625             (progn
 626               (wl-summary-update-thread
 627                message-entity
 628                child-entity
 629                (elmo-message-entity wl-summary-buffer-elmo-folder
 630                                     parent-msg))
 631               (when parent
 632                 ;; use thread structure.
 633                 ;;(wl-thread-entity-get-nearly-older-brother
 634                 ;; child-entity parent))) ; return value
 635                 (wl-thread-entity-get-number parent))) ; return value
 636 ;;;           (setq beg (point))
 637 ;;;           (wl-thread-goto-bottom-of-sub-thread)
 638 ;;;           (wl-thread-update-indent-string-region beg (point)))
 639           ;; currently invisible.. update closed line.
 640           (wl-thread-update-children-number invisible-top)
 641           nil))))
 642
 643 ;(defun wl-thread-get-parent-list (msgs)
 644 ;  ;; return ancestors
 645 ;  (let* ((msgs2 msgs)
 646 ;        myself)
 647 ;    (while msgs2
 648 ;      (setq myself (car msgs2)
 649 ;           msgs2 (cdr msgs2))
 650 ;      (while (not (eq myself (car msgs2)))
 651 ;       (if (wl-thread-descendant-p myself (car msgs2))
 652 ;           (setq msgs (delq (car msgs2) msgs)))
 653 ;       (setq msgs2 (or (cdr msgs2) msgs)))
 654 ;      (setq msgs2 (cdr msgs2)))
 655 ;    msgs))
 656
 657 (defun wl-thread-get-parent-list (msgs)
 658   ;; return connected ancestors
 659   (let ((ptr msgs)
 660         parent ret)
 661     (while (car ptr)
 662       (setq parent (wl-thread-entity-get-parent (wl-thread-get-entity (car ptr))))
 663       (when (or (not parent)
 664                 (not (memq parent msgs)))
 665         (setq ret (append ret (list (car ptr)))))
 666       (setq ptr (cdr ptr)))
 667     ret))
 668
 669 (defun wl-thread-update-indent-string-thread (top-list)
 670   (let ((top-list (wl-thread-get-parent-list top-list))
 671         beg)
 672     (elmo-with-progress-display
 673         (wl-thread-update-indent-string-thread (length top-list))
 674         "Updating thread indent"
 675       (while top-list
 676         (when (car top-list)
 677           (wl-summary-jump-to-msg (car top-list))
 678           (setq beg (point))
 679           (wl-thread-goto-bottom-of-sub-thread)
 680           (wl-thread-update-indent-string-region beg (point)))
 681         (elmo-progress-notify 'wl-thread-update-indent-string-thread)
 682         (setq top-list (cdr top-list))))))
 683
 684 (defun wl-thread-update-children-number (entity)
 685   "Update the children number."
 686   (wl-thread-update-line-on-buffer (wl-thread-entity-get-number entity)))
 687
 688 ;;
 689 ;; Thread oriented commands.
 690 ;;
 691 (defun wl-thread-call-region-func (func &optional arg)
 692   (save-excursion
 693     (if arg
 694         (wl-summary-goto-top-of-current-thread)
 695       (beginning-of-line))
 696     (let ((beg (point)))
 697       (wl-thread-goto-bottom-of-sub-thread)
 698       (funcall func beg (point)))))
 699
 700 (defun wl-thread-prefetch (&optional arg)
 701   (interactive "P")
 702   (wl-thread-call-region-func 'wl-summary-prefetch-region arg))
 703
 704 (defun wl-thread-mark-as-read (&optional arg)
 705   (interactive "P")
 706   (wl-thread-call-region-func 'wl-summary-mark-as-read-region arg))
 707
 708 (defun wl-thread-mark-as-unread (&optional arg)
 709   (interactive "P")
 710   (wl-thread-call-region-func 'wl-summary-mark-as-unread-region arg))
 711
 712 (defun wl-thread-mark-as-important (&optional arg)
 713   (interactive "P")
 714   (wl-thread-call-region-func 'wl-summary-mark-as-important-region arg))
 715
 716 (defun wl-thread-set-flags (&optional arg)
 717   (interactive "P")
 718   (wl-thread-call-region-func 'wl-summary-set-flags-region arg))
 719
 720 (defun wl-thread-mark-as-answered (&optional arg)
 721   (interactive "P")
 722   (wl-thread-call-region-func 'wl-summary-mark-as-answered-region arg))
 723
 724 (defun wl-thread-recover-messages (&optional arg)
 725   "Recover killed messages which are contained current thread."
 726   (interactive "P")
 727   (wl-thread-call-region-func 'wl-summary-recover-messages-region arg))
 728
 729 (defun wl-thread-unmark (&optional arg)
 730   (interactive "P")
 731   (wl-thread-call-region-func 'wl-summary-unmark-region arg))
 732
 733 (defun wl-thread-exec (&optional arg)
 734   (interactive "P")
 735   (wl-thread-call-region-func 'wl-summary-exec-region arg))
 736
 737 (defun wl-thread-save (&optional arg)
 738   (interactive "P")
 739   (wl-thread-call-region-func 'wl-summary-save-region arg))
 740
 741 (defun wl-thread-force-open (&optional msg-num)
 742   "force open current folder"
 743   (when msg-num
 744     (wl-summary-jump-to-msg msg-num))
 745   (wl-thread-open-close 'force-open))
 746
 747 (defun wl-thread-entity-force-open (entity)
 748   (let ((wl-thread-insert-force-opened t)
 749         notopen)
 750     (if (null (wl-thread-entity-get-parent entity))
 751         ;; top!!
 752         (if (and (not (wl-thread-entity-get-opened entity))
 753                  (wl-thread-entity-get-children entity))
 754             (wl-thread-force-open (wl-thread-entity-get-number entity)))
 755       (if (setq notopen (wl-thread-entity-parent-invisible-p entity))
 756           (wl-thread-force-open (wl-thread-entity-get-number notopen))))))
 757
 758 (defun wl-thread-insert-top ()
 759   (let ((elist wl-thread-entity-list)
 760         (len (length wl-thread-entity-list)))
 761     (elmo-with-progress-display
 762         (wl-thread-insert-entity (length wl-thread-entity-list))
 763         "Inserting message"
 764       (wl-delete-all-overlays)
 765       (while elist
 766         (wl-thread-insert-entity
 767          0
 768          (wl-thread-get-entity (car elist))
 769          nil
 770          len)
 771         (elmo-progress-notify 'wl-thread-insert-entity)
 772         (setq elist (cdr elist))))))
 773
 774 (defsubst wl-thread-insert-entity-sub (indent entity parent-entity all)
 775   (let (msg-num
 776         message-entity
 777         temp-mark
 778         summary-line)
 779     (when (setq msg-num (wl-thread-entity-get-number entity))
 780       (unless all ; all...means no temp-mark.
 781         (cond ((memq msg-num wl-summary-buffer-target-mark-list)
 782                (setq temp-mark "*"))
 783               ((setq temp-mark (wl-summary-registered-temp-mark msg-num))
 784                (setq temp-mark (nth 1 temp-mark)))))
 785       (unless temp-mark
 786         (setq temp-mark (wl-summary-get-score-mark msg-num)))
 787       (setq message-entity
 788             (elmo-message-entity wl-summary-buffer-elmo-folder
 789                                  (nth 0 entity)))
 790 ;;;   (wl-delete-all-overlays)
 791       (when message-entity
 792         (wl-summary-insert-line
 793          (wl-summary-create-line
 794           message-entity
 795           (elmo-message-entity wl-summary-buffer-elmo-folder
 796                                (nth 0 parent-entity))
 797           temp-mark
 798           (elmo-message-status wl-summary-buffer-elmo-folder msg-num)
 799           (if wl-thread-insert-force-opened
 800               nil
 801             (wl-thread-maybe-get-children-num msg-num))
 802           (wl-thread-make-indent-string entity)
 803           (wl-thread-entity-get-linked entity)))))))
 804
 805 (defun wl-thread-insert-entity (indent entity parent-entity all)
 806   "Insert thread entity in current buffer."
 807   (let ((msgs (list (car entity)))
 808         children msgs-stack)
 809     (while msgs
 810       (wl-thread-insert-entity-sub indent entity parent-entity all)
 811       (setq msgs (cdr msgs))
 812       (setq children (nth 2 entity))
 813       (if children
 814           ;; insert children
 815           (when (or wl-thread-insert-force-opened
 816                     (wl-thread-entity-get-opened entity))
 817             (wl-thread-entity-set-opened entity t)
 818             (wl-push msgs msgs-stack)
 819             (setq msgs children
 820                   indent (1+ indent)
 821                   parent-entity entity)))
 822       (unless msgs
 823         (while (and (null msgs) msgs-stack)
 824           (setq msgs (wl-pop msgs-stack))
 825           (setq indent (1- indent)))
 826         (when msgs
 827           (setq entity (wl-thread-get-entity (car msgs)))
 828           (setq parent-entity (wl-thread-entity-get-parent-entity entity))))
 829       (setq entity (wl-thread-get-entity (car msgs))))))
 830
 831 (defun wl-thread-descendant-p (mynumber number)
 832   (let ((cur (wl-thread-get-entity number))
 833         num)
 834     (catch 'done
 835       (while cur
 836         (setq cur (wl-thread-entity-get-parent-entity cur))
 837         (if (null (setq num (wl-thread-entity-get-number cur))) ; top!
 838             (throw 'done nil))
 839         (if (and num
 840                  (eq mynumber (wl-thread-entity-get-number cur)))
 841             (throw 'done t)))
 842       nil)))
 843
 844 ;; (defun wl-thread-goto-bottom-of-sub-thread ()
 845 ;;   (interactive)
 846 ;;   (let ((depth (wl-thread-get-depth-of-current-line)))
 847 ;;     (forward-line 1)
 848 ;;     (while (and (not (eobp))
 849 ;;              (> (wl-thread-get-depth-of-current-line)
 850 ;;                 depth))
 851 ;;       (forward-line 1))
 852 ;;     (beginning-of-line)))
 853
 854 (defun wl-thread-goto-bottom-of-sub-thread (&optional msg)
 855   (interactive)
 856   (let ((mynumber (or msg (wl-summary-message-number))))
 857     (forward-line 1)
 858     (while (wl-thread-descendant-p mynumber (wl-summary-message-number))
 859       (forward-line 1))
 860     (beginning-of-line)))
 861
 862 (defun wl-thread-remove-argument-region (beg end)
 863   (save-excursion
 864     (save-restriction
 865       (narrow-to-region beg end)
 866       (goto-char (point-min))
 867       (while (not (eobp))
 868         (wl-summary-remove-argument)
 869         (forward-line 1)))))
 870
 871 (defun wl-thread-print-argument-region (beg end)
 872   (if wl-summary-buffer-temp-mark-list
 873       (save-excursion
 874         (save-restriction
 875           (narrow-to-region beg end)
 876           (goto-char (point-min))
 877           (while (not (eobp))
 878             (let ((num (wl-summary-message-number))
 879                   temp-mark pair)
 880               (when (and (setq temp-mark
 881                                (wl-summary-registered-temp-mark num))
 882                          (nth 2 temp-mark)
 883                          (setq pair (cons (nth 0 temp-mark)(nth 2 temp-mark))))
 884                 (wl-summary-print-argument (car pair) (cdr pair))))
 885             (forward-line 1))))))
 886
 887 (defsubst wl-thread-get-children-msgs (msg &optional visible-only)
 888   (let ((msgs (list msg))
 889         msgs-stack children
 890         entity ret-val)
 891     (while msgs
 892       (wl-append ret-val (list (car msgs)))
 893       (setq children (wl-thread-entity-get-children
 894                       (setq entity (wl-thread-get-entity (car msgs)))))
 895       (if (and visible-only
 896                (not (wl-thread-entity-get-opened entity)))
 897           (setq children nil))
 898       (setq msgs (cdr msgs))
 899       (if (null children)
 900           (while (and (null msgs) msgs-stack)
 901             (setq msgs (wl-pop msgs-stack)))
 902         (wl-push msgs msgs-stack)
 903         (setq msgs children)))
 904     ret-val))
 905
 906 (defun wl-thread-get-children-msgs-uncached (msg &optional uncached-marks)
 907   (let ((children-msgs (wl-thread-get-children-msgs msg))
 908         mark uncached-list)
 909     (while children-msgs
 910       (if (and (not (eq msg (car children-msgs))) ; except itself
 911                (or (and uncached-marks
 912                         (setq mark (wl-summary-message-mark
 913                                     wl-summary-buffer-elmo-folder
 914                                     (car children-msgs)))
 915                         (member mark uncached-marks))
 916                    (and (not uncached-marks)
 917                         (null (elmo-file-cache-exists-p
 918                                (elmo-message-field
 919                                 wl-summary-buffer-elmo-folder
 920                                 (car children-msgs)
 921                                 'message-id))))))
 922           (wl-append uncached-list (list (car children-msgs))))
 923       (setq children-msgs (cdr children-msgs)))
 924     uncached-list))
 925
 926 (defun wl-thread-get-children-msgs-with-mark (msg mark)
 927   (let ((children-msgs (wl-thread-get-children-msgs msg))
 928         (check-func (cond ((string= mark "o")
 929                            'wl-summary-msg-marked-as-refiled)
 930                           ((string= mark "O")
 931                            'wl-summary-msg-marked-as-copied)
 932                           ((string= mark "D")
 933                            'wl-summary-msg-marked-as-deleted)
 934                           ((string= mark "*")
 935                            'wl-summary-msg-marked-as-target)))
 936         ret-val)
 937     (while children-msgs
 938       (if (funcall check-func (car children-msgs))
 939           (wl-append ret-val (list (car children-msgs))))
 940       (setq children-msgs (cdr children-msgs)))
 941     ret-val))
 942
 943 (defun wl-thread-close (entity)
 944   (let (depth beg)
 945     (wl-thread-entity-set-opened entity nil)
 946     (setq depth (wl-thread-get-depth-of-current-line))
 947     (beginning-of-line)
 948     (setq beg (point))
 949     (wl-thread-goto-bottom-of-sub-thread)
 950     (wl-thread-remove-argument-region beg
 951                                       (point))
 952     (forward-char -1)   ;; needed for mouse-face.
 953     (delete-region beg (point))
 954     (wl-thread-insert-entity (- depth 1)
 955                              entity
 956                              (wl-thread-get-entity
 957                               (nth 3 entity))
 958                              nil)
 959     (delete-char 1) ; delete '\n'
 960     (wl-thread-print-argument-region beg (point))))
 961
 962 (defun wl-thread-close-children (&optional number)
 963   (interactive)
 964   (when (eq wl-summary-buffer-view 'thread)
 965     (setq number (or number (wl-summary-message-number)))
 966     (save-excursion
 967       (let ((inhibit-read-only t)
 968             (entity (wl-thread-get-entity number)))
 969         (when (wl-thread-entity-get-opened entity)
 970           (wl-thread-close entity))))))
 971
 972 (defun wl-thread-open (entity)
 973   (let (depth beg)
 974     (beginning-of-line)
 975     (setq beg (point))
 976     (setq depth (wl-thread-get-depth-of-current-line))
 977     (end-of-line)
 978     (delete-region beg (point))
 979     (wl-thread-entity-set-opened entity t)
 980     (wl-thread-insert-entity depth ;(- depth 1)
 981                              entity
 982                              (wl-thread-get-entity
 983                               (nth 3 entity)) nil)
 984     (delete-char 1) ; delete '\n'
 985     (wl-thread-print-argument-region beg (point))))
 986
 987 (defun wl-thread-open-children (&optional number)
 988   (interactive)
 989   (when (eq wl-summary-buffer-view 'thread)
 990     (setq number (or number (wl-summary-message-number)))
 991     (save-excursion
 992       (let ((inhibit-read-only t)
 993             (entity (wl-thread-get-entity number)))
 994         (unless (wl-thread-entity-get-opened entity)
 995           (wl-thread-open entity))))))
 996
 997 (defun wl-thread-open-close (&optional force-open)
 998   (interactive "P")
 999   (when (eq wl-summary-buffer-view 'thread)
1000 ;;; (if (equal wl-thread-top-entity '(nil t nil nil))
1001 ;;;     (error "There's no thread structure"))
1002     (save-excursion
1003       (let ((inhibit-read-only t)
1004             (buffer-read-only nil)
1005             (wl-thread-insert-force-opened
1006              (or wl-thread-insert-force-opened
1007                  force-open))
1008             msg entity parent)
1009         (setq msg (wl-summary-message-number))
1010         (setq entity (wl-thread-get-entity msg))
1011         (if (wl-thread-entity-get-opened entity)
1012             ;; if already opened, close its child!
1013           (if (wl-thread-entity-get-children entity)
1014               (wl-thread-close entity)
1015             ;; opened, but has no children, close its parent!
1016             (when (setq parent (wl-thread-entity-get-parent entity))
1017               (wl-summary-jump-to-msg parent)
1018               (wl-thread-close
1019                (wl-thread-get-entity (wl-summary-message-number)))))
1020           ;; if closed (or it is just a thread bottom message)
1021           ;; has children, open it!
1022           (if (wl-thread-entity-get-children entity)
1023               (wl-thread-open entity)
1024             ;; closed, and has no children, close its parent!
1025             (setq msg (or (wl-thread-entity-get-parent entity)
1026                           (wl-thread-entity-get-number entity)))
1027             (when msg
1028               (wl-summary-jump-to-msg msg)
1029               (wl-thread-close
1030                (wl-thread-get-entity (wl-summary-message-number)))))))
1031       (when wl-summary-lazy-highlight
1032         (wl-highlight-summary-window))
1033       (wl-summary-set-message-modified)
1034       (set-buffer-modified-p nil))))
1035
1036 (defun wl-thread-get-depth-of-current-line ()
1037   (let ((entity (wl-thread-get-entity (wl-summary-message-number)))
1038         (depth 0)
1039         number)
1040     (while (setq number (wl-thread-entity-get-parent entity))
1041       (incf depth)
1042       (setq entity (wl-thread-get-entity number)))
1043     depth))
1044
1045 (defun wl-thread-update-indent-string-region (beg end)
1046   (interactive "r")
1047   (save-excursion
1048     (goto-char beg)
1049     (while (< (point) end)
1050       (save-excursion
1051         (wl-thread-update-line-on-buffer-sub nil (wl-summary-message-number)))
1052       (forward-line 1))))
1053
1054 (defsubst wl-thread-make-indent-string (entity)
1055   (let ((cur entity)
1056         (ret-val "")
1057         (space-str (wl-repeat-string wl-thread-space-str-internal
1058                                      (- wl-thread-indent-level-internal 1)))
1059         parent)
1060     (when (wl-thread-entity-get-number
1061            (setq parent (wl-thread-entity-get-parent-entity cur)))
1062       (if (wl-thread-entity-get-younger-brothers cur)
1063           (setq ret-val wl-thread-have-younger-brother-str-internal)
1064         (setq ret-val wl-thread-youngest-child-str-internal))
1065       (setq ret-val (concat ret-val
1066                             (wl-repeat-string
1067                              wl-thread-horizontal-str-internal
1068                              (- wl-thread-indent-level-internal 1))))
1069       (setq cur parent)
1070       (while (wl-thread-entity-get-number
1071               (wl-thread-entity-get-parent-entity cur))
1072         (if (wl-thread-entity-get-younger-brothers cur)
1073             (setq ret-val (concat wl-thread-vertical-str-internal
1074                                   space-str
1075                                   ret-val))
1076           (setq ret-val (concat wl-thread-space-str-internal
1077                                 space-str
1078                                 ret-val)))
1079         (setq cur (wl-thread-entity-get-parent-entity cur))))
1080     ret-val))
1081
1082 (defun wl-thread-set-parent (&optional parent-number)
1083   "Set current message's parent interactively."
1084   (interactive)
1085   (let ((number (wl-summary-message-number))
1086         (dst-parent (if (interactive-p)
1087                         (read-from-minibuffer "Parent Message (No.): ")))
1088         entity dst-parent-entity src-parent children
1089         update-msgs
1090         buffer-read-only)
1091     (if (string= dst-parent "")
1092         (setq dst-parent nil)
1093       (if (interactive-p)
1094           (setq dst-parent (string-to-int dst-parent))
1095         (setq dst-parent parent-number)))
1096     (if (and dst-parent
1097              (memq dst-parent (wl-thread-get-children-msgs number)))
1098         (error "Parent is children or myself"))
1099     (setq entity (wl-thread-get-entity number))
1100     (when (and number entity)
1101       ;; delete thread
1102       (setq update-msgs (wl-thread-delete-message number 'deep))
1103       ;; insert as child at new parent
1104       (setq dst-parent-entity (wl-thread-get-entity dst-parent))
1105       (if dst-parent-entity
1106           (progn
1107             (if (setq children
1108                       (wl-thread-entity-get-children dst-parent-entity))
1109                 (wl-append update-msgs
1110                            (wl-thread-get-children-msgs
1111                             (car (last children)) t)))
1112             (wl-thread-entity-set-children
1113              dst-parent-entity
1114              (append children (list number)))
1115             (wl-thread-entity-set-linked
1116              entity
1117              (let ((parent (elmo-message-entity-parent
1118                             wl-summary-buffer-elmo-folder
1119                             (elmo-message-entity
1120                              wl-summary-buffer-elmo-folder
1121                              number))))
1122                (or (null parent)
1123                    (/= parent-number (elmo-message-entity-number parent))))))
1124         ;; insert as top
1125         (wl-append wl-thread-entity-list (list number))
1126         (wl-thread-entity-set-linked entity nil))
1127
1128       ;; update my thread
1129       (wl-append update-msgs (wl-thread-get-children-msgs number t))
1130       (setq update-msgs (elmo-uniq-list update-msgs))
1131       (wl-thread-entity-set-parent entity dst-parent)
1132       ;; update thread on buffer
1133       (wl-thread-make-number-list)
1134       (wl-thread-update-line-msgs update-msgs))))
1135
1136 (require 'product)
1137 (product-provide (provide 'wl-thread) (require 'wl-version))
1138
1139 ;;; wl-thread.el ends here