wl/wl.el

   1 ;;; wl.el --- Wanderlust bootstrap.
   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 'elmo)
  35 (require 'wl-version)                   ; reduce recursive-load-depth
  36
  37 ;; from x-face.el
  38 (unless (and (fboundp 'defgroup)
  39              (fboundp 'defcustom))
  40   (require 'backquote)
  41   (defmacro defgroup (&rest args))
  42   (defmacro defcustom (symbol value &optional doc &rest args)
  43     (let ((doc (concat "*" (or doc ""))))
  44       (` (defvar (, symbol) (, value) (, doc))))))
  45
  46 (require 'wl-vars)
  47 (require 'wl-util)
  48
  49 (cond (wl-on-xemacs
  50        (require 'wl-xmas))
  51       (wl-on-emacs21
  52        (require 'wl-e21))
  53       (t
  54        (require 'wl-mule)))
  55
  56 (provide 'wl)                           ; circular dependency
  57 (require 'wl-folder)
  58 (require 'wl-summary)
  59 (require 'wl-thread)
  60 (require 'wl-address)
  61 (require 'wl-news)
  62
  63 (wl-draft-mode-setup)
  64 (require 'wl-draft)
  65 (wl-draft-key-setup)
  66
  67 (require 'wl-demo)
  68 (require 'wl-highlight)
  69
  70 (eval-when-compile
  71   (require 'cl)
  72   (require 'smtp)
  73   (require 'wl-score)
  74   (require 'wl-fldmgr)
  75   (require 'wl-mime))
  76
  77 (defun wl-plugged-init (&optional make-alist)
  78   (setq elmo-plugged wl-plugged)
  79   (if wl-reset-plugged-alist
  80       (elmo-set-plugged elmo-plugged))
  81   (when make-alist
  82     (wl-make-plugged-alist))
  83   ;; Plug status.
  84   (setq elmo-plugged (setq wl-plugged (elmo-plugged-p))
  85         wl-modeline-plug-status wl-plugged)
  86   (if wl-plugged
  87       (wl-toggle-plugged t 'flush)))
  88
  89 (defun wl-toggle-plugged (&optional arg queue-flush-only)
  90   (interactive)
  91   (elmo-quit) ; Disconnect current connection.
  92   (unless queue-flush-only
  93     (cond
  94      ((eq arg 'on)
  95       (setq wl-plugged t))
  96      ((eq arg 'off)
  97       (setq wl-plugged nil))
  98      (t (setq wl-plugged (not wl-plugged))))
  99     (elmo-set-plugged wl-plugged))
 100   (setq elmo-plugged wl-plugged
 101         wl-modeline-plug-status wl-plugged)
 102   (save-excursion
 103     (let ((summaries (wl-collect-summary)))
 104       (while summaries
 105         (set-buffer (pop summaries))
 106         (wl-summary-save-view)
 107         (elmo-folder-commit wl-summary-buffer-elmo-folder))))
 108   (setq wl-biff-check-folders-running nil)
 109   (if wl-plugged
 110       (progn
 111         ;; flush queue!!
 112         (elmo-dop-queue-flush)
 113         (unless queue-flush-only (wl-biff-start))
 114         (if (and wl-draft-enable-queuing
 115                  wl-auto-flush-queue)
 116             (wl-draft-queue-flush))
 117 ;;      (when (and (eq major-mode 'wl-summary-mode)
 118 ;;                 (elmo-folder-plugged-p wl-summary-buffer-elmo-folder))
 119 ;;        (let* ((msgdb-dir (elmo-folder-msgdb-path
 120 ;;                           wl-summary-buffer-elmo-folder))
 121 ;;               (seen-list (elmo-msgdb-seen-load msgdb-dir)))
 122 ;;       (setq seen-list
 123 ;;                (wl-summary-flush-pending-append-operations seen-list))
 124 ;;          (elmo-msgdb-seen-save msgdb-dir seen-list)))
 125         (run-hooks 'wl-plugged-hook))
 126     (wl-biff-stop)
 127     (run-hooks 'wl-unplugged-hook))
 128   (force-mode-line-update t))
 129
 130 ;;; wl-plugged-mode
 131
 132 (defvar wl-plugged-port-label-alist
 133   (list (cons 119 "nntp")
 134         (cons 143 "imap4")
 135         (cons 110 "pop3")))
 136         ;;(cons elmo-pop-before-smtp-port "pop3")
 137
 138 (defconst wl-plugged-switch-variables
 139   '(("Queuing" . wl-draft-enable-queuing)
 140     ("AutoFlushQueue" . wl-auto-flush-queue)
 141     ("DisconnectedOperation" . elmo-enable-disconnected-operation)))
 142
 143 (defvar wl-plugged-buf-name "Plugged")
 144 (defvar wl-plugged-mode-map nil)
 145 (defvar wl-plugged-alist nil)
 146 (defvar wl-plugged-switch nil)
 147 (defvar wl-plugged-winconf nil)
 148 (defvar wl-plugged-sending-queue-alist nil)
 149 (defvar wl-plugged-dop-queue-alist nil)
 150 (defvar wl-plugged-alist-modified nil)
 151
 152 (defvar wl-plugged-mode-menu-spec
 153   '("Plugged"
 154     ["Toggle plugged" wl-plugged-toggle t]
 155     ["Toggle All plugged" wl-plugged-toggle-all t]
 156     ["Prev Port"      wl-plugged-move-to-previous t]
 157     ["Next Port"      wl-plugged-move-to-next t]
 158     ["Prev Server"    wl-plugged-move-to-previous-server t]
 159     ["Next Server"    wl-plugged-move-to-next-server t]
 160     ["Flush queue"    wl-plugged-flush-queue t]
 161     "----"
 162     ["Exit"           wl-plugged-exit t]))
 163
 164 (eval-and-compile
 165   (if wl-on-xemacs
 166       (defun wl-plugged-setup-mouse ()
 167         (define-key wl-plugged-mode-map 'button2 'wl-plugged-click))
 168     (defun wl-plugged-setup-mouse ()
 169       (define-key wl-plugged-mode-map [mouse-2] 'wl-plugged-click))))
 170
 171 (unless wl-plugged-mode-map
 172   (setq wl-plugged-mode-map (make-sparse-keymap))
 173   (define-key wl-plugged-mode-map " "    'wl-plugged-toggle)
 174   (define-key wl-plugged-mode-map "\C-m" 'wl-plugged-toggle)
 175   (define-key wl-plugged-mode-map "\M-t" 'wl-plugged-toggle-all)
 176   (define-key wl-plugged-mode-map "q"    'wl-plugged-exit)
 177   (define-key wl-plugged-mode-map "\C-t" 'wl-plugged-exit)
 178   (define-key wl-plugged-mode-map "F"    'wl-plugged-flush-queue)
 179   (define-key wl-plugged-mode-map "P"    'wl-plugged-move-to-previous-server)
 180   (define-key wl-plugged-mode-map "N"    'wl-plugged-move-to-next-server)
 181   (define-key wl-plugged-mode-map "p"    'wl-plugged-move-to-previous)
 182   (define-key wl-plugged-mode-map "n"    'wl-plugged-move-to-next)
 183   (define-key wl-plugged-mode-map "\e\t" 'wl-plugged-move-to-previous)
 184   (define-key wl-plugged-mode-map "\t"   'wl-plugged-move-to-next)
 185   (wl-plugged-setup-mouse)
 186   (easy-menu-define
 187    wl-plugged-mode-menu
 188    wl-plugged-mode-map
 189    "Menu used in Plugged mode."
 190    wl-plugged-mode-menu-spec))
 191
 192 (defun wl-plugged-mode ()
 193   "Mode for setting Wanderlust plugged.
 194 See info under Wanderlust for full documentation.
 195
 196 Special commands:
 197 \\{wl-plugged-mode-map}
 198
 199 Entering Plugged mode calls the value of `wl-plugged-mode-hook'."
 200   (interactive)
 201   (kill-all-local-variables)
 202   (use-local-map wl-plugged-mode-map)
 203   (setq major-mode 'wl-plugged-mode)
 204   (setq mode-name "Plugged")
 205   (easy-menu-add wl-plugged-mode-menu)
 206   (wl-mode-line-buffer-identification)
 207   (setq wl-plugged-switch wl-plugged)
 208   (setq wl-plugged-alist-modified nil)
 209   (setq buffer-read-only t)
 210   (run-hooks 'wl-plugged-mode-hook))
 211
 212 (defmacro wl-plugged-string (plugged &optional time)
 213   (` (if (, time) wl-plugged-auto-off
 214        (if (, plugged) wl-plugged-plug-on wl-plugged-plug-off))))
 215
 216 (defmacro wl-plugged-server-indent ()
 217   (` (make-string wl-plugged-server-indent ? )))
 218
 219 (defun wl-plugged-set-variables ()
 220   (setq wl-plugged-sending-queue-alist
 221         (wl-plugged-sending-queue-info))
 222   (setq wl-plugged-dop-queue-alist
 223         (wl-plugged-dop-queue-info))
 224   (setq wl-plugged-alist
 225         (sort (copy-sequence elmo-plugged-alist)
 226               '(lambda (a b)
 227                  (string< (caar a) (caar b))))))
 228
 229 (defun wl-plugged-sending-queue-info ()
 230   ;; sending queue status
 231   (let (alist msgs sent-via server port)
 232     (setq msgs (elmo-folder-list-messages
 233                 (wl-folder-get-elmo-folder wl-queue-folder)))
 234     (while msgs
 235       (setq sent-via (wl-draft-queue-info-operation (car msgs) 'get-sent-via))
 236       (while sent-via
 237         (when (eq (nth 1 (car sent-via)) 'unplugged)
 238           (setq server (car (nth 2 (car sent-via)))
 239                 port (cdr (nth 2 (car sent-via))))
 240           (elmo-plugged-p server port)  ;; add elmo-plugged-alist if nothing.
 241           (setq alist
 242                 (wl-append-assoc-list
 243                  (cons server port)
 244                  (car msgs)
 245                  alist)))
 246         (setq sent-via (cdr sent-via)))
 247       (setq msgs (cdr msgs)))
 248     alist))
 249
 250 (defun wl-plugged-sending-queue-status (qinfo)
 251   ;; sending queue status
 252   (let ((len (length (cdr qinfo))))
 253     (concat (wl-plugged-set-folder-icon
 254              wl-queue-folder
 255              (wl-folder-get-petname wl-queue-folder))
 256             (if (> len 1)
 257                 (format ": %d msgs (" len)
 258               (format ": %d msg (" len))
 259             (mapconcat (function int-to-string) (cdr qinfo) ",")
 260             ")")))
 261
 262 (defun wl-plugged-dop-queue-info ()
 263   ;; dop queue status
 264   (let* ((count 0)
 265          (elmo-dop-queue (copy-sequence elmo-dop-queue))
 266          dop-queue last alist server-info
 267          ope operation)
 268     ;(elmo-dop-queue-load)
 269     (elmo-dop-queue-merge)
 270     (setq dop-queue (sort elmo-dop-queue '(lambda (a b)
 271                                             (string< (elmo-dop-queue-fname a)
 272                                                      (elmo-dop-queue-fname b)))))
 273     (wl-append dop-queue (list nil)) ;; terminate(dummy)
 274     (when (car dop-queue)
 275       (setq last (elmo-dop-queue-fname (car dop-queue)))) ;; first
 276     (while dop-queue
 277       (when (car dop-queue)
 278         (setq ope (cons (elmo-dop-queue-method-name (car dop-queue))
 279                         (length
 280                          (if (listp
 281                               (car
 282                                (elmo-dop-queue-arguments (car dop-queue))))
 283                              (car (elmo-dop-queue-arguments
 284                                    (car dop-queue))))))))
 285       (if (and (car dop-queue)
 286                (string= last (elmo-dop-queue-fname (car dop-queue))))
 287           (wl-append operation (list ope))
 288         ;;(setq count (1+ count))
 289         (when (and last (setq server-info (elmo-net-port-info
 290                                            (wl-folder-get-elmo-folder last))))
 291           (setq alist
 292                 (wl-append-assoc-list
 293                  server-info
 294                  (cons last operation)
 295                  alist)))
 296         (when (car dop-queue)
 297           (setq last (elmo-dop-queue-fname (car dop-queue))
 298                 operation (list ope))))
 299       (setq dop-queue (cdr dop-queue)))
 300     alist))
 301
 302 (defun wl-plugged-dop-queue-status (qinfo &optional column)
 303   ;; dop queue status
 304   (let ((operations (cdr qinfo))
 305         (column (or column wl-plugged-queue-status-column)))
 306     (mapconcat
 307      '(lambda (folder-ope)
 308         (concat (wl-plugged-set-folder-icon
 309                  (car folder-ope)
 310                  (wl-folder-get-petname (car folder-ope)))
 311                 "("
 312                 (let ((opes (cdr folder-ope))
 313                       pair shrinked)
 314                   (while opes
 315                     (if (setq pair (assoc (car (car opes)) shrinked))
 316                         (setcdr pair (+ (cdr pair)
 317                                         (max (cdr (car opes)) 1)))
 318                       (setq shrinked (cons
 319                                       (cons (car (car opes))
 320                                             (max (cdr (car opes)) 1))
 321                                       shrinked)))
 322                     (setq opes (cdr opes)))
 323                   (mapconcat
 324                    '(lambda (ope)
 325                       (if (> (cdr ope) 0)
 326                           (format "%s:%d" (car ope) (cdr ope))
 327                         (format "%s" (car ope))))
 328                    (nreverse shrinked) ","))
 329                 ")"))
 330      operations
 331      (concat "\n" (wl-set-string-width column "")))))
 332
 333 (defun wl-plugged-drawing (plugged-alist)
 334   (let ((buffer-read-only nil)
 335         (alist plugged-alist)
 336         (vars wl-plugged-switch-variables)
 337         last server port stream-type label plugged time
 338         line len qinfo column)
 339     (erase-buffer)
 340     (while vars
 341       (insert (format "%s:[%s]%s"
 342                       (caar vars)
 343                       (wl-plugged-string (symbol-value (cdar vars)))
 344                       (if (cdr vars) " " "")))
 345       (setq vars (cdr vars)))
 346     (insert "\n")
 347     (let ((elmo-plugged wl-plugged-switch))
 348       (setq line (format "[%s](wl-plugged)"
 349                          (wl-plugged-string (elmo-plugged-p))))
 350       ;; sending queue status
 351       (when (setq qinfo (assoc (cons nil nil) wl-plugged-sending-queue-alist))
 352         (setq line (concat
 353                     (wl-set-string-width wl-plugged-queue-status-column line)
 354                     (wl-plugged-sending-queue-status qinfo))))
 355       (insert line "\n"))
 356     (while alist
 357       (setq server (nth 0 (caar alist))
 358             port (nth 1 (caar alist))
 359             stream-type (nth 2 (caar alist))
 360             label (nth 1 (car alist))
 361             plugged (nth 2 (car alist))
 362             time (nth 3 (car alist)))
 363       (unless (string= last server)
 364         ;; server plug
 365         (insert (format "%s[%s]%s\n"
 366                         (wl-plugged-server-indent)
 367                         (wl-plugged-string
 368                          (elmo-plugged-p server nil plugged-alist))
 369                         server))
 370         (setq last server))
 371       ;; port plug
 372       (setq line
 373             (format "%s[%s]%s"
 374                     (make-string wl-plugged-port-indent ? )
 375                     (wl-plugged-string plugged time)
 376                     (cond
 377                      ((stringp port)
 378                       port)
 379                      (t
 380                       (format "%s(%d)"
 381                               (or label
 382                                   (cdr (assq port wl-plugged-port-label-alist))
 383                                   "")
 384                               port)))))
 385       (setq column (max (if line (1+ (string-width line)) 0)
 386                         wl-plugged-queue-status-column))
 387       (cond
 388        ;; sending queue status
 389        ((setq qinfo (assoc (cons server port) wl-plugged-sending-queue-alist))
 390         (setq line
 391               (concat
 392                (wl-set-string-width column line)
 393                (wl-plugged-sending-queue-status qinfo))))
 394        ;; dop queue status
 395        ((setq qinfo (assoc (list server port stream-type)
 396                            wl-plugged-dop-queue-alist))
 397         (setq line
 398               (concat
 399                (wl-set-string-width column line)
 400                (wl-plugged-dop-queue-status qinfo column)))))
 401       (insert line "\n")
 402       (setq alist (cdr alist)))
 403     (delete-region (1- (point-max)) (point-max)) ;; delete line at the end.
 404     (goto-char (point-min))
 405     (while (not (eobp))
 406       (wl-highlight-plugged-current-line)
 407       (forward-line 1)))
 408   (set-buffer-modified-p nil)
 409   (count-lines (point-min) (point-max)))
 410
 411 (defun wl-plugged-redrawing-switch (indent switch &optional time)
 412   (beginning-of-line)
 413   (when (re-search-forward
 414          (format "^%s\\[\\([^]]+\\)\\]" (make-string indent ? )))
 415     (goto-char (match-beginning 1))
 416     (delete-region (match-beginning 1) (match-end 1))
 417     (insert (wl-plugged-string switch time))
 418     (wl-highlight-plugged-current-line)
 419     (forward-line 1)))
 420
 421 (defun wl-plugged-redrawing (plugged-alist)
 422   (let ((buffer-read-only nil)
 423         (alist plugged-alist)
 424         last server port plugged time)
 425     (goto-char (point-min))
 426     (wl-plugged-redrawing-switch 0 (elmo-plugged-p))
 427     (while alist
 428       (setq server (caaar alist)
 429             port (cdaar alist)
 430             plugged (nth 2 (car alist))
 431             time (nth 3 (car alist)))
 432       (unless (string= last server)
 433         ;; server plug
 434         (wl-plugged-redrawing-switch
 435          wl-plugged-server-indent
 436          (elmo-plugged-p server nil plugged-alist))
 437         (setq last server))
 438       ;; port plug
 439       (wl-plugged-redrawing-switch
 440        wl-plugged-port-indent plugged time)
 441       (setq alist (cdr alist))))
 442   (sit-for 0)
 443   (set-buffer-modified-p nil))
 444
 445 (defun wl-plugged-change ()
 446   (interactive)
 447   (if (not elmo-plugged-alist)
 448       (message "No plugged info")
 449     (setq wl-plugged-winconf (current-window-configuration))
 450     (let* ((cur-win (selected-window))
 451            (max-lines (if (eq major-mode 'wl-summary-mode)
 452                           (/ (frame-height) 2)
 453                         (window-height)))
 454            window-lines lines)
 455       (save-excursion
 456         (set-buffer (get-buffer-create wl-plugged-buf-name))
 457         (wl-plugged-mode)
 458         (buffer-disable-undo (current-buffer))
 459         (delete-windows-on (current-buffer))
 460         (wl-plugged-set-variables)
 461         (setq lines (wl-plugged-drawing wl-plugged-alist)))
 462       (select-window cur-win)
 463       (setq window-lines (min max-lines (max lines window-min-height)))
 464       (when (> (- (window-height) window-lines) window-min-height)
 465         (split-window cur-win (- (window-height) window-lines)))
 466       (switch-to-buffer wl-plugged-buf-name)
 467       (condition-case nil
 468           (progn
 469             (enlarge-window (- window-lines (window-height)))
 470             (when (fboundp 'pos-visible-in-window-p)
 471               (goto-char (point-min))
 472               (while (and (< (window-height) max-lines)
 473                           (not (pos-visible-in-window-p (1- (point-max)))))
 474                 (enlarge-window 2))))
 475         (error))
 476       (goto-char (point-min))
 477       (forward-line 1)
 478       (wl-plugged-move-to-next)))) ;; goto first entry
 479
 480 (defsubst wl-plugged-get-server ()
 481   (save-excursion
 482     (end-of-line)
 483     (wl-plugged-move-to-previous-server)
 484     (beginning-of-line)
 485     (when (looking-at (format "^%s\\[[^]]+\\]\\(.*\\)"
 486                               (wl-plugged-server-indent)))
 487       (elmo-match-buffer 1))))
 488
 489 (defun wl-plugged-toggle ()
 490   (interactive)
 491   (let ((cur-point (point)))
 492     (save-excursion
 493       (beginning-of-line)
 494       (cond
 495        ;; switch variable
 496        ((bobp)
 497         (let (variable switch name)
 498           (goto-char cur-point)
 499           (when (and (not (bobp))
 500                      (not (eq (char-before) ? )))
 501             (if (re-search-backward " [^ ]+" nil t)
 502                 (forward-char 1)
 503               (re-search-backward "^[^ ]+" nil t)))
 504           (when (looking-at "\\([^ :[]+\\):?\\[\\([^]]+\\)\\]")
 505             (setq name (elmo-match-buffer 1))
 506             (setq switch (not (string= (elmo-match-buffer 2) wl-plugged-plug-on)))
 507             (when (setq variable (cdr (assoc name wl-plugged-switch-variables)))
 508               (set variable switch))
 509             (goto-char (match-beginning 2))
 510             (let ((buffer-read-only nil))
 511               (delete-region (match-beginning 2) (match-end 2))
 512               (insert (wl-plugged-string switch))
 513               (set-buffer-modified-p nil)))))
 514        ;; switch plug
 515        ((looking-at "^\\( *\\)\\[\\([^]]+\\)\\]\\([^ \n]*\\)")
 516         (let* ((indent (length (elmo-match-buffer 1)))
 517                (switch (elmo-match-buffer 2))
 518                (name (elmo-match-buffer 3))
 519                (plugged (not (string= switch wl-plugged-plug-on)))
 520                (alist wl-plugged-alist)
 521                server port stream-type name-1)
 522           (cond
 523            ((eq indent wl-plugged-port-indent)  ;; toggle port plug
 524             (cond
 525              ((string-match "\\([^([]*\\)(\\([^)[]+\\))" name)
 526               (setq port (string-to-int (elmo-match-string 2 name)))
 527               (if (string-match "!" (setq name-1 (elmo-match-string 1 name)))
 528                   (setq stream-type
 529                         (intern (substring name-1 (match-end 0))))))
 530              (t
 531               (setq port name)))
 532             (setq server (wl-plugged-get-server))
 533             (elmo-set-plugged plugged server port stream-type nil alist))
 534            ((eq indent wl-plugged-server-indent)  ;; toggle server plug
 535             (elmo-set-plugged plugged name nil nil nil alist))
 536            ((eq indent 0)  ;; toggle all plug
 537             (elmo-set-plugged plugged nil nil nil nil alist)))
 538           ;; redraw
 539           (wl-plugged-redrawing wl-plugged-alist)
 540           ;; show plugged status in modeline
 541           (let ((elmo-plugged wl-plugged-switch))
 542             (setq wl-plugged-switch (elmo-plugged-p)
 543                   wl-modeline-plug-status wl-plugged-switch)
 544             (force-mode-line-update t))))))
 545     (setq wl-plugged-alist-modified t)
 546     (goto-char cur-point)))
 547
 548 (defun wl-plugged-click (e)
 549   (interactive "e")
 550   (mouse-set-point e)
 551   (wl-plugged-toggle))
 552
 553 (defun wl-plugged-toggle-all ()
 554   (interactive)
 555   (let ((cur-point (point)))
 556     (setq wl-plugged-switch (not wl-plugged-switch))
 557     (elmo-set-plugged wl-plugged-switch nil nil nil nil wl-plugged-alist)
 558     (wl-plugged-redrawing wl-plugged-alist)
 559     (goto-char cur-point)
 560     (setq wl-plugged-alist-modified t)
 561     ;; show plugged status in modeline
 562     (setq wl-modeline-plug-status wl-plugged-switch)
 563     (force-mode-line-update t)))
 564
 565 (defun wl-plugged-exit ()
 566   (interactive)
 567   (setq ;;elmo-plugged-alist wl-plugged-alist
 568         wl-plugged wl-plugged-switch
 569         wl-plugged-alist nil
 570         wl-plugged-sending-queue-alist nil
 571         wl-plugged-dop-queue-alist nil)
 572   (run-hooks 'wl-plugged-exit-hook)
 573   (when wl-plugged-alist-modified
 574     (wl-toggle-plugged (if wl-plugged 'on 'off) t))
 575   (kill-buffer (current-buffer))
 576   (if wl-plugged-winconf
 577       (set-window-configuration wl-plugged-winconf)))
 578
 579 (defun wl-plugged-flush-queue ()
 580   (interactive)
 581   (let ((cur-point (point))
 582         (dop-status (elmo-dop-queue-flush))
 583         (send-status (wl-draft-queue-flush)))
 584     (unless (or dop-status send-status)
 585       (message "No processing queue."))
 586     (wl-plugged-set-variables)
 587     (wl-plugged-drawing wl-plugged-alist)
 588     (goto-char cur-point)))
 589
 590 (defun wl-plugged-move-to-next ()
 591   (interactive)
 592   (when (re-search-forward "\\[\\([^]]+\\)\\]" nil t)
 593     (let ((pos (match-beginning 1)))
 594       (if (invisible-p pos)
 595           (goto-char (next-visible-point pos))
 596         (goto-char pos)))))
 597
 598 (defun wl-plugged-move-to-previous ()
 599   (interactive)
 600   (if (eq (char-before) ?\]) (forward-char -1))
 601   (when (re-search-backward "\\[\\([^]]+\\)\\]" nil t)
 602     (let ((pos (match-beginning 1)))
 603       (if (invisible-p pos)
 604           (goto-char (next-visible-point pos))
 605         (goto-char pos)))))
 606
 607 (defun wl-plugged-move-to-next-server ()
 608   (interactive)
 609   (let ((regexp
 610          (format "^%s\\[\\([^]]+\\)\\]" (wl-plugged-server-indent)))
 611         point)
 612     (save-excursion
 613       (end-of-line)
 614       (if (re-search-forward regexp nil t)
 615           (setq point (match-beginning 1))))
 616     (if point (goto-char point))))
 617
 618 (defun wl-plugged-move-to-previous-server ()
 619   (interactive)
 620   (let ((regexp
 621          (format "^%s\\[\\([^]]+\\)\\]" (wl-plugged-server-indent))))
 622     (if (re-search-backward regexp nil t)
 623         (goto-char (match-beginning 1)))))
 624
 625 ;;; end of wl-plugged-mode
 626
 627 (defun wl-save ()
 628   "Save summary and folder status."
 629   (interactive)
 630   (wl-save-status 'keep-summary)
 631   (run-hooks 'wl-save-hook))
 632
 633 (defun wl-save-status (&optional keep-summary)
 634   (message "Saving summary and folder status...")
 635   (let (summary-buf)
 636     (save-excursion
 637       (let ((summaries (wl-collect-summary)))
 638         (while summaries
 639           (with-current-buffer (car summaries)
 640             (unless keep-summary
 641               (wl-summary-cleanup-temp-marks))
 642             (wl-summary-save-view)
 643             (elmo-folder-commit wl-summary-buffer-elmo-folder)
 644             (unless keep-summary
 645               (kill-buffer (car summaries))))
 646           (setq summaries (cdr summaries))))))
 647   (wl-refile-alist-save)
 648   (wl-folder-info-save)
 649   (and (featurep 'wl-fldmgr) (wl-fldmgr-exit))
 650   (elmo-crosspost-message-alist-save)
 651   (message "Saving summary and folder status...done"))
 652
 653 (defun wl-exit ()
 654   (interactive)
 655   (when (or (not wl-interactive-exit)
 656             (y-or-n-p "Do you really want to quit Wanderlust? "))
 657     (elmo-quit)
 658     (when wl-use-acap (funcall (symbol-function 'wl-acap-exit)))
 659     (wl-biff-stop)
 660     (run-hooks 'wl-exit-hook)
 661     (wl-save-status)
 662     (wl-folder-cleanup-variables)
 663     (wl-message-buffer-cache-clean-up)
 664     (wl-kill-buffers
 665      (format "^\\(%s\\)$"
 666              (mapconcat 'identity
 667                         (list wl-folder-buffer-name
 668                               wl-plugged-buf-name)
 669                         "\\|")))
 670     (when wl-delete-startup-frame-function
 671       (funcall wl-delete-startup-frame-function))
 672 ;;    (if (and wl-folder-use-frame
 673 ;;           (> (length (visible-frame-list)) 1))
 674 ;;      (delete-frame))
 675     (setq wl-init nil)
 676     (remove-hook 'kill-emacs-hook 'wl-save-status)
 677     t)
 678   (message "") ; empty minibuffer.
 679   )
 680
 681 (defun wl-init ()
 682   (when (not wl-init)
 683     (require 'mime-setup)
 684     (setq elmo-plugged wl-plugged)
 685     (add-hook 'kill-emacs-hook 'wl-save-status)
 686     (wl-address-init)
 687     (wl-draft-setup)
 688     (wl-refile-alist-setup)
 689     (require 'wl-mime)
 690     ;; defined above.
 691     (wl-mime-setup)
 692     (fset 'wl-summary-from-func-internal
 693           (symbol-value 'wl-summary-from-function))
 694     (fset 'wl-summary-subject-func-internal
 695           (symbol-value 'wl-summary-subject-function))
 696     (fset 'wl-summary-subject-filter-func-internal
 697           (symbol-value 'wl-summary-subject-filter-function))
 698     (setq elmo-no-from wl-summary-no-from-message)
 699     (setq elmo-no-subject wl-summary-no-subject-message)
 700     (wl-news-check)
 701     (setq wl-init t)
 702     ;; This hook may contain the functions `wl-plugged-init-icons' and
 703     ;; `wl-biff-init-icons' for reasons of system internal to accord
 704     ;; facilities for the Emacs variants.
 705     (run-hooks 'wl-init-hook)))
 706
 707 (defun wl-check-environment (no-check-folder)
 708   (unless wl-from (error "Please set `wl-from' to your mail address."))
 709   ;; Message-ID
 710   (when wl-insert-message-id
 711     (let ((message-id (funcall wl-message-id-function))
 712           domain)
 713       (unless (string-match "^<\\([^@]*\\)@\\([^@]*\\)>$" message-id)
 714         (cond
 715          ((string-match "@" wl-message-id-domain)
 716           (error "Please remove `@' from `wl-message-id-domain'."))
 717          (t
 718           (error
 719            "Check around `wl-message-id-function' to get valid Message-ID string."))))
 720       (setq domain (match-string 2 message-id))
 721       (if (or (not (string-match "[^.]\\.[^.]" domain))
 722               (string= domain "localhost.localdomain"))
 723           (elmo-warning
 724            "Please set `wl-message-id-domain' to get valid Message-ID string."))))
 725   ;; folders
 726   (when (not no-check-folder)
 727     (let ((draft-folder (wl-folder-get-elmo-folder wl-draft-folder))
 728           (queue-folder (wl-folder-get-elmo-folder wl-queue-folder))
 729           (lost+found-folder (wl-folder-get-elmo-folder
 730                               elmo-lost+found-folder)))
 731       (if (not (elmo-folder-message-file-p draft-folder))
 732           (error "%s is not allowed for draft folder" wl-draft-folder))
 733       (unless (elmo-folder-exists-p draft-folder)
 734         (if (y-or-n-p
 735              (format "Draft Folder %s does not exist, create it? "
 736                      wl-draft-folder))
 737             (elmo-folder-create draft-folder)
 738           (error "Draft Folder is not created")))
 739       (if (and wl-draft-enable-queuing
 740                (not (elmo-folder-exists-p queue-folder)))
 741           (if (y-or-n-p
 742                (format "Queue Folder %s does not exist, create it? "
 743                        wl-queue-folder))
 744               (elmo-folder-create queue-folder)
 745             (error "Queue Folder is not created")))
 746       (when (not (eq no-check-folder 'wl-draft))
 747         (unless (elmo-folder-exists-p lost+found-folder)
 748           (elmo-folder-create lost+found-folder)))
 749       ;; tmp dir
 750       (unless (file-exists-p wl-temporary-file-directory)
 751         (if (y-or-n-p
 752              (format "Temp directory (to save multipart) %s does not exist, create it now? "
 753                      wl-temporary-file-directory))
 754             (make-directory wl-temporary-file-directory)
 755           (error "Temp directory is not created"))))))
 756
 757 (defconst wl-check-variables-alist
 758   '((numberp . elmo-pop3-default-port)
 759     (symbolp . elmo-pop3-default-authenticate-type)
 760     (numberp . elmo-imap4-default-port)
 761     (symbolp . elmo-imap4-default-authenticate-type)
 762     (numberp . elmo-nntp-default-port)
 763     (numberp . wl-pop-before-smtp-port)
 764     (symbolp . wl-pop-before-smtp-authenticate-type)))
 765
 766 (defun wl-check-variables ()
 767   (let ((type-variables wl-check-variables-alist)
 768         type)
 769     (while (setq type (car type-variables))
 770       (if (and (eval (cdr type))
 771                (not (funcall (car type)
 772                              (eval (cdr type)))))
 773           (error "%s must be %s: %S"
 774                  (cdr type)
 775                  (substring (format "%s" (car type)) 0 -1)
 776                  (eval (cdr type))))
 777       (setq type-variables (cdr type-variables)))))
 778
 779 (defun wl-check-variables-2 ()
 780   (if (< wl-message-buffer-cache-size 1)
 781       (error "`wl-message-buffer-cache-size' must be larger than 0."))
 782   (when wl-message-buffer-prefetch-depth
 783     (if (not (< wl-message-buffer-prefetch-depth
 784                 wl-message-buffer-cache-size))
 785         (error (concat
 786                 "`wl-message-buffer-prefetch-depth' must be smaller than "
 787                 "`wl-message-buffer-cache-size' - 1."))))
 788   (let (case-fold-search)
 789     (unless (string-match "%T" wl-summary-line-format)
 790       (error "`wl-summary-line-format' must contain %%T and %%P"))
 791     (unless (string-match "%P" wl-summary-line-format)
 792       (error "`wl-summary-line-format' must contain %%T and %%P"))
 793     (dolist (pair wl-folder-summary-line-format-alist)
 794       (unless (string-match "%T" (cdr pair))
 795         (error "Format `%s' must contain %%T and %%P" (cdr pair)))
 796       (unless (string-match "%P" (cdr pair))
 797         (error "Format `%s' must contain %%T and %%P" (cdr pair))))))
 798
 799 ;;;###autoload
 800 (defun wl (&optional arg)
 801   "Start Wanderlust -- Yet Another Message Interface On Emacsen.
 802 If ARG (prefix argument) is specified, folder checkings are skipped."
 803   (interactive "P")
 804   (unless wl-init
 805     (wl-load-profile)
 806     (wl-folder-init)
 807     (elmo-init))
 808   (let (demo-buf check)
 809     (unless wl-init
 810       (if wl-demo (setq demo-buf (wl-demo)))
 811       (setq check t))
 812     (wl-init)
 813     (condition-case obj
 814         (progn
 815           (if check
 816               (progn
 817                 (message "Checking environment...")
 818                 (wl-check-environment arg)
 819                 (message "Checking environment...done")
 820                 (message "Checking type of variables...")
 821                 (wl-check-variables)
 822                 (wl-check-variables-2)
 823                 (message "Checking type of variables...done")))
 824           (let ((inhibit-quit t))
 825             (wl-plugged-init (wl-folder arg)))
 826           (unless arg
 827             (run-hooks 'wl-auto-check-folder-pre-hook)
 828             (wl-folder-auto-check)
 829             (run-hooks 'wl-auto-check-folder-hook))
 830           (unless arg (wl-biff-start)))
 831       (error
 832        (if (buffer-live-p demo-buf)
 833            (kill-buffer demo-buf))
 834        (signal (car obj)(cdr obj)))
 835       (quit))
 836     (if (buffer-live-p demo-buf)
 837         (kill-buffer demo-buf)))
 838   (run-hooks 'wl-hook))
 839
 840 (defvar wl-delete-startup-frame-function nil)
 841
 842 ;;;###autoload
 843 (defun wl-other-frame (&optional arg)
 844   "Pop up a frame to read messages via Wanderlust."
 845   (interactive)
 846   (if wl-folder-use-frame
 847       (wl arg)
 848     (let ((focusing-functions (append '(raise-frame select-frame)
 849                                       (if (fboundp 'x-focus-frame)
 850                                           '(x-focus-frame)
 851                                         '(focus-frame))))
 852           (folder (get-buffer wl-folder-buffer-name))
 853           window frame wl-folder-use-frame)
 854       (if (and folder
 855                (setq window (get-buffer-window folder t))
 856                (window-live-p window)
 857                (setq frame (window-frame window)))
 858           (progn
 859             (while focusing-functions
 860               (funcall (car focusing-functions) frame)
 861               (setq focusing-functions (cdr focusing-functions)))
 862             (wl arg))
 863         (setq frame (make-frame))
 864         (while focusing-functions
 865           (funcall (car focusing-functions) frame)
 866           (setq focusing-functions (cdr focusing-functions)))
 867         (setq wl-delete-startup-frame-function
 868               `(lambda ()
 869                  (setq wl-delete-startup-frame-function nil)
 870                  (let ((frame ,frame))
 871                    (if (eq (selected-frame) frame)
 872                        (delete-frame frame)))))
 873         (wl arg)))))
 874
 875 ;; Define some autoload functions WL might use.
 876 (eval-and-compile
 877   ;; This little mapcar goes through the list below and marks the
 878   ;; symbols in question as autoloaded functions.
 879   (mapcar
 880    (function
 881     (lambda (package)
 882       (let ((interactive (nth 1 (memq ':interactive package))))
 883         (mapcar
 884          (function
 885           (lambda (function)
 886             (let (keymap)
 887               (when (consp function)
 888                 (setq keymap (car (memq 'keymap function)))
 889                 (setq function (car function)))
 890               (autoload function (car package) nil interactive keymap))))
 891          (if (eq (nth 1 package) ':interactive)
 892              (cdddr package)
 893            (cdr package))))))
 894    '(("wl-fldmgr" :interactive t
 895       wl-fldmgr-access-display-all wl-fldmgr-access-display-normal
 896       wl-fldmgr-add wl-fldmgr-clear-cut-entity-list wl-fldmgr-copy
 897       wl-fldmgr-copy-region wl-fldmgr-cut wl-fldmgr-cut-region
 898       wl-fldmgr-make-access-group wl-fldmgr-make-filter
 899       wl-fldmgr-make-group wl-fldmgr-make-multi
 900       wl-fldmgr-reconst-entity-hashtb wl-fldmgr-rename wl-fldmgr-delete
 901       wl-fldmgr-save-folders wl-fldmgr-set-petname wl-fldmgr-sort
 902       wl-fldmgr-subscribe wl-fldmgr-subscribe-region
 903       wl-fldmgr-unsubscribe wl-fldmgr-unsubscribe-region wl-fldmgr-yank )
 904      ("wl-acap" wl-acap-init)
 905      ("wl-acap" :interactive t wl-acap-store)
 906      ("wl-fldmgr"
 907       (wl-fldmgr-mode-map keymap)
 908       wl-fldmgr-add-entity-hashtb)
 909      ("wl-expire" :interactive t
 910       wl-folder-archive-current-entity
 911       wl-folder-expire-current-entity wl-summary-archive
 912       wl-summary-expire )
 913      ("wl-score"
 914       wl-score-save wl-summary-rescore-msgs wl-summary-score-headers
 915       wl-summary-score-update-all-lines )
 916      ("wl-score" :interactive t
 917       wl-score-change-score-file wl-score-edit-current-scores
 918       wl-score-edit-file wl-score-flush-cache wl-summary-rescore
 919       wl-score-set-mark-below wl-score-set-expunge-below
 920       wl-summary-increase-score wl-summary-lower-score ))))
 921
 922 ;; for backward compatibility
 923 (defalias 'wl-summary-from-func-petname 'wl-summary-default-from)
 924
 925 (require 'product)
 926 (product-provide (provide 'wl) (require 'wl-version))
 927
 928 ;;; wl.el ends here