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     (wl-thread-entity-set-children to (wl-append children (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 (defun 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 (nconc 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         top)
 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             (throw 'done nil)
 261           (when (not (wl-thread-entity-get-opened cur-entity))
 262             (setq top cur-entity)))))
 263     top))
 264
 265 (defun wl-thread-entity-get-nearly-older-brother (entity &optional parent)
 266   (let ((brothers (wl-thread-entity-get-older-brothers entity parent)))
 267     (when brothers
 268       (car (last brothers)))))
 269
 270 (defun wl-thread-entity-get-older-brothers (entity &optional parent)
 271   (let ((parent (or parent
 272                     (wl-thread-entity-get-parent-entity entity)))
 273         brothers ret-val)
 274     (if parent
 275         (setq brothers (wl-thread-entity-get-children parent))
 276       (setq brothers wl-thread-entity-list))
 277     (while (and brothers
 278                 (not (eq (wl-thread-entity-get-number entity)
 279                          (car brothers))))
 280       (wl-append ret-val (list (car brothers)))
 281       (setq brothers (cdr brothers)))
 282     ret-val))
 283
 284 (defun wl-thread-entity-get-younger-brothers (entity &optional parent)
 285   (let* ((parent (or parent
 286                      (wl-thread-entity-get-parent-entity entity)))
 287          (brothers (wl-thread-entity-get-children parent)))
 288     (if parent
 289         (cdr (memq (wl-thread-entity-get-number entity)
 290                    brothers))
 291       ;; top!!
 292       (cdr (memq (car entity) wl-thread-entity-list)))))
 293
 294 (defun wl-thread-jump-to-msg (&optional number)
 295   "Jump to the message with specified number in the current summary."
 296   (interactive)
 297   (let ((num (or number
 298                  (string-to-number
 299                   (read-from-minibuffer "Jump to Message(No.): ")))))
 300     (wl-thread-entity-force-open (wl-thread-get-entity num))
 301     (wl-summary-jump-to-msg num)))
 302
 303 (defun wl-thread-close-all ()
 304   "Close all top threads."
 305   (interactive)
 306   (elmo-with-progress-display
 307       (wl-thread-close-all (length wl-thread-entity-list))
 308       "Closing all threads"
 309     (save-excursion
 310       (dolist (entity wl-thread-entity-list)
 311         (when (and (wl-thread-entity-get-opened (wl-thread-get-entity
 312                                                  entity))
 313                    (wl-thread-entity-get-children (wl-thread-get-entity
 314                                                    entity)))
 315           (wl-summary-jump-to-msg entity)
 316           (wl-thread-open-close))
 317         (elmo-progress-notify 'wl-thread-close-all)))))
 318
 319 (defun wl-thread-open-all ()
 320   "Open all threads."
 321   (interactive)
 322   (elmo-with-progress-display
 323       (wl-thread-open-all (count-lines (point-min) (point-max)))
 324       "Opening all threads"
 325     (save-excursion
 326       (goto-char (point-min))
 327       (while (not (eobp))
 328         (if (wl-thread-entity-get-opened
 329              (wl-thread-get-entity (wl-summary-message-number)))
 330             (forward-line 1)
 331           (wl-thread-force-open)
 332           (wl-thread-goto-bottom-of-sub-thread))
 333         (elmo-progress-notify 'wl-thread-open-all)))))
 334
 335 (defun wl-thread-open-all-unread ()
 336   (interactive)
 337   (dolist (number (elmo-folder-list-flagged wl-summary-buffer-elmo-folder
 338                                             'digest 'in-msgdb))
 339     (wl-thread-entity-force-open (wl-thread-get-entity number))))
 340
 341 (defsubst wl-thread-maybe-get-children-num (msg)
 342   (let ((entity (wl-thread-get-entity msg)))
 343     (if (not (wl-thread-entity-get-opened entity))
 344         (wl-thread-entity-get-children-num entity))))
 345
 346 (defsubst wl-thread-update-line-on-buffer-sub (entity msg &optional parent-msg)
 347   (let* ((entity (or entity (wl-thread-get-entity msg)))
 348          (parent-msg (or parent-msg (wl-thread-entity-get-parent entity)))
 349          (buffer-read-only nil)
 350          (inhibit-read-only t)
 351          message-entity temp-mark summary-line invisible-top)
 352     (if (wl-thread-delete-line-from-buffer msg)
 353         (progn
 354           (cond
 355            ((memq msg wl-summary-buffer-target-mark-list)
 356             (setq temp-mark "*"))
 357            ((setq temp-mark (wl-summary-registered-temp-mark msg))
 358             (setq temp-mark (nth 1 temp-mark)))
 359            (t (setq temp-mark (wl-summary-get-score-mark msg))))
 360           (when (setq message-entity
 361                       (elmo-message-entity wl-summary-buffer-elmo-folder
 362                                            msg))
 363             (wl-summary-insert-line
 364              (wl-summary-create-line
 365               message-entity
 366               (elmo-message-entity wl-summary-buffer-elmo-folder
 367                                    parent-msg)
 368               temp-mark
 369               (elmo-message-status wl-summary-buffer-elmo-folder msg)
 370               (if wl-thread-insert-force-opened
 371                   nil
 372                 (wl-thread-maybe-get-children-num msg))
 373               (wl-thread-make-indent-string entity)
 374               (wl-thread-entity-get-linked entity)))))
 375       ;; insert thread (moving thread)
 376       (if (not (setq invisible-top
 377                      (wl-thread-entity-parent-invisible-p entity)))
 378           (wl-summary-update-thread
 379            (elmo-message-entity wl-summary-buffer-elmo-folder msg)
 380            entity
 381            (and parent-msg
 382                 (elmo-message-entity wl-summary-buffer-elmo-folder
 383                                      parent-msg)))
 384         ;; currently invisible.. update closed line.
 385         (wl-thread-update-children-number invisible-top)))))
 386
 387 (defun wl-thread-update-line-on-buffer (&optional msg parent-msg updates)
 388   (interactive)
 389   (let ((msgs (list (or msg (wl-summary-message-number))))
 390         entity children msgs-stack)
 391    (while msgs
 392     (setq msg (wl-pop msgs))
 393     (setq updates (and updates (delete msg updates)))
 394     (setq entity (wl-thread-get-entity msg))
 395     (wl-thread-update-line-on-buffer-sub entity msg parent-msg)
 396     ;;
 397     (setq children (wl-thread-entity-get-children entity))
 398     (if children
 399         ;; update children
 400         (when (wl-thread-entity-get-opened entity)
 401           (wl-push msgs msgs-stack)
 402           (setq parent-msg msg
 403                 msgs children))
 404       (unless msgs
 405         (while (and (null msgs) msgs-stack)
 406           (setq msgs (wl-pop msgs-stack)))
 407         (when msgs
 408           (setq parent-msg
 409                 (wl-thread-entity-get-number
 410                  (wl-thread-entity-get-parent-entity
 411                   (wl-thread-get-entity (car msgs)))))))))
 412    updates))
 413
 414 (defun wl-thread-update-line-msgs (msgs)
 415   (wl-delete-all-overlays)
 416   (dolist (message msgs)
 417     (wl-thread-update-line-on-buffer-sub nil message)
 418     (elmo-progress-notify 'wl-thread-update-line)))
 419
 420 (defun wl-thread-delete-line-from-buffer (msg)
 421   "Simply delete msg line."
 422   (let (beg)
 423     (if (wl-summary-jump-to-msg msg)
 424         (progn
 425           (setq beg (point))
 426           (forward-line 1)
 427           (delete-region beg (point))
 428           t)
 429       nil)))
 430
 431 (defun wl-thread-cleanup-symbols (msgs)
 432   (let (entity)
 433     (while msgs
 434       (when (setq entity (wl-thread-get-entity (car msgs)))
 435         ;; delete entity.
 436         (setq wl-thread-entities (delq entity wl-thread-entities))
 437         ;; free symbol.
 438         (elmo-clear-hash-val (format "#%d" (car msgs))
 439                              wl-thread-entity-hashtb))
 440       (setq msgs (cdr msgs)))))
 441
 442 (defun wl-thread-get-exist-children (msg &optional include-self)
 443   (let ((msgs (list msg))
 444         msgs-stack children
 445         entity ret-val)
 446     (while msgs
 447       (setq children (wl-thread-entity-get-children
 448                       (setq entity (wl-thread-get-entity (car msgs)))))
 449       (when (elmo-message-entity wl-summary-buffer-elmo-folder (car msgs))
 450         (wl-append ret-val (list (car msgs)))
 451         (setq children nil))
 452       (setq msgs (cdr msgs))
 453       (if (null children)
 454           (while (and (null msgs) msgs-stack)
 455             (setq msgs (wl-pop msgs-stack)))
 456         (wl-push msgs msgs-stack)
 457         (setq msgs children)))
 458     (unless include-self (setq ret-val (delq msg ret-val)))
 459     ret-val))
 460
 461 (defun wl-thread-delete-message (msg &optional deep update)
 462   "Delete MSG from entity and buffer."
 463   (save-excursion
 464     (let ((entity (wl-thread-get-entity msg))
 465           top-child top-entity update-msgs invisible-top)
 466       (setq wl-summary-buffer-number-list
 467             (delq msg wl-summary-buffer-number-list))
 468       (when entity
 469         (when deep
 470           (setq wl-summary-buffer-number-list
 471                 (elmo-list-delete
 472                  (wl-thread-entity-get-descendant entity)
 473                  wl-summary-buffer-number-list
 474                  #'delq)))
 475         (let ((parent (wl-thread-entity-get-parent-entity entity)))
 476           (if parent
 477               ;; has parent.
 478               (let (children
 479                     (older-brothers (wl-thread-entity-get-older-brothers
 480                                      entity parent))
 481                     (younger-brothers (wl-thread-entity-get-younger-brothers
 482                                        entity parent)))
 483                 (unless deep
 484                   (setq children (wl-thread-entity-get-children entity))
 485                   (wl-thread-reparent-children
 486                    children (wl-thread-entity-get-number parent))
 487                   (setq update-msgs
 488                         (apply (function nconc)
 489                                update-msgs
 490                                (mapcar
 491                                 (function
 492                                  (lambda (message)
 493                                    (wl-thread-get-children-msgs message t)))
 494                                 children))))
 495                 (wl-thread-entity-set-children
 496                  parent (append older-brothers children younger-brothers))
 497                 ;; If chidren and younger-brothers do not exist,
 498                 ;; update nearly older brother.
 499                 (when (and older-brothers
 500                            (not younger-brothers)
 501                            (not children))
 502                   (wl-append
 503                    update-msgs
 504                    (wl-thread-get-children-msgs (car (last older-brothers))))))
 505             ;; top...oldest child becomes top.
 506             (unless deep
 507               (let ((children (wl-thread-entity-get-children entity)))
 508                 (when children
 509                   (setq top-child (car children)
 510                         children (cdr children))
 511                   (setq top-entity (wl-thread-get-entity top-child))
 512                   (wl-thread-entity-set-parent top-entity nil)
 513                   (wl-thread-entity-set-linked top-entity nil)
 514                   (wl-append update-msgs
 515                              (wl-thread-get-children-msgs top-child t)))
 516                 (when children
 517                   (wl-thread-entity-set-children
 518                    top-entity
 519                    (append
 520                     (wl-thread-entity-get-children top-entity)
 521                     children))
 522                   (wl-thread-reparent-children children top-child)
 523                   (wl-append update-msgs children))))
 524             ;; delete myself from top list.
 525             (let ((match (memq msg wl-thread-entity-list)))
 526               (when match
 527                 (if top-child
 528                     (setcar match top-child)
 529                   (setq wl-thread-entity-list
 530                         (delq msg wl-thread-entity-list))))))))
 531       ;;
 532       (if deep
 533           ;; delete thread on buffer
 534           (when (wl-summary-jump-to-msg msg)
 535             (let ((beg (point)))
 536               (wl-thread-goto-bottom-of-sub-thread)
 537               (delete-region beg (point))))
 538         ;; delete myself from buffer.
 539         (unless (wl-thread-delete-line-from-buffer msg)
 540           ;; jump to suitable point.
 541           ;; just upon the oldest younger-brother of my top.
 542           (setq invisible-top
 543                 (car (wl-thread-entity-parent-invisible-p entity)))
 544           (if invisible-top
 545               (progn
 546                 (wl-append update-msgs (list invisible-top))
 547                 (wl-summary-jump-to-msg invisible-top))
 548             (goto-char (point-max))))
 549
 550         ;; insert children if thread is closed or delete top.
 551         (when (or top-child
 552                   (not (wl-thread-entity-get-opened entity)))
 553           (let (next-top insert-msgs ent grandchildren)
 554             (if top-child
 555                 (progn
 556                   (setq insert-msgs (wl-thread-get-exist-children
 557                                      top-child 'include-self))
 558                   (setq next-top (car insert-msgs))
 559                   (setq ent (wl-thread-get-entity next-top))
 560                   (when (and
 561                          (wl-thread-entity-get-opened entity) ;; open
 562                          (not (wl-thread-entity-get-opened ent)) ;; close
 563                          (setq grandchildren
 564                                (wl-thread-entity-get-children ent))
 565                          (wl-summary-jump-to-msg next-top))
 566                     (forward-line 1)
 567                     (setq insert-msgs (append (cdr insert-msgs) grandchildren)))
 568                   (when top-entity (wl-thread-entity-set-opened top-entity t))
 569                   (when ent (wl-thread-entity-set-opened ent t)))
 570               (when (not invisible-top)
 571                 (setq insert-msgs (wl-thread-get-exist-children msg))
 572                 ;; First msg always opened, because first msg maybe becomes top.
 573                 (if (setq ent (wl-thread-get-entity (car insert-msgs)))
 574                     (wl-thread-entity-set-opened ent t))))
 575             ;; insert children
 576             (while insert-msgs
 577               ;; if no exists in summary, insert entity.
 578               (when (and (car insert-msgs)
 579                          (not (wl-summary-jump-to-msg (car insert-msgs))))
 580                 (setq ent (wl-thread-get-entity (car insert-msgs)))
 581                 (wl-thread-insert-entity 0 ; no mean now...
 582                                          ent entity nil))
 583               (setq insert-msgs (cdr insert-msgs))))))
 584       (if update
 585           ;; modify buffer.
 586           (while update-msgs
 587             (wl-thread-update-line-on-buffer-sub nil (pop update-msgs)))
 588         ;; don't update buffer
 589         update-msgs)))) ; return value
 590
 591 (defun wl-thread-insert-message (message-entity
 592                                  msg parent-msg &optional update linked)
 593   "Insert MSG to the entity.
 594 When optional argument UPDATE is non-nil,
 595 Message is inserted to the summary buffer."
 596   (let ((parent (wl-thread-get-entity parent-msg))
 597         child-entity invisible-top)
 598 ;;; Update the thread view...not implemented yet.
 599 ;;;  (when force-insert
 600 ;;;    (if parent
 601 ;;;       (wl-thread-entity-force-open parent))
 602     (when (and wl-summary-max-thread-depth parent)
 603       (let ((cur parent)
 604             (depth 0))
 605         (while cur
 606           (incf depth)
 607           (setq cur (wl-thread-entity-get-parent-entity cur)))
 608         (when (> depth wl-summary-max-thread-depth)
 609           (setq parent nil
 610                 parent-msg nil))))
 611     (if parent
 612         ;; insert as children.
 613         (wl-thread-entity-insert-as-children
 614          parent
 615          (setq child-entity
 616                (wl-thread-create-entity
 617                 msg (wl-thread-entity-get-number 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                                  msg-num))
 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                                (wl-thread-entity-get-number 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 (wl-thread-entity-get-children 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                               (wl-thread-entity-get-parent 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                               (wl-thread-entity-get-parent entity))
 984                              nil)
 985     (delete-char 1) ; delete '\n'
 986     (wl-thread-print-argument-region beg (point))))
 987
 988 (defun wl-thread-open-children (&optional number)
 989   (interactive)
 990   (when (eq wl-summary-buffer-view 'thread)
 991     (setq number (or number (wl-summary-message-number)))
 992     (save-excursion
 993       (let ((inhibit-read-only t)
 994             (entity (wl-thread-get-entity number)))
 995         (unless (wl-thread-entity-get-opened entity)
 996           (wl-thread-open entity))))))
 997
 998 (defun wl-thread-open-close (&optional force-open)
 999   (interactive "P")
1000   (when (eq wl-summary-buffer-view 'thread)
1001 ;;; (if (equal wl-thread-top-entity '(nil t nil nil))
1002 ;;;     (error "There's no thread structure"))
1003     (save-excursion
1004       (let ((inhibit-read-only t)
1005             (buffer-read-only nil)
1006             (wl-thread-insert-force-opened
1007              (or wl-thread-insert-force-opened
1008                  force-open))
1009             msg entity parent)
1010         (setq msg (wl-summary-message-number))
1011         (setq entity (wl-thread-get-entity msg))
1012         (if (wl-thread-entity-get-opened entity)
1013             ;; if already opened, close its child!
1014           (if (wl-thread-entity-get-children entity)
1015               (wl-thread-close entity)
1016             ;; opened, but has no children, close its parent!
1017             (when (setq parent (wl-thread-entity-get-parent entity))
1018               (wl-summary-jump-to-msg parent)
1019               (wl-thread-close
1020                (wl-thread-get-entity (wl-summary-message-number)))))
1021           ;; if closed (or it is just a thread bottom message)
1022           ;; has children, open it!
1023           (if (wl-thread-entity-get-children entity)
1024               (wl-thread-open entity)
1025             ;; closed, and has no children, close its parent!
1026             (setq msg (or (wl-thread-entity-get-parent entity)
1027                           (wl-thread-entity-get-number entity)))
1028             (when msg
1029               (wl-summary-jump-to-msg msg)
1030               (wl-thread-close
1031                (wl-thread-get-entity (wl-summary-message-number)))))))
1032       (when wl-summary-lazy-highlight
1033         (wl-highlight-summary-window))
1034       (wl-summary-set-message-modified)
1035       (set-buffer-modified-p nil))))
1036
1037 (defun wl-thread-get-depth-of-current-line ()
1038   (let ((entity (wl-thread-get-entity (wl-summary-message-number)))
1039         (depth 0)
1040         number)
1041     (while (setq number (wl-thread-entity-get-parent entity))
1042       (incf depth)
1043       (setq entity (wl-thread-get-entity number)))
1044     depth))
1045
1046 (defun wl-thread-update-indent-string-region (beg end)
1047   (interactive "r")
1048   (save-excursion
1049     (goto-char beg)
1050     (while (< (point) end)
1051       (save-excursion
1052         (wl-thread-update-line-on-buffer-sub nil (wl-summary-message-number)))
1053       (forward-line 1))))
1054
1055 (defsubst wl-thread-make-indent-string (entity)
1056   (let ((cur entity)
1057         (ret-val "")
1058         (space-str (wl-repeat-string wl-thread-space-str-internal
1059                                      (- wl-thread-indent-level-internal 1)))
1060         parent)
1061     (when (wl-thread-entity-get-number
1062            (setq parent (wl-thread-entity-get-parent-entity cur)))
1063       (if (wl-thread-entity-get-younger-brothers cur)
1064           (setq ret-val wl-thread-have-younger-brother-str-internal)
1065         (setq ret-val wl-thread-youngest-child-str-internal))
1066       (setq ret-val (concat ret-val
1067                             (wl-repeat-string
1068                              wl-thread-horizontal-str-internal
1069                              (- wl-thread-indent-level-internal 1))))
1070       (setq cur parent)
1071       (while (wl-thread-entity-get-number
1072               (wl-thread-entity-get-parent-entity cur))
1073         (if (wl-thread-entity-get-younger-brothers cur)
1074             (setq ret-val (concat wl-thread-vertical-str-internal
1075                                   space-str
1076                                   ret-val))
1077           (setq ret-val (concat wl-thread-space-str-internal
1078                                 space-str
1079                                 ret-val)))
1080         (setq cur (wl-thread-entity-get-parent-entity cur))))
1081     ret-val))
1082
1083 (defun wl-thread-set-parent (&optional parent-number)
1084   "Set current message's parent interactively."
1085   (interactive)
1086   (let ((number (wl-summary-message-number))
1087         (dst-parent (if (interactive-p)
1088                         (read-from-minibuffer "Parent Message (No.): ")))
1089         entity dst-parent-entity src-parent children
1090         update-msgs
1091         buffer-read-only)
1092     (if (string= dst-parent "")
1093         (setq dst-parent nil)
1094       (if (interactive-p)
1095           (setq dst-parent (string-to-number dst-parent))
1096         (setq dst-parent parent-number)))
1097     (if (and dst-parent
1098              (memq dst-parent (wl-thread-get-children-msgs number)))
1099         (error "Parent is children or myself"))
1100     (setq entity (wl-thread-get-entity number))
1101     (when (and number entity)
1102       ;; delete thread
1103       (setq update-msgs (wl-thread-delete-message number 'deep))
1104       ;; insert as child at new parent
1105       (setq dst-parent-entity (wl-thread-get-entity dst-parent))
1106       (if dst-parent-entity
1107           (progn
1108             (if (setq children
1109                       (wl-thread-entity-get-children dst-parent-entity))
1110                 (wl-append update-msgs
1111                            (wl-thread-get-children-msgs
1112                             (car (last children)) t)))
1113             (wl-thread-entity-set-children
1114              dst-parent-entity
1115              (append children (list number)))
1116             (wl-thread-entity-set-linked
1117              entity
1118              (let ((parent (elmo-message-entity-parent
1119                             wl-summary-buffer-elmo-folder
1120                             (elmo-message-entity
1121                              wl-summary-buffer-elmo-folder
1122                              number))))
1123                (or (null parent)
1124                    (/= parent-number (elmo-message-entity-number parent))))))
1125         ;; insert as top
1126         (wl-append wl-thread-entity-list (list number))
1127         (wl-thread-entity-set-linked entity nil))
1128
1129       ;; update my thread
1130       (wl-append update-msgs (wl-thread-get-children-msgs number t))
1131       (setq update-msgs (elmo-uniq-list update-msgs))
1132       (wl-thread-entity-set-parent entity dst-parent)
1133       ;; update thread on buffer
1134       (wl-thread-make-number-list)
1135       (wl-thread-update-line-msgs update-msgs))))
1136
1137 (require 'product)
1138 (product-provide (provide 'wl-thread) (require 'wl-version))
1139
1140 ;;; wl-thread.el ends here