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