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