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