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                                 (lambda (message)
 492                                   (wl-thread-get-children-msgs message t))
 493                                 children))))
 494                 (wl-thread-entity-set-children
 495                  parent (append older-brothers children younger-brothers))
 496                 ;; If chidren and younger-brothers do not exist,
 497                 ;; update nearly older brother.
 498                 (when (and older-brothers
 499                            (not younger-brothers)
 500                            (not children))
 501                   (wl-append
 502                    update-msgs
 503                    (wl-thread-get-children-msgs (car (last older-brothers))))))
 504             ;; top...oldest child becomes top.
 505             (unless deep
 506               (let ((children (wl-thread-entity-get-children entity)))
 507                 (when children
 508                   (setq top-child (car children)
 509                         children (cdr children))
 510                   (setq top-entity (wl-thread-get-entity top-child))
 511                   (wl-thread-entity-set-parent top-entity nil)
 512                   (wl-thread-entity-set-linked top-entity nil)
 513                   (wl-append update-msgs
 514                              (wl-thread-get-children-msgs top-child t)))
 515                 (when children
 516                   (wl-thread-entity-set-children
 517                    top-entity
 518                    (append
 519                     (wl-thread-entity-get-children top-entity)
 520                     children))
 521                   (wl-thread-reparent-children children top-child)
 522                   (wl-append update-msgs children))))
 523             ;; delete myself from top list.
 524             (let ((match (memq msg wl-thread-entity-list)))
 525               (when match
 526                 (if top-child
 527                     (setcar match top-child)
 528                   (setq wl-thread-entity-list
 529                         (delq msg wl-thread-entity-list))))))))
 530       ;;
 531       (if deep
 532           ;; delete thread on buffer
 533           (when (wl-summary-jump-to-msg msg)
 534             (let ((beg (point)))
 535               (wl-thread-goto-bottom-of-sub-thread)
 536               (delete-region beg (point))))
 537         ;; delete myself from buffer.
 538         (unless (wl-thread-delete-line-from-buffer msg)
 539           ;; jump to suitable point.
 540           ;; just upon the oldest younger-brother of my top.
 541           (setq invisible-top
 542                 (car (wl-thread-entity-parent-invisible-p entity)))
 543           (if invisible-top
 544               (progn
 545                 (wl-append update-msgs (list invisible-top))
 546                 (wl-summary-jump-to-msg invisible-top))
 547             (goto-char (point-max))))
 548
 549         ;; insert children if thread is closed or delete top.
 550         (when (or top-child
 551                   (not (wl-thread-entity-get-opened entity)))
 552           (let (next-top insert-msgs ent grandchildren)
 553             (if top-child
 554                 (progn
 555                   (setq insert-msgs (wl-thread-get-exist-children
 556                                      top-child 'include-self))
 557                   (setq next-top (car insert-msgs))
 558                   (setq ent (wl-thread-get-entity next-top))
 559                   (when (and
 560                          (wl-thread-entity-get-opened entity) ;; open
 561                          (not (wl-thread-entity-get-opened ent)) ;; close
 562                          (setq grandchildren
 563                                (wl-thread-entity-get-children ent))
 564                          (wl-summary-jump-to-msg next-top))
 565                     (forward-line 1)
 566                     (setq insert-msgs (append (cdr insert-msgs) grandchildren)))
 567                   (when top-entity (wl-thread-entity-set-opened top-entity t))
 568                   (when ent (wl-thread-entity-set-opened ent t)))
 569               (when (not invisible-top)
 570                 (setq insert-msgs (wl-thread-get-exist-children msg))
 571                 ;; First msg always opened, because first msg maybe becomes top.
 572                 (if (setq ent (wl-thread-get-entity (car insert-msgs)))
 573                     (wl-thread-entity-set-opened ent t))))
 574             ;; insert children
 575             (while insert-msgs
 576               ;; if no exists in summary, insert entity.
 577               (when (and (car insert-msgs)
 578                          (not (wl-summary-jump-to-msg (car insert-msgs))))
 579                 (setq ent (wl-thread-get-entity (car insert-msgs)))
 580                 (wl-thread-insert-entity 0 ; no mean now...
 581                                          ent entity nil))
 582               (setq insert-msgs (cdr insert-msgs))))))
 583       (if update
 584           ;; modify buffer.
 585           (while update-msgs
 586             (wl-thread-update-line-on-buffer-sub nil (pop update-msgs)))
 587         ;; don't update buffer
 588         update-msgs)))) ; return value
 589
 590 (defun wl-thread-insert-message (message-entity
 591                                  msg parent-msg &optional update linked)
 592   "Insert MSG to the entity.
 593 When optional argument UPDATE is non-nil,
 594 Message is inserted to the summary buffer."
 595   (let ((parent (wl-thread-get-entity parent-msg))
 596         child-entity invisible-top)
 597 ;;; Update the thread view...not implemented yet.
 598 ;;;  (when force-insert
 599 ;;;    (if parent
 600 ;;;       (wl-thread-entity-force-open parent))
 601     (when (and wl-summary-max-thread-depth parent)
 602       (let ((cur parent)
 603             (depth 0))
 604         (while cur
 605           (incf depth)
 606           (setq cur (wl-thread-entity-get-parent-entity cur)))
 607         (when (> depth wl-summary-max-thread-depth)
 608           (setq parent nil
 609                 parent-msg nil))))
 610     (if parent
 611         ;; insert as children.
 612         (wl-thread-entity-insert-as-children
 613          parent
 614          (setq child-entity
 615                (wl-thread-create-entity
 616                 msg (wl-thread-entity-get-number parent) nil linked)))
 617       ;; insert as top message.
 618       (wl-thread-entity-insert-as-top
 619        (wl-thread-create-entity msg nil)))
 620     (if update
 621         (if (not (setq invisible-top
 622                        (wl-thread-entity-parent-invisible-p child-entity)))
 623             ;; visible.
 624             (progn
 625               (wl-summary-update-thread
 626                message-entity
 627                child-entity
 628                (elmo-message-entity wl-summary-buffer-elmo-folder
 629                                     parent-msg))
 630               (when parent
 631                 ;; use thread structure.
 632                 ;;(wl-thread-entity-get-nearly-older-brother
 633                 ;; child-entity parent))) ; return value
 634                 (wl-thread-entity-get-number parent))) ; return value
 635 ;;;           (setq beg (point))
 636 ;;;           (wl-thread-goto-bottom-of-sub-thread)
 637 ;;;           (wl-thread-update-indent-string-region beg (point)))
 638           ;; currently invisible.. update closed line.
 639           (wl-thread-update-children-number invisible-top)
 640           nil))))
 641
 642 ;(defun wl-thread-get-parent-list (msgs)
 643 ;  ;; return ancestors
 644 ;  (let* ((msgs2 msgs)
 645 ;        myself)
 646 ;    (while msgs2
 647 ;      (setq myself (car msgs2)
 648 ;           msgs2 (cdr msgs2))
 649 ;      (while (not (eq myself (car msgs2)))
 650 ;       (if (wl-thread-descendant-p myself (car msgs2))
 651 ;           (setq msgs (delq (car msgs2) msgs)))
 652 ;       (setq msgs2 (or (cdr msgs2) msgs)))
 653 ;      (setq msgs2 (cdr msgs2)))
 654 ;    msgs))
 655
 656 (defun wl-thread-get-parent-list (msgs)
 657   ;; return connected ancestors
 658   (let ((ptr msgs)
 659         parent ret)
 660     (while (car ptr)
 661       (setq parent (wl-thread-entity-get-parent (wl-thread-get-entity (car ptr))))
 662       (when (or (not parent)
 663                 (not (memq parent msgs)))
 664         (setq ret (append ret (list (car ptr)))))
 665       (setq ptr (cdr ptr)))
 666     ret))
 667
 668 (defun wl-thread-update-indent-string-thread (top-list)
 669   (let ((top-list (wl-thread-get-parent-list top-list))
 670         beg)
 671     (elmo-with-progress-display
 672         (wl-thread-update-indent-string-thread (length top-list))
 673         "Updating thread indent"
 674       (while top-list
 675         (when (car top-list)
 676           (wl-summary-jump-to-msg (car top-list))
 677           (setq beg (point))
 678           (wl-thread-goto-bottom-of-sub-thread)
 679           (wl-thread-update-indent-string-region beg (point)))
 680         (elmo-progress-notify 'wl-thread-update-indent-string-thread)
 681         (setq top-list (cdr top-list))))))
 682
 683 (defun wl-thread-update-children-number (entity)
 684   "Update the children number."
 685   (wl-thread-update-line-on-buffer (wl-thread-entity-get-number entity)))
 686
 687 ;;
 688 ;; Thread oriented commands.
 689 ;;
 690 (defun wl-thread-call-region-func (func &optional arg)
 691   (save-excursion
 692     (if arg
 693         (wl-summary-goto-top-of-current-thread)
 694       (beginning-of-line))
 695     (let ((beg (point)))
 696       (wl-thread-goto-bottom-of-sub-thread)
 697       (funcall func beg (point)))))
 698
 699 (defun wl-thread-prefetch (&optional arg)
 700   (interactive "P")
 701   (wl-thread-call-region-func 'wl-summary-prefetch-region arg))
 702
 703 (defun wl-thread-mark-as-read (&optional arg)
 704   (interactive "P")
 705   (wl-thread-call-region-func 'wl-summary-mark-as-read-region arg))
 706
 707 (defun wl-thread-mark-as-unread (&optional arg)
 708   (interactive "P")
 709   (wl-thread-call-region-func 'wl-summary-mark-as-unread-region arg))
 710
 711 (defun wl-thread-mark-as-important (&optional arg)
 712   (interactive "P")
 713   (wl-thread-call-region-func 'wl-summary-mark-as-important-region arg))
 714
 715 (defun wl-thread-set-flags (&optional arg)
 716   (interactive "P")
 717   (wl-thread-call-region-func 'wl-summary-set-flags-region arg))
 718
 719 (defun wl-thread-mark-as-answered (&optional arg)
 720   (interactive "P")
 721   (wl-thread-call-region-func 'wl-summary-mark-as-answered-region arg))
 722
 723 (defun wl-thread-recover-messages (&optional arg)
 724   "Recover killed messages which are contained current thread."
 725   (interactive "P")
 726   (wl-thread-call-region-func 'wl-summary-recover-messages-region arg))
 727
 728 (defun wl-thread-unmark (&optional arg)
 729   (interactive "P")
 730   (wl-thread-call-region-func 'wl-summary-unmark-region arg))
 731
 732 (defun wl-thread-exec (&optional arg)
 733   (interactive "P")
 734   (wl-thread-call-region-func 'wl-summary-exec-region arg))
 735
 736 (defun wl-thread-save (&optional arg)
 737   (interactive "P")
 738   (wl-thread-call-region-func 'wl-summary-save-region arg))
 739
 740 (defun wl-thread-force-open (&optional msg-num)
 741   "force open current folder"
 742   (when msg-num
 743     (wl-summary-jump-to-msg msg-num))
 744   (wl-thread-open-close 'force-open))
 745
 746 (defun wl-thread-entity-force-open (entity)
 747   (let ((wl-thread-insert-force-opened t)
 748         notopen)
 749     (if (null (wl-thread-entity-get-parent entity))
 750         ;; top!!
 751         (if (and (not (wl-thread-entity-get-opened entity))
 752                  (wl-thread-entity-get-children entity))
 753             (wl-thread-force-open (wl-thread-entity-get-number entity)))
 754       (if (setq notopen (wl-thread-entity-parent-invisible-p entity))
 755           (wl-thread-force-open (wl-thread-entity-get-number notopen))))))
 756
 757 (defun wl-thread-insert-top ()
 758   (let ((elist wl-thread-entity-list)
 759         (len (length wl-thread-entity-list)))
 760     (elmo-with-progress-display
 761         (wl-thread-insert-entity (length wl-thread-entity-list))
 762         "Inserting message"
 763       (wl-delete-all-overlays)
 764       (while elist
 765         (wl-thread-insert-entity
 766          0
 767          (wl-thread-get-entity (car elist))
 768          nil
 769          len)
 770         (elmo-progress-notify 'wl-thread-insert-entity)
 771         (setq elist (cdr elist))))))
 772
 773 (defsubst wl-thread-insert-entity-sub (indent entity parent-entity all)
 774   (let (msg-num
 775         message-entity
 776         temp-mark
 777         summary-line)
 778     (when (setq msg-num (wl-thread-entity-get-number entity))
 779       (unless all ; all...means no temp-mark.
 780         (cond ((memq msg-num wl-summary-buffer-target-mark-list)
 781                (setq temp-mark "*"))
 782               ((setq temp-mark (wl-summary-registered-temp-mark msg-num))
 783                (setq temp-mark (nth 1 temp-mark)))))
 784       (unless temp-mark
 785         (setq temp-mark (wl-summary-get-score-mark msg-num)))
 786       (setq message-entity
 787             (elmo-message-entity wl-summary-buffer-elmo-folder
 788                                  msg-num))
 789 ;;;   (wl-delete-all-overlays)
 790       (when message-entity
 791         (wl-summary-insert-line
 792          (wl-summary-create-line
 793           message-entity
 794           (elmo-message-entity wl-summary-buffer-elmo-folder
 795                                (wl-thread-entity-get-number parent-entity))
 796           temp-mark
 797           (elmo-message-status wl-summary-buffer-elmo-folder msg-num)
 798           (if wl-thread-insert-force-opened
 799               nil
 800             (wl-thread-maybe-get-children-num msg-num))
 801           (wl-thread-make-indent-string entity)
 802           (wl-thread-entity-get-linked entity)))))))
 803
 804 (defun wl-thread-insert-entity (indent entity parent-entity all)
 805   "Insert thread entity in current buffer."
 806   (let ((msgs (list (car entity)))
 807         children msgs-stack)
 808     (while msgs
 809       (wl-thread-insert-entity-sub indent entity parent-entity all)
 810       (setq msgs (cdr msgs))
 811       (setq children (wl-thread-entity-get-children entity))
 812       (if children
 813           ;; insert children
 814           (when (or wl-thread-insert-force-opened
 815                     (wl-thread-entity-get-opened entity))
 816             (wl-thread-entity-set-opened entity t)
 817             (wl-push msgs msgs-stack)
 818             (setq msgs children
 819                   indent (1+ indent)
 820                   parent-entity entity)))
 821       (unless msgs
 822         (while (and (null msgs) msgs-stack)
 823           (setq msgs (wl-pop msgs-stack))
 824           (setq indent (1- indent)))
 825         (when msgs
 826           (setq entity (wl-thread-get-entity (car msgs)))
 827           (setq parent-entity (wl-thread-entity-get-parent-entity entity))))
 828       (setq entity (wl-thread-get-entity (car msgs))))))
 829
 830 (defun wl-thread-descendant-p (mynumber number)
 831   (let ((cur (wl-thread-get-entity number))
 832         num)
 833     (catch 'done
 834       (while cur
 835         (setq cur (wl-thread-entity-get-parent-entity cur))
 836         (if (null (setq num (wl-thread-entity-get-number cur))) ; top!
 837             (throw 'done nil))
 838         (if (and num
 839                  (eq mynumber (wl-thread-entity-get-number cur)))
 840             (throw 'done t)))
 841       nil)))
 842
 843 ;; (defun wl-thread-goto-bottom-of-sub-thread ()
 844 ;;   (interactive)
 845 ;;   (let ((depth (wl-thread-get-depth-of-current-line)))
 846 ;;     (forward-line 1)
 847 ;;     (while (and (not (eobp))
 848 ;;              (> (wl-thread-get-depth-of-current-line)
 849 ;;                 depth))
 850 ;;       (forward-line 1))
 851 ;;     (beginning-of-line)))
 852
 853 (defun wl-thread-goto-bottom-of-sub-thread (&optional msg)
 854   (interactive)
 855   (let ((mynumber (or msg (wl-summary-message-number))))
 856     (forward-line 1)
 857     (while (wl-thread-descendant-p mynumber (wl-summary-message-number))
 858       (forward-line 1))
 859     (beginning-of-line)))
 860
 861 (defun wl-thread-remove-argument-region (beg end)
 862   (save-excursion
 863     (save-restriction
 864       (narrow-to-region beg end)
 865       (goto-char (point-min))
 866       (while (not (eobp))
 867         (wl-summary-remove-argument)
 868         (forward-line 1)))))
 869
 870 (defun wl-thread-print-argument-region (beg end)
 871   (if wl-summary-buffer-temp-mark-list
 872       (save-excursion
 873         (save-restriction
 874           (narrow-to-region beg end)
 875           (goto-char (point-min))
 876           (while (not (eobp))
 877             (let ((num (wl-summary-message-number))
 878                   temp-mark pair)
 879               (when (and (setq temp-mark
 880                                (wl-summary-registered-temp-mark num))
 881                          (nth 2 temp-mark)
 882                          (setq pair (cons (nth 0 temp-mark)(nth 2 temp-mark))))
 883                 (wl-summary-print-argument (car pair) (cdr pair))))
 884             (forward-line 1))))))
 885
 886 (defsubst wl-thread-get-children-msgs (msg &optional visible-only)
 887   (let ((msgs (list msg))
 888         msgs-stack children
 889         entity ret-val)
 890     (while msgs
 891       (wl-append ret-val (list (car msgs)))
 892       (setq children (wl-thread-entity-get-children
 893                       (setq entity (wl-thread-get-entity (car msgs)))))
 894       (if (and visible-only
 895                (not (wl-thread-entity-get-opened entity)))
 896           (setq children nil))
 897       (setq msgs (cdr msgs))
 898       (if (null children)
 899           (while (and (null msgs) msgs-stack)
 900             (setq msgs (wl-pop msgs-stack)))
 901         (wl-push msgs msgs-stack)
 902         (setq msgs children)))
 903     ret-val))
 904
 905 (defun wl-thread-get-children-msgs-uncached (msg &optional uncached-marks)
 906   (let ((children-msgs (wl-thread-get-children-msgs msg))
 907         mark uncached-list)
 908     (while children-msgs
 909       (if (and (not (eq msg (car children-msgs))) ; except itself
 910                (or (and uncached-marks
 911                         (setq mark (wl-summary-message-mark
 912                                     wl-summary-buffer-elmo-folder
 913                                     (car children-msgs)))
 914                         (member mark uncached-marks))
 915                    (and (not uncached-marks)
 916                         (null (elmo-file-cache-exists-p
 917                                (elmo-message-field
 918                                 wl-summary-buffer-elmo-folder
 919                                 (car children-msgs)
 920                                 'message-id))))))
 921           (wl-append uncached-list (list (car children-msgs))))
 922       (setq children-msgs (cdr children-msgs)))
 923     uncached-list))
 924
 925 (defun wl-thread-get-children-msgs-with-mark (msg mark)
 926   (let ((children-msgs (wl-thread-get-children-msgs msg))
 927         (check-func (cond ((string= mark "o")
 928                            'wl-summary-msg-marked-as-refiled)
 929                           ((string= mark "O")
 930                            'wl-summary-msg-marked-as-copied)
 931                           ((string= mark "D")
 932                            'wl-summary-msg-marked-as-deleted)
 933                           ((string= mark "*")
 934                            'wl-summary-msg-marked-as-target)))
 935         ret-val)
 936     (while children-msgs
 937       (if (funcall check-func (car children-msgs))
 938           (wl-append ret-val (list (car children-msgs))))
 939       (setq children-msgs (cdr children-msgs)))
 940     ret-val))
 941
 942 (defun wl-thread-close (entity)
 943   (let (depth beg)
 944     (wl-thread-entity-set-opened entity nil)
 945     (setq depth (wl-thread-get-depth-of-current-line))
 946     (setq beg (point-at-bol))
 947     (wl-thread-goto-bottom-of-sub-thread)
 948     (wl-thread-remove-argument-region beg
 949                                       (point))
 950     (forward-char -1)   ;; needed for mouse-face.
 951     (delete-region beg (point))
 952     (wl-thread-insert-entity (- depth 1)
 953                              entity
 954                              (wl-thread-get-entity
 955                               (wl-thread-entity-get-parent entity))
 956                              nil)
 957     (delete-char 1) ; delete '\n'
 958     (wl-thread-print-argument-region beg (point))))
 959
 960 (defun wl-thread-close-children (&optional number)
 961   (interactive)
 962   (when (eq wl-summary-buffer-view 'thread)
 963     (setq number (or number (wl-summary-message-number)))
 964     (save-excursion
 965       (let ((inhibit-read-only t)
 966             (entity (wl-thread-get-entity number)))
 967         (when (wl-thread-entity-get-opened entity)
 968           (wl-thread-close entity))))))
 969
 970 (defun wl-thread-open (entity)
 971   (let (depth beg)
 972     (setq beg (point-at-bol))
 973     (setq depth (wl-thread-get-depth-of-current-line))
 974     (delete-region (point-at-bol) (point-at-eol))
 975     (wl-thread-entity-set-opened entity t)
 976     (wl-thread-insert-entity depth ;(- depth 1)
 977                              entity
 978                              (wl-thread-get-entity
 979                               (wl-thread-entity-get-parent entity))
 980                              nil)
 981     (delete-char 1) ; delete '\n'
 982     (wl-thread-print-argument-region beg (point))))
 983
 984 (defun wl-thread-open-children (&optional number)
 985   (interactive)
 986   (when (eq wl-summary-buffer-view 'thread)
 987     (setq number (or number (wl-summary-message-number)))
 988     (save-excursion
 989       (let ((inhibit-read-only t)
 990             (entity (wl-thread-get-entity number)))
 991         (unless (wl-thread-entity-get-opened entity)
 992           (wl-thread-open entity))))))
 993
 994 (defun wl-thread-open-close (&optional force-open)
 995   (interactive "P")
 996   (when (eq wl-summary-buffer-view 'thread)
 997 ;;; (if (equal wl-thread-top-entity '(nil t nil nil))
 998 ;;;     (error "There's no thread structure"))
 999     (save-excursion
1000       (let ((inhibit-read-only t)
1001             (buffer-read-only nil)
1002             (wl-thread-insert-force-opened
1003              (or wl-thread-insert-force-opened
1004                  force-open))
1005             msg entity parent)
1006         (setq msg (wl-summary-message-number))
1007         (setq entity (wl-thread-get-entity msg))
1008         (if (wl-thread-entity-get-opened entity)
1009             ;; if already opened, close its child!
1010           (if (wl-thread-entity-get-children entity)
1011               (wl-thread-close entity)
1012             ;; opened, but has no children, close its parent!
1013             (when (setq parent (wl-thread-entity-get-parent entity))
1014               (wl-summary-jump-to-msg parent)
1015               (wl-thread-close
1016                (wl-thread-get-entity (wl-summary-message-number)))))
1017           ;; if closed (or it is just a thread bottom message)
1018           ;; has children, open it!
1019           (if (wl-thread-entity-get-children entity)
1020               (wl-thread-open entity)
1021             ;; closed, and has no children, close its parent!
1022             (setq msg (or (wl-thread-entity-get-parent entity)
1023                           (wl-thread-entity-get-number entity)))
1024             (when msg
1025               (wl-summary-jump-to-msg msg)
1026               (wl-thread-close
1027                (wl-thread-get-entity (wl-summary-message-number)))))))
1028       (when wl-summary-lazy-highlight
1029         (wl-highlight-summary-window))
1030       (wl-summary-set-message-modified)
1031       (set-buffer-modified-p nil))))
1032
1033 (defun wl-thread-get-depth-of-current-line ()
1034   (let ((entity (wl-thread-get-entity (wl-summary-message-number)))
1035         (depth 0)
1036         number)
1037     (while (setq number (wl-thread-entity-get-parent entity))
1038       (incf depth)
1039       (setq entity (wl-thread-get-entity number)))
1040     depth))
1041
1042 (defun wl-thread-update-indent-string-region (beg end)
1043   (interactive "r")
1044   (save-excursion
1045     (goto-char beg)
1046     (while (< (point) end)
1047       (save-excursion
1048         (wl-thread-update-line-on-buffer-sub nil (wl-summary-message-number)))
1049       (forward-line 1))))
1050
1051 (defsubst wl-thread-make-indent-string (entity)
1052   (let ((cur entity)
1053         (ret-val "")
1054         (space-str (wl-repeat-string wl-thread-space-str-internal
1055                                      (- wl-thread-indent-level-internal 1)))
1056         parent)
1057     (when (wl-thread-entity-get-number
1058            (setq parent (wl-thread-entity-get-parent-entity cur)))
1059       (if (wl-thread-entity-get-younger-brothers cur)
1060           (setq ret-val wl-thread-have-younger-brother-str-internal)
1061         (setq ret-val wl-thread-youngest-child-str-internal))
1062       (setq ret-val (concat ret-val
1063                             (wl-repeat-string
1064                              wl-thread-horizontal-str-internal
1065                              (- wl-thread-indent-level-internal 1))))
1066       (setq cur parent)
1067       (while (wl-thread-entity-get-number
1068               (wl-thread-entity-get-parent-entity cur))
1069         (if (wl-thread-entity-get-younger-brothers cur)
1070             (setq ret-val (concat wl-thread-vertical-str-internal
1071                                   space-str
1072                                   ret-val))
1073           (setq ret-val (concat wl-thread-space-str-internal
1074                                 space-str
1075                                 ret-val)))
1076         (setq cur (wl-thread-entity-get-parent-entity cur))))
1077     ret-val))
1078
1079 (defun wl-thread-set-parent (&optional parent-number)
1080   "Set current message's parent interactively."
1081   (interactive)
1082   (let ((number (wl-summary-message-number))
1083         (dst-parent (if (interactive-p)
1084                         (read-from-minibuffer "Parent Message (No.): ")))
1085         entity dst-parent-entity src-parent children
1086         update-msgs
1087         buffer-read-only)
1088     (if (string= dst-parent "")
1089         (setq dst-parent nil)
1090       (if (interactive-p)
1091           (setq dst-parent (string-to-number dst-parent))
1092         (setq dst-parent parent-number)))
1093     (if (and dst-parent
1094              (memq dst-parent (wl-thread-get-children-msgs number)))
1095         (error "Parent is children or myself"))
1096     (setq entity (wl-thread-get-entity number))
1097     (when (and number entity)
1098       ;; delete thread
1099       (setq update-msgs (wl-thread-delete-message number 'deep))
1100       ;; insert as child at new parent
1101       (setq dst-parent-entity (wl-thread-get-entity dst-parent))
1102       (if dst-parent-entity
1103           (progn
1104             (if (setq children
1105                       (wl-thread-entity-get-children dst-parent-entity))
1106                 (wl-append update-msgs
1107                            (wl-thread-get-children-msgs
1108                             (car (last children)) t)))
1109             (wl-thread-entity-set-children
1110              dst-parent-entity
1111              (append children (list number)))
1112             (wl-thread-entity-set-linked
1113              entity
1114              (let ((parent (elmo-message-entity-parent
1115                             wl-summary-buffer-elmo-folder
1116                             (elmo-message-entity
1117                              wl-summary-buffer-elmo-folder
1118                              number))))
1119                (or (null parent)
1120                    (/= parent-number (elmo-message-entity-number parent))))))
1121         ;; insert as top
1122         (wl-append wl-thread-entity-list (list number))
1123         (wl-thread-entity-set-linked entity nil))
1124
1125       ;; update my thread
1126       (wl-append update-msgs (wl-thread-get-children-msgs number t))
1127       (setq update-msgs (elmo-uniq-list update-msgs))
1128       (wl-thread-entity-set-parent entity dst-parent)
1129       ;; update thread on buffer
1130       (wl-thread-make-number-list)
1131       (wl-thread-update-line-msgs update-msgs))))
1132
1133 (require 'product)
1134 (product-provide (provide 'wl-thread) (require 'wl-version))
1135
1136 ;;; wl-thread.el ends here