;;; wl-util.el -- Utility modules for Wanderlust.
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 2000 A. SAGATA <sagata@nttvdt.hil.ntt.co.jp>
+;; Copyright (C) 2000 Katsumi Yamaoka <yamaoka@jpl.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
+;; A. SAGATA <sagata@nttvdt.hil.ntt.co.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: mail, net news
;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
;;
;;; Commentary:
-;;
+;;
;;; Code:
-;;
+;;
-(provide 'wl-util)
(eval-when-compile
- (provide 'elmo-util))
-
-(condition-case ()
- (require 'tm-edit)
- (error))
-(condition-case ()
- (require 'pp)
- (error))
+ (require 'elmo-util))
+
+(condition-case nil (require 'tm-edit) (error nil))
+(condition-case nil (require 'pp) (error nil))
+
(eval-when-compile
- (mapcar
- (function
- (lambda (symbol)
- (unless (boundp symbol)
- (set (make-local-variable symbol) nil))))
- '(mule-version
- nemacs-version
- emacs-beta-version
- xemacs-codename
- mime-edit-insert-user-agent-field
- mime-edit-user-agent-value
- mime-editor/version
- mime-editor/codename))
(require 'time-stamp)
- (defun-maybe read-event ())
- (defun-maybe next-command-event ())
- (defun-maybe event-to-character (a))
- (defun-maybe key-press-event-p (a))
- (defun-maybe button-press-event-p (a))
- (defun-maybe set-process-kanji-code (a b))
- (defun-maybe set-process-coding-system (a b c))
- (defun-maybe dispatch-event (a)))
+ (defalias-maybe 'next-command-event 'ignore)
+ (defalias-maybe 'event-to-character 'ignore)
+ (defalias-maybe 'key-press-event-p 'ignore)
+ (defalias-maybe 'button-press-event-p 'ignore)
+ (defalias-maybe 'set-process-kanji-code 'ignore)
+ (defalias-maybe 'set-process-coding-system 'ignore)
+ (defalias-maybe 'dispatch-event 'ignore))
(defalias 'wl-set-work-buf 'elmo-set-work-buf)
(make-obsolete 'wl-set-work-buf 'elmo-set-work-buf)
(list 'nconc val func)
(list 'setq val func)))
-(defun wl-parse (string regexp &optional matchn)
- (or matchn (setq matchn 1))
- (let (list)
- (store-match-data nil)
- (while (string-match regexp string (match-end 0))
- (setq list (cons (substring string (match-beginning matchn)
- (match-end matchn)) list)))
- (nreverse list)))
+(defalias 'wl-parse 'elmo-parse)
+(make-obsolete 'wl-parse 'elmo-parse)
(defun wl-delete-duplicates (list &optional all hack-addresses)
- "Delete duplicate equivalent strings from the list.
-If ALL is t, then if there is more than one occurrence of a string in the list,
+ "Delete duplicate equivalent strings from the LIST.
+If ALL is t, then if there is more than one occurrence of a string in the LIST,
then all occurrences of it are removed instead of just the subsequent ones.
If HACK-ADDRESSES is t, then the strings are considered to be mail addresses,
and only the address part is compared (so that \"Name <foo>\" and \"foo\"
(nreverse list)) ; jwz: fixed order
)))
-(defun wl-version (&optional with-codename)
- (format "%s %s%s" wl-appname wl-version
- (if with-codename
- (format " - \"%s\"" wl-codename) "")))
-
-(defun wl-version-show ()
- (interactive)
- (message "%s" (wl-version t)))
-
-;; from gnus
-(defun wl-extended-emacs-version (&optional with-codename)
- "Stringified Emacs version"
- (interactive)
- (cond
- ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version)
- (concat "Emacs " (wl-match-string 1 emacs-version)
- (and (boundp 'mule-version)(concat "/Mule " mule-version))))
- ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
- emacs-version)
- (concat (wl-match-string 1 emacs-version)
- (format " %d.%d" emacs-major-version emacs-minor-version)
- (if (and (boundp 'emacs-beta-version)
- emacs-beta-version)
- (format "b%d" emacs-beta-version))
- (if with-codename
- (if (boundp 'xemacs-codename)
- (concat " - \"" xemacs-codename "\"")))))
- (t emacs-version)))
-
-(defun wl-extended-emacs-version2 (&optional delimiter with-codename)
- "Stringified Emacs version"
- (interactive)
- (cond
- ((and (boundp 'mule-version)
- mule-version
- (string-match "\\([0-9]+\.[0-9]+\\)\\(.*$\\)" mule-version))
- (format "Mule%s%s@%d.%d%s"
- (or delimiter " ")
- (wl-match-string 1 mule-version)
- emacs-major-version
- emacs-minor-version
- (if with-codename
- (wl-match-string 2 mule-version)
- "")))
- ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version)
- (if (boundp 'nemacs-version)
- (concat "Nemacs" (or delimiter " ")
- nemacs-version
- "@"
- (substring emacs-version
- (match-beginning 1)
- (match-end 1)))
- (concat "Emacs" (or delimiter " ")
- (wl-match-string 1 emacs-version))))
- ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
- emacs-version)
- (concat (wl-match-string 1 emacs-version)
- (or delimiter " ")
- (format "%d.%d" emacs-major-version emacs-minor-version)
- (if (and (boundp 'emacs-beta-version)
- emacs-beta-version)
- (format "b%d" emacs-beta-version))
- (if (and with-codename
- (boundp 'xemacs-codename)
- xemacs-codename)
- (format " (%s)" xemacs-codename))))
- (t emacs-version)))
-
-(defun wl-extended-emacs-version3 (&optional delimiter with-codename)
- "Stringified Emacs version"
- (interactive)
- (cond
- ((and (boundp 'mule-version)
- mule-version
- (string-match "\\([0-9]+\.[0-9]+\\)\\(.*$\\)" mule-version))
- (format "Emacs%s%d.%d Mule%s%s%s"
- (or delimiter " ")
- emacs-major-version
- emacs-minor-version
- (or delimiter " ")
- (wl-match-string 1 mule-version)
- (if with-codename
- (wl-match-string 2 mule-version)
- "")))
- ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version)
- (if (boundp 'nemacs-version)
- (let ((nemacs-codename-assoc '(("3.3.2" . " (FUJIMUSUME)")
- ("3.3.1" . " (HINAMATSURI)")
- ("3.2.3" . " (YUMENO-AWAYUKI)"))))
- (format "Emacs%s%s Nemacs%s%s%s"
- (or delimiter " ")
- (wl-match-string 1 emacs-version)
- (or delimiter " ")
- nemacs-version
- (or (and with-codename
- (cdr (assoc nemacs-version
- nemacs-codename-assoc)))
- "")))
- (concat "Emacs" (or delimiter " ")
- (wl-match-string 1 emacs-version))))
- ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
- emacs-version)
- (concat (wl-match-string 1 emacs-version)
- (or delimiter " ")
- (format "%d.%d" emacs-major-version emacs-minor-version)
- (if (and (boundp 'emacs-beta-version)
- emacs-beta-version)
- (format "b%d" emacs-beta-version))
- (if (and with-codename
- (boundp 'xemacs-codename)
- xemacs-codename)
- (format " (%s)" xemacs-codename))))
- (t emacs-version)))
-
(defun wl-append-element (list element)
(if element
(append list (list element))
list))
-(defun wl-read-event-char ()
- "Get the next event."
- (let ((event (read-event)))
- ;; should be gnus-characterp, but this can't be called in XEmacs anyway
- (cons (and (numberp event) event) event)))
-
-(defun wl-xmas-read-event-char ()
- "Get the next event."
- (let ((event (next-command-event)))
- (sit-for 0)
- ;; We junk all non-key events. Is this naughty?
- (while (not (or (key-press-event-p event)
- (button-press-event-p event)))
- (dispatch-event event)
- (setq event (next-command-event)))
- (cons (and (key-press-event-p event)
- (event-to-character event))
- event)))
-
-(if running-xemacs
- (fset 'wl-read-event-char 'wl-xmas-read-event-char))
-
(defmacro wl-push (v l)
+ "Insert V at the head of the list stored in L."
(list 'setq l (list 'cons v l)))
(defmacro wl-pop (l)
+ "Remove the head of the list stored in L."
(list 'car (list 'prog1 l (list 'setq l (list 'cdr l)))))
(defun wl-ask-folder (func mes-string)
(wl-push (cdr keve) unread-command-events))))
;(defalias 'wl-make-hash 'elmo-make-hash)
-;(make-obsolete 'wl-make-hash 'elmo-make-hash)
+;;(make-obsolete 'wl-make-hash 'elmo-make-hash)
-;(defalias 'wl-get-hash-val 'elmo-get-hash-val)
-;(make-obsolete 'wl-get-hash-val 'elmo-get-hash-val)
+;;(defalias 'wl-get-hash-val 'elmo-get-hash-val)
+;;(make-obsolete 'wl-get-hash-val 'elmo-get-hash-val)
-;(defalias 'wl-set-hash-val 'elmo-set-hash-val)
-;(make-obsolete 'wl-set-hash-val 'elmo-set-hash-val)
+;;(defalias 'wl-set-hash-val 'elmo-set-hash-val)
+;;(make-obsolete 'wl-set-hash-val 'elmo-set-hash-val)
(defsubst wl-set-string-width (width string)
(elmo-set-work-buf
(if (> (current-column) width)
(if (> (move-to-column width) width)
(progn
- (condition-case nil ; ignore error
+ (condition-case nil ; ignore error
(backward-char 1)
(error))
(concat (buffer-substring (point-min) (point)) " "))
(if (= (current-column) width)
string
(concat string
- (format (format "%%%ds"
+ (format (format "%%%ds"
(- width (current-column)))
" "))))))
(format "%dK" result))
(t (format "%dB" result)))))
-(defun wl-generate-user-agent-string ()
- "A candidate of wl-generate-mailer-string-func.
-Insert User-Agent field instead of X-Mailer field."
- (let ((mime-user-agent (and (boundp 'mime-edit-insert-user-agent-field)
- mime-edit-insert-user-agent-field
- mime-edit-user-agent-value)))
- (if mime-user-agent
- (concat "User-Agent: "
- wl-appname "/" wl-version
- " (" wl-codename ") "
- mime-user-agent)
- (if (and (boundp 'mime-editor/version)
- mime-editor/version)
- (concat "User-Agent: "
- wl-appname "/" wl-version
- " (" wl-codename ") "
- "tm/" mime-editor/version
- (if (and (boundp 'mime-editor/codename)
- mime-editor/codename)
- (concat " (" mime-editor/codename ")"))
- (if (and (boundp 'mime-library-product)
- mime-library-product)
- (concat " " (aref mime-library-product 0)
- "/"
- (mapconcat 'int-to-string
- (aref mime-library-product 1)
- ".")
- " (" (aref mime-library-product 2) ")"))
- (condition-case nil
- (progn
- (require 'apel-ver)
- (concat " " (apel-version)))
- (file-error nil))
- " " (wl-extended-emacs-version3 "/" t))
- (concat "User-Agent: " wl-appname "/" wl-version " (" wl-codename ") "
- (wl-extended-emacs-version3 "/" t))))))
-
-(defun wl-make-modeline-subr ()
- (let* ((duplicated (copy-sequence mode-line-format))
- (cur-entry duplicated)
- return-modeline)
- (if (memq 'wl-plug-state-indicator mode-line-format)
- duplicated
- (catch 'done
- (while cur-entry
- (if (or (and (symbolp (car cur-entry))
- (eq 'mode-line-buffer-identification
- (car cur-entry)))
- (and (consp (car cur-entry))
- (or
- (eq 'modeline-buffer-identification
- (car (car cur-entry)))
- (eq 'modeline-buffer-identification
- (cdr (car cur-entry))))))
- (progn
- (setq return-modeline (append return-modeline
- (list 'wl-plug-state-indicator)
- cur-entry))
- (throw 'done return-modeline))
- (setq return-modeline (append return-modeline
- (list (car cur-entry)))))
- (setq cur-entry (cdr cur-entry)))))))
+(defun wl-mode-line-buffer-identification (&optional id)
+ (let ((priorities '(biff plug title)))
+ (let ((items (reverse wl-mode-line-display-priority-list))
+ item)
+ (while items
+ (setq item (car items)
+ items (cdr items))
+ (unless (memq item '(biff plug))
+ (setq item 'title))
+ (setq priorities (cons item (delq item priorities)))))
+ (let (priority result)
+ (while priorities
+ (setq priority (car priorities)
+ priorities (cdr priorities))
+ (cond
+ ((eq 'biff priority)
+ (when wl-biff-check-folder-list
+ (setq result (append result '((wl-modeline-biff-status
+ wl-modeline-biff-state-on
+ wl-modeline-biff-state-off))))))
+ ((eq 'plug priority)
+ (when wl-show-plug-status-on-modeline
+ (setq result (append result '((wl-modeline-plug-status
+ wl-modeline-plug-state-on
+ wl-modeline-plug-state-off))))))
+ (t
+ (setq result (append result (or id '("Wanderlust: %12b")))))))
+ (prog1
+ (setq mode-line-buffer-identification (if (stringp (car result))
+ result
+ (cons "" result)))
+ (force-mode-line-update t)))))
(defalias 'wl-display-error 'elmo-display-error)
(make-obsolete 'wl-display-error 'elmo-display-error)
value)))
(defmacro wl-match-string (pos string)
- "Substring POSth matched string."
+ "Substring POSth matched STRING."
(` (substring (, string) (match-beginning (, pos)) (match-end (, pos)))))
(defmacro wl-match-buffer (pos)
(defalias 'wl-string 'elmo-string)
(make-obsolete 'wl-string 'elmo-string)
-(defun wl-parse-newsgroups (string &optional subscribe-only)
- (let* ((nglist (wl-parse string "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)"))
- spec ret-val)
- (if (not subscribe-only)
- nglist
- (while nglist
- (if (intern-soft (car nglist) wl-folder-newsgroups-hashtb)
- (wl-append ret-val (list (car nglist))))
- (setq nglist (cdr nglist)))
- ret-val)))
-
;; Check if active region exists or not.
(if (boundp 'mark-active)
(defmacro wl-region-exists-p ()
(if (fboundp 'region-exists-p)
(defmacro wl-region-exists-p ()
(list 'region-exists-p))))
-
+
(if (not (fboundp 'overlays-in))
(defun overlays-in (beg end)
"Return a list of the overlays that overlap the region BEG ... END.
(list (list item value))))))
(defun wl-delete-alist (key alist)
- "Delete all entries in ALIST that have a key eq to KEY."
+ "Delete by side effect any entries specified with KEY from ALIST.
+Return the modified ALIST. Key comparison is done with `assq'.
+Write `(setq foo (wl-delete-alist key foo))' to be sure of changing
+the value of `foo'."
(let (entry)
(while (setq entry (assq key alist))
(setq alist (delq entry alist)))
alist))
-(eval-when-compile
+(defun wl-delete-associations (keys alist)
+ "Delete by side effect any entries specified with KEYS from ALIST.
+Return the modified ALIST. KEYS must be a list of keys for ALIST.
+Deletion is done with `wl-delete-alist'.
+Write `(setq foo (wl-delete-associations keys foo))' to be sure of
+changing the value of `foo'."
+ (while keys
+ (setq alist (wl-delete-alist (car keys) alist))
+ (setq keys (cdr keys)))
+ alist)
+
+(defun wl-inverse-alist (keys alist)
+ "Inverse ALIST, copying.
+Return an association list represents the inverse mapping of ALIST,
+from objects to KEYS.
+The objects mapped (cdrs of elements of the ALIST) are shared."
+ (let (x y tmp result)
+ (while keys
+ (setq x (car keys))
+ (setq y (cdr (assq x alist)))
+ (if y
+ (if (setq tmp (assoc y result))
+ (setq result (cons (append tmp (list x))
+ (delete tmp result)))
+ (setq result (cons (list y x) result))))
+ (setq keys (cdr keys)))
+ result))
+
+(eval-when-compile
(require 'static))
(static-unless (fboundp 'pp)
(defvar pp-escape-newlines t)
(if (looking-at "[ \t]*\)")
(delete-region (match-beginning 0) (match-end 0))
(error "Malformed quote"))
- (backward-sexp 1))
+ (backward-sexp 1))
((condition-case err-var
(prog1 t (down-list 1))
(error nil))
(defsubst wl-get-date-iso8601 (date)
(or (get-text-property 0 'wl-date date)
(let* ((d1 (timezone-fix-time date nil nil))
- (time (format "%04d%02d%02dT%02d%02d%02d"
- (aref d1 0) (aref d1 1) (aref d1 2)
- (aref d1 3) (aref d1 4) (aref d1 5))))
- (put-text-property 0 1 'wl-date time date)
- time)))
+ (time (format "%04d%02d%02dT%02d%02d%02d"
+ (aref d1 0) (aref d1 1) (aref d1 2)
+ (aref d1 3) (aref d1 4) (aref d1 5))))
+ (put-text-property 0 1 'wl-date time date)
+ time)))
(defun wl-make-date-string ()
(let ((s (current-time-string)))
s)
(concat (wl-match-string 1 s) ", "
(timezone-make-date-arpa-standard s (current-time-zone)))))
-
+
(defun wl-date-iso8601 (date)
"Convert the DATE to YYMMDDTHHMMSS."
(condition-case ()
(wl-get-date-iso8601 date)
(error "")))
-
+
(defun wl-day-number (date)
(let ((dat (mapcar '(lambda (s) (and s (string-to-int s)) )
(timezone-parse-date date))))
(setq fld-name nil))
(if (eq (length (setq port
(elmo-match-string 2 url))) 0)
- (setq port (int-to-string elmo-default-nntp-port)))
+ (setq port (int-to-string elmo-nntp-default-port)))
(if (eq (length (setq server
(elmo-match-string 1 url))) 0)
- (setq server elmo-default-nntp-server))
+ (setq server elmo-nntp-default-server))
(setq folder (concat "-" fld-name "@" server ":" port))
(if (eq (length (setq msg
(elmo-match-string 4 url))) 0)
(` (save-excursion
(if (buffer-live-p wl-current-summary-buffer)
(set-buffer wl-current-summary-buffer))
- wl-message-buf-name)))
+ wl-message-buffer)))
(defmacro wl-kill-buffers (regexp)
(` (mapcar (function
(and (get-buffer x)
(kill-buffer x)))))
(buffer-list))))
-
+
(defun wl-sendlog-time ()
(static-if (fboundp 'format-time-string)
(format-time-string "%Y/%m/%d %T")
(let ((date (current-time-string)))
(format "%s/%02d/%02d %s"
- (substring date -4)
- (cdr (assoc (upcase (substring date 4 7))
+ (substring date -4)
+ (cdr (assoc (upcase (substring date 4 7))
timezone-months-assoc))
- (string-to-int (substring date 8 10))
- (substring date 11 19)))))
+ (string-to-int (substring date 8 10))
+ (substring date 11 19)))))
(defun wl-collect-summary ()
(let (result)
".wl")))
(defun wl-draft-make-message-id-string ()
+ "Return Message-ID field value."
(concat "<" (wl-unique-id) "@"
(or wl-message-id-domain
(if wl-local-domain
">"))
;;; Profile loading.
-(defvar wl-load-profile-func 'wl-local-load-profile)
+(defvar wl-load-profile-function 'wl-local-load-profile)
(defun wl-local-load-profile ()
+ "Load `wl-init-file'."
(message "Initializing ...")
(load wl-init-file 'noerror 'nomessage))
-
+
(defun wl-load-profile ()
- (funcall wl-load-profile-func))
+ "Call `wl-load-profile-function' function."
+ (funcall wl-load-profile-function))
+
+;;;
+
+(defmacro wl-count-lines ()
+ (` (save-excursion
+ (beginning-of-line)
+ (count-lines 1 (point)))))
+
+(defun wl-horizontal-recenter ()
+ "Recenter the current buffer horizontally."
+ (beginning-of-line)
+ (re-search-forward "[[<]" (point-at-eol) t)
+ (if (< (current-column) (/ (window-width) 2))
+ (set-window-hscroll (get-buffer-window (current-buffer) t) 0)
+ (let* ((orig (point))
+ (end (window-end (get-buffer-window (current-buffer) t)))
+ (max 0))
+ (when end
+ ;; Find the longest line currently displayed in the window.
+ (goto-char (window-start))
+ (while (and (not (eobp))
+ (< (point) end))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ (goto-char orig)
+ ;; Scroll horizontally to center (sort of) the point.
+ (if (> max (window-width))
+ (set-window-hscroll
+ (get-buffer-window (current-buffer) t)
+ (min (- (current-column) (/ (window-width) 3))
+ (+ 2 (- max (window-width)))))
+ (set-window-hscroll (get-buffer-window (current-buffer) t) 0))
+ max))))
+
+;; Biff
+(static-cond
+ (wl-on-xemacs
+ (defvar wl-biff-timer-name "wl-biff")
+
+ (defun wl-biff-stop ()
+ (when (get-itimer wl-biff-timer-name)
+ (delete-itimer wl-biff-timer-name)))
+
+ (defun wl-biff-start ()
+ (wl-biff-stop)
+ (when wl-biff-check-folder-list
+ (wl-biff-check-folders)
+ (start-itimer wl-biff-timer-name 'wl-biff-check-folders
+ wl-biff-check-interval wl-biff-check-interval))))
+
+ ((and (condition-case nil (require 'timer) (error nil));; FSFmacs 19+
+ (fboundp 'timer-activate))
+
+ (defun wl-biff-stop ()
+ (when (get 'wl-biff 'timer)
+ (cancel-timer (get 'wl-biff 'timer))))
+
+ (defun wl-biff-start ()
+ (require 'timer)
+ (when wl-biff-check-folder-list
+ (wl-biff-check-folders)
+ (if (get 'wl-biff 'timer)
+ (timer-activate (get 'wl-biff 'timer))
+ (put 'wl-biff 'timer (run-at-time
+ (timer-next-integral-multiple-of-time
+ (current-time) wl-biff-check-interval)
+ wl-biff-check-interval
+ 'wl-biff-event-handler)))))
+
+ (defun-maybe timer-next-integral-multiple-of-time (time secs)
+ "Yield the next value after TIME that is an integral multiple of SECS.
+More precisely, the next value, after TIME, that is an integral multiple
+of SECS seconds since the epoch. SECS may be a fraction.
+This function is imported from Emacs 20.7."
+ (let ((time-base (ash 1 16)))
+ (if (fboundp 'atan)
+ ;; Use floating point, taking care to not lose precision.
+ (let* ((float-time-base (float time-base))
+ (million 1000000.0)
+ (time-usec (+ (* million
+ (+ (* float-time-base (nth 0 time))
+ (nth 1 time)))
+ (nth 2 time)))
+ (secs-usec (* million secs))
+ (mod-usec (mod time-usec secs-usec))
+ (next-usec (+ (- time-usec mod-usec) secs-usec))
+ (time-base-million (* float-time-base million)))
+ (list (floor next-usec time-base-million)
+ (floor (mod next-usec time-base-million) million)
+ (floor (mod next-usec million))))
+ ;; Floating point is not supported.
+ ;; Use integer arithmetic, avoiding overflow if possible.
+ (let* ((mod-sec (mod (+ (* (mod time-base secs)
+ (mod (nth 0 time) secs))
+ (nth 1 time))
+ secs))
+ (next-1-sec (+ (- (nth 1 time) mod-sec) secs)))
+ (list (+ (nth 0 time) (floor next-1-sec time-base))
+ (mod next-1-sec time-base)
+ 0)))))
+
+ (defun wl-biff-event-handler ()
+ ;; PAKURing from FSF:time.el
+ (wl-biff-check-folders)
+ ;; Do redisplay right now, if no input pending.
+ (sit-for 0)
+ (let* ((current (current-time))
+ (timer (get 'wl-biff 'timer))
+ ;; Compute the time when this timer will run again, next.
+ (next-time (timer-relative-time
+ (list (aref timer 1) (aref timer 2) (aref timer 3))
+ (* 5 (aref timer 4)) 0)))
+ ;; If the activation time is far in the past,
+ ;; skip executions until we reach a time in the future.
+ ;; This avoids a long pause if Emacs has been suspended for hours.
+ (or (> (nth 0 next-time) (nth 0 current))
+ (and (= (nth 0 next-time) (nth 0 current))
+ (> (nth 1 next-time) (nth 1 current)))
+ (and (= (nth 0 next-time) (nth 0 current))
+ (= (nth 1 next-time) (nth 1 current))
+ (> (nth 2 next-time) (nth 2 current)))
+ (progn
+ (timer-set-time timer (timer-next-integral-multiple-of-time
+ current wl-biff-check-interval)
+ wl-biff-check-interval)
+ (timer-activate timer))))))
+ (t
+ (fset 'wl-biff-stop 'ignore)
+ (fset 'wl-biff-start 'ignore)))
+
+(defsubst wl-biff-notify (new-mails notify-minibuf)
+ (when (and (not wl-modeline-biff-status) (> new-mails 0))
+ (run-hooks 'wl-biff-notify-hook))
+ (when (and wl-modeline-biff-status (eq new-mails 0))
+ (run-hooks 'wl-biff-unnotify-hook))
+ (setq wl-modeline-biff-status (> new-mails 0))
+ (force-mode-line-update t)
+ (when notify-minibuf
+ (cond ((zerop new-mails) (message "No mail."))
+ ((= 1 new-mails) (message "You have a new mail."))
+ (t (message "You have %d new mails." new-mails)))))
+
+;; Internal variable.
+(defvar wl-biff-check-folders-running nil)
+
+(defun wl-biff-check-folders ()
+ (interactive)
+ (if wl-biff-check-folders-running
+ (when (interactive-p)
+ (message "Biff process is running."))
+ (setq wl-biff-check-folders-running t)
+ (when (interactive-p)
+ (message "Checking new mails..."))
+ (let ((new-mails 0)
+ (flist (or wl-biff-check-folder-list (list wl-default-folder)))
+ folder)
+ (if (eq (length flist) 1)
+ (wl-biff-check-folder-async (wl-folder-get-elmo-folder
+ (car flist)) (interactive-p))
+ (unwind-protect
+ (while flist
+ (setq folder (wl-folder-get-elmo-folder (car flist))
+ flist (cdr flist))
+ (when (elmo-folder-plugged-p folder)
+ (setq new-mails
+ (+ new-mails
+ (nth 0 (wl-biff-check-folder folder))))))
+ (setq wl-biff-check-folders-running nil)
+ (wl-biff-notify new-mails (interactive-p)))))))
+
+(defun wl-biff-check-folder (folder)
+ (if (eq (elmo-folder-type folder) 'pop3)
+ ;; pop3 biff should share the session.
+ (prog2
+ (elmo-folder-check folder)
+ (wl-folder-check-one-entity (elmo-folder-name-internal folder))
+ (elmo-folder-close folder))
+ (let ((elmo-network-session-name-prefix "BIFF-"))
+ (wl-folder-check-one-entity (elmo-folder-name-internal folder)))))
+
+(defun wl-biff-check-folder-async-callback (diff data)
+ (if (nth 1 data)
+ (with-current-buffer (nth 1 data)
+ (wl-folder-entity-hashtb-set wl-folder-entity-hashtb
+ (nth 0 data)
+ (list (car diff) 0 (cdr diff))
+ (current-buffer))))
+ (setq wl-folder-info-alist-modified t)
+ (setq wl-biff-check-folders-running nil)
+ (sit-for 0)
+ (wl-biff-notify (car diff) (nth 2 data)))
+
+(defun wl-biff-check-folder-async (folder notify-minibuf)
+ (when (elmo-folder-plugged-p folder)
+ (if (and (eq (elmo-folder-type-internal folder) 'imap4)
+ (elmo-folder-use-flag-p folder))
+ ;; Check asynchronously only when IMAP4 and use server diff.
+ (progn
+ (setq elmo-folder-diff-async-callback
+ 'wl-biff-check-folder-async-callback)
+ (setq elmo-folder-diff-async-callback-data
+ (list (elmo-folder-name-internal folder)
+ (get-buffer wl-folder-buffer-name)
+ notify-minibuf))
+ (let ((elmo-network-session-name-prefix "BIFF-"))
+ (elmo-folder-diff-async folder)))
+ (wl-biff-notify (car (wl-biff-check-folder folder))
+ notify-minibuf)
+ (setq wl-biff-check-folders-running nil))))
+
+(if (and (fboundp 'regexp-opt)
+ (not (featurep 'xemacs)))
+ (defalias 'wl-regexp-opt 'regexp-opt)
+ (defun wl-regexp-opt (strings &optional paren)
+ "Return a regexp to match a string in STRINGS.
+Each string should be unique in STRINGS and should not contain any regexps,
+quoted or not. If optional PAREN is non-nil, ensure that the returned regexp
+is enclosed by at least one regexp grouping construct."
+ (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
+ (concat open-paren (mapconcat 'regexp-quote strings "\\|")
+ close-paren))))
+
+(defun wl-expand-newtext (newtext original)
+ (let ((len (length newtext))
+ (pos 0)
+ c expanded beg N did-expand)
+ (while (< pos len)
+ (setq beg pos)
+ (while (and (< pos len)
+ (not (= (aref newtext pos) ?\\)))
+ (setq pos (1+ pos)))
+ (unless (= beg pos)
+ (push (substring newtext beg pos) expanded))
+ (when (< pos len)
+ ;; We hit a \; expand it.
+ (setq did-expand t
+ pos (1+ pos)
+ c (aref newtext pos))
+ (if (not (or (= c ?\&)
+ (and (>= c ?1)
+ (<= c ?9))))
+ ;; \ followed by some character we don't expand.
+ (push (char-to-string c) expanded)
+ ;; \& or \N
+ (if (= c ?\&)
+ (setq N 0)
+ (setq N (- c ?0)))
+ (when (match-beginning N)
+ (push (substring original (match-beginning N) (match-end N))
+ expanded))))
+ (setq pos (1+ pos)))
+ (if did-expand
+ (apply (function concat) (nreverse expanded))
+ newtext)))
+
+(require 'product)
+(product-provide (provide 'wl-util) (require 'wl-version))
;;; wl-util.el ends here
projects / elisp / wanderlust.git / blobdiff