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