-;;; wl-util.el -- Utility modules for Wanderlust.
+;;; 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).
;;; Code:
;;
-
-(require 'product)
-(product-provide (provide 'wl-util) (require 'wl-version))
+(require 'bytecomp)
(eval-when-compile
(require 'elmo-util))
-(condition-case nil (require 'tm-edit) (error nil))
(condition-case nil (require 'pp) (error nil))
(eval-when-compile
(require 'time-stamp)
- (defalias-maybe 'read-event 'ignore)
(defalias-maybe 'next-command-event 'ignore)
(defalias-maybe 'event-to-character 'ignore)
(defalias-maybe 'key-press-event-p 'ignore)
(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\"
(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 wl-on-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)
-
-;(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)
-
-(defsubst wl-set-string-width (width string)
- (elmo-set-work-buf
- (elmo-set-buffer-multibyte default-enable-multibyte-characters)
- (insert string)
- (if (> (current-column) width)
- (if (> (move-to-column width) width)
- (progn
- (condition-case nil ; ignore error
- (backward-char 1)
- (error))
- (concat (buffer-substring (point-min) (point)) " "))
- (buffer-substring (point-min) (point)))
- (if (= (current-column) width)
+;;(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-set-hash-val 'elmo-set-hash-val)
+;;(make-obsolete 'wl-set-hash-val 'elmo-set-hash-val)
+
+(defsubst wl-set-string-width (width string &optional padding ignore-invalid)
+ "Make a new string which have specified WIDTH and content of STRING.
+`wl-invalid-character-message' is used when invalid character is contained.
+If WIDTH is negative number, padding chars are added to the head and
+otherwise, padding chars are added to the tail of the string.
+The optional 3rd arg PADDING, if non-nil, specifies a padding character
+to add the result instead of white space.
+If optional 4th argument is non-nil, don't use `wl-invalid-character-message'
+even when invalid character is contained."
+ (static-cond
+ ((and (fboundp 'string-width) (fboundp 'truncate-string-to-width)
+ (not (featurep 'xemacs)))
+ (if (> (string-width string) (abs width))
+ (setq string (truncate-string-to-width string (abs width))))
+ (if (= (string-width string) (abs width))
+ string
+ (when (and (not ignore-invalid)
+ (< (abs width) (string-width string)))
+ (setq string
+ (truncate-string-to-width wl-invalid-character-message
+ (abs width))))
+ (let ((paddings (make-string
+ (max 0 (- (abs width) (string-width string)))
+ (or padding ?\ ))))
+ (if (< width 0)
+ (concat paddings string)
+ (concat string paddings)))))
+ (t
+ (elmo-set-work-buf
+ (elmo-set-buffer-multibyte default-enable-multibyte-characters)
+ (insert string)
+ (when (> (current-column) (abs width))
+ (when (> (move-to-column (abs width)) (abs width))
+ (condition-case nil ; ignore error
+ (backward-char 1)
+ (error)))
+ (setq string (buffer-substring (point-min) (point))))
+ (if (= (current-column) (abs width))
string
- (concat string
- (format (format "%%%ds"
- (- width (current-column)))
- " "))))))
-
-(defun wl-display-bytes (num)
- (let (result remain)
- (cond
- ((> (setq result (/ num 1000000)) 0)
- (setq remain (% num 1000000))
- (if (> remain 400000)
- (setq result (+ 1 result)))
- (format "%dM" result))
- ((> (setq result (/ num 1000)) 0)
- (setq remain (% num 1000))
- (if (> remain 400)
- (setq result (+ 1 result)))
- (format "%dK" result))
- (t (format "%dB" result)))))
+ (let ((paddings (make-string (- (abs width) (current-column))
+ (or padding ?\ ))))
+ (if (< width 0)
+ (concat paddings string)
+ (concat string paddings))))))))
(defun wl-mode-line-buffer-identification (&optional id)
(let ((priorities '(biff plug title)))
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)
(defmacro wl-as-coding-system (coding-system &rest body)
(` (let ((file-coding-system-for-read (, coding-system))
(file-coding-system (, coding-system)))
- (,@ body))))
- (if wl-on-nemacs
- (defmacro wl-as-coding-system (coding-system &rest body)
- (` (let ((default-kanji-fileio-code (, coding-system))
- (kanji-fileio-code (, coding-system))
- kanji-expected-code)
- (,@ body))))))))
+ (,@ body)))))))
(defmacro wl-as-mime-charset (mime-charset &rest body)
(` (wl-as-coding-system (mime-charset-to-coding-system (, mime-charset))
(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,]+\\)"))
- 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 ()
alist)
(defun wl-inverse-alist (keys alist)
- "Inverse ALIST, copying. Return an association list represents
-the inverse mapping of ALIST, from objects to KEYS.
+ "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
"^nntp://\\([^:/]*\\):?\\([0-9]*\\)/\\([^/]*\\)/\\([0-9]*\\).*$" url)
(progn
(if (eq (length (setq fld-name
- (elmo-match-string 3 url))) 0)
- (setq fld-name nil))
+ (elmo-match-string 3 url))) 0)
+ (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))
+ (elmo-match-string 1 url))) 0)
+ (setq server elmo-nntp-default-server))
(setq folder (concat "-" fld-name "@" server ":" port))
(if (eq (length (setq msg
(elmo-match-string 4 url))) 0)
(defmacro wl-current-message-buffer ()
(` (save-excursion
(if (buffer-live-p wl-current-summary-buffer)
- (set-buffer wl-current-summary-buffer))
- wl-message-buf-name)))
+ (set-buffer wl-current-summary-buffer))
+ wl-message-buffer)))
(defmacro wl-kill-buffers (regexp)
(` (mapcar (function
(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))
- timezone-months-assoc))
- (string-to-int (substring date 8 10))
- (substring date 11 19)))))
-
(defun wl-collect-summary ()
(let (result)
(mapcar
(buffer-list))
result))
+(defun wl-collect-draft ()
+ (let ((draft-regexp (concat
+ "^" (regexp-quote
+ (elmo-localdir-folder-directory-internal
+ (wl-folder-get-elmo-folder wl-draft-folder)))))
+ result buf)
+ (mapcar
+ (function (lambda (x)
+ (if (and
+ (setq buf (with-current-buffer x
+ wl-draft-buffer-file-name))
+ (string-match draft-regexp buf))
+ (setq result (nconc result (list x))))))
+ (buffer-list))
+ result))
+
(static-if (fboundp 'read-directory-name)
- (defalias 'wl-read-directory-name 'read-directory-name)
+ (defun wl-read-directory-name (prompt dir)
+ (read-directory-name prompt dir dir))
(defun wl-read-directory-name (prompt dir)
(let ((dir (read-file-name prompt dir)))
(unless (file-directory-p dir)
;; Append the name of the message interface, because while the
;; generated ID is unique to this newsreader, other newsreaders
;; might otherwise generate the same ID via another algorithm.
- ".wl")))
+ wl-unique-id-suffix)))
+(defvar wl-message-id-function 'wl-draft-make-message-id-string)
(defun wl-draft-make-message-id-string ()
- (concat "<" (wl-unique-id) "@"
- (or wl-message-id-domain
- (if wl-local-domain
- (concat (system-name) "." wl-local-domain)
- (system-name)))
- ">"))
+ "Return Message-ID field value."
+ (concat "<" (wl-unique-id)
+ (let (from user domain)
+ (if (and wl-message-id-use-wl-from
+ (progn
+ (setq from (wl-address-header-extract-address wl-from))
+ (and (string-match "^\\(.*\\)@\\(.*\\)$" from)
+ (setq user (match-string 1 from))
+ (setq domain (match-string 2 from)))))
+ (format "%%%s@%s>" user domain)
+ (format "@%s>"
+ (or wl-message-id-domain
+ (if wl-local-domain
+ (concat (system-name) "." wl-local-domain)
+ (system-name))))))))
;;; 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 ()
- (message "Initializing ...")
+ "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))
;;;
(start-itimer wl-biff-timer-name 'wl-biff-check-folders
wl-biff-check-interval wl-biff-check-interval))))
- ((condition-case nil (require 'timer) (error nil));; FSFmacs 19+
+ ((and (condition-case nil (require 'timer) (error nil));; FSFmacs 19+
+ (fboundp 'timer-activate))
(defun wl-biff-stop ()
- (put 'wl-biff 'timer nil))
+ (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)
- (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))))
+ (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.
(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."))
- ((eq 1 new-mails) (message "You have a new mail."))
+ ((= 1 new-mails) (message "You have a new mail."))
(t (message "You have %d new mails." new-mails)))))
;; Internal variable.
(message "Checking new mails..."))
(let ((new-mails 0)
(flist (or wl-biff-check-folder-list (list wl-default-folder)))
- (elmo-network-session-name-prefix "BIFF-")
folder)
(if (eq (length flist) 1)
- (wl-biff-check-folder-async (car flist) (interactive-p))
+ (wl-biff-check-folder-async (wl-folder-get-elmo-folder
+ (car flist) 'biff) (interactive-p))
(unwind-protect
(while flist
- (setq folder (car 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-folder-check-one-entity folder))))))
+ (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-internal folder) 'pop3)
+ (unless (elmo-pop3-get-session folder 'any-exists)
+ (wl-folder-check-one-entity (elmo-folder-name-internal folder)
+ 'biff))
+ (wl-folder-check-one-entity (elmo-folder-name-internal folder)
+ 'biff)))
+
(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))
+ (wl-folder-entity-hashtb-set wl-folder-entity-hashtb
+ (nth 0 data)
+ (list (nth 0 diff)
+ (- (nth 1 diff) (nth 0 diff))
+ (nth 2 diff))
(current-buffer))))
(setq wl-folder-info-alist-modified t)
(setq wl-biff-check-folders-running nil)
(defun wl-biff-check-folder-async (folder notify-minibuf)
(when (elmo-folder-plugged-p folder)
- (if (and (eq (elmo-folder-get-type folder) 'imap4)
- (wl-folder-use-server-diff-p folder))
+ (elmo-folder-set-biff-internal folder t)
+ (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 folder (get-buffer wl-folder-buffer-name)
+ (list (elmo-folder-name-internal folder)
+ (get-buffer wl-folder-buffer-name)
notify-minibuf))
(elmo-folder-diff-async folder))
- (wl-biff-notify (car (wl-folder-check-one-entity folder))
- notify-minibuf)
- (setq wl-biff-check-folders-running nil))))
+ (unwind-protect
+ (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))))
+
+(defalias 'wl-expand-newtext 'elmo-expand-newtext)
+
+(defun wl-region-exists-p ()
+ "Return non-nil if a region exists on current buffer."
+ (static-if (featurep 'xemacs)
+ (and zmacs-regions zmacs-region-active-p)
+ (and transient-mark-mode mark-active)))
+
+(defvar wl-line-string)
+(defun wl-line-parse-format (format spec-alist)
+ "Make a formatter from FORMAT and SPEC-ALIST."
+ (let (f spec specs stack)
+ (setq f
+ (with-temp-buffer
+ (insert format)
+ (goto-char (point-min))
+ (while (search-forward "%" nil t)
+ (cond
+ ((looking-at "%")
+ (goto-char (match-end 0)))
+ ((looking-at "\\(-?\\(0?\\)[0-9]*\\)\\([^0-9]\\)")
+ (cond
+ ((string= (match-string 3) "(")
+ (if (zerop (length (match-string 1)))
+ (error "No number specification for %%( line format"))
+ (push (list
+ (match-beginning 0) ; start
+ (match-end 0) ; start-content
+ (string-to-number
+ (match-string 1)) ; width
+ specs) ; specs
+ stack)
+ (setq specs nil))
+ ((string= (match-string 3) ")")
+ (let ((entry (pop stack))
+ form)
+ (unless entry
+ (error
+ "No matching %%( parenthesis in summary line format"))
+ (goto-char (car entry)) ; start
+ (setq form (buffer-substring (nth 1 entry) ; start-content
+ (- (match-beginning 0) 1)))
+ (delete-region (car entry) (match-end 0))
+ (insert "s")
+ (setq specs
+ (append
+ (nth 3 entry)
+ (list (list 'wl-set-string-width (nth 2 entry)
+ (append
+ (list 'format form)
+ specs)))))))
+ (t
+ (setq spec
+ (if (setq spec (assq (string-to-char (match-string 3))
+ spec-alist))
+ (nth 1 spec)
+ (match-string 3)))
+ (unless (string= "" (match-string 1))
+ (setq spec (list 'wl-set-string-width
+ (string-to-number (match-string 1))
+ spec
+ (unless (string= "" (match-string 2))
+ (string-to-char (match-string 2))))))
+ (replace-match "s" 'fixed)
+ (setq specs (append specs
+ (list
+ (list
+ 'setq 'wl-line-string
+ spec)))))))))
+ (buffer-string)))
+ (append (list 'format f) specs)))
+
+(defmacro wl-line-formatter-setup (formatter format alist)
+ (` (let (byte-compile-warnings)
+ (setq (, formatter)
+ (byte-compile
+ (list 'lambda ()
+ (wl-line-parse-format (, format) (, alist)))))
+ (when (get-buffer "*Compile-Log*")
+ (bury-buffer "*Compile-Log*"))
+ (when (get-buffer "*Compile-Log-Show*")
+ (bury-buffer "*Compile-Log-Show*")))))
+
+(require 'product)
+(product-provide (provide 'wl-util) (require 'wl-version))
;;; wl-util.el ends here