;;; Code:
;;
(require 'bytecomp)
-(eval-when-compile
- (require 'elmo-util))
+(require 'elmo-util)
+(require 'elmo-flag)
+(require 'wl-vars)
+(eval-when-compile (require 'elmo-pop3))
+(eval-when-compile (require 'cl))
+(eval-when-compile (require 'static))
(condition-case nil (require 'pp) (error nil))
(defalias 'wl-string-assoc 'elmo-string-assoc)
(defalias 'wl-string-rassoc 'elmo-string-rassoc)
-(defun wl-parse-addresses (string)
- (if (null string)
- ()
- (elmo-set-work-buf
- ;;(unwind-protect
- (let (list start s char)
- (insert string)
- (goto-char (point-min))
- (skip-chars-forward "\t\f\n\r ")
- (setq start (point))
- (while (not (eobp))
- (skip-chars-forward "^\"\\,(")
- (setq char (following-char))
- (cond ((= char ?\\)
- (forward-char 1)
- (if (not (eobp))
- (forward-char 1)))
- ((= char ?,)
- (setq s (buffer-substring start (point)))
- (if (or (null (string-match "^[\t\f\n\r ]+$" s))
- (not (string= s "")))
- (setq list (cons s list)))
- (skip-chars-forward ",\t\f\n\r ")
- (setq start (point)))
- ((= char ?\")
- (re-search-forward "[^\\]\"" nil 0))
- ((= char ?\()
- (let ((parens 1))
- (forward-char 1)
- (while (and (not (eobp)) (not (zerop parens)))
- (re-search-forward "[()]" nil 0)
- (cond ((or (eobp)
- (= (char-after (- (point) 2)) ?\\)))
- ((= (preceding-char) ?\()
- (setq parens (1+ parens)))
- (t
- (setq parens (1- parens)))))))))
- (setq s (buffer-substring start (point)))
- (if (and (null (string-match "^[\t\f\n\r ]+$" s))
- (not (string= s "")))
- (setq list (cons s list)))
- (nreverse list)) ; jwz: fixed order
- )))
+(defalias 'wl-parse-addresses 'elmo-parse-addresses)
(defun wl-append-element (list element)
(if element
(cmd (if (featurep 'xemacs)
(event-to-character last-command-event)
(string-to-char (format "%s" (this-command-keys))))))
- (message mes-string)
+ (message "%s" mes-string)
(setq key (car (setq keve (wl-read-event-char))))
- (if (or (equal key ?\ )
+ (if (or (equal key (string-to-char " "))
(and cmd
(equal key cmd)))
(progn
(funcall func))
(wl-push (cdr keve) unread-command-events))))
-;(defalias 'wl-make-hash 'elmo-make-hash)
-;;(make-obsolete 'wl-make-hash 'elmo-make-hash)
+(defun wl-require-update-all-folder-p (name)
+ "Return non-nil if NAME is draft or queue folder."
+ (or (string= name wl-draft-folder)
+ (string= name wl-queue-folder)))
+
+;;;(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-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 &optional padding)
+(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."
+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)))
(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 ?\ ))))
+ (or padding (string-to-char " ")))))
(if (< width 0)
(concat paddings string)
(concat string paddings)))))
(t
(elmo-set-work-buf
- (elmo-set-buffer-multibyte default-enable-multibyte-characters)
+ (set-buffer-multibyte default-enable-multibyte-characters)
(insert string)
(when (> (current-column) (abs width))
(when (> (move-to-column (abs width)) (abs width))
(if (= (current-column) (abs width))
string
(let ((paddings (make-string (- (abs width) (current-column))
- (or padding ?\ ))))
+ (or padding (string-to-char " ")))))
(if (< width 0)
(concat paddings string)
(concat string paddings))))))))
value pair)
(while alist
(setq pair (car alist))
- (if (string-match (car pair) folder)
- (cond ((eq match 'all)
- (setq value (append value (list (cdr pair)))))
- ((eq match 'all-list)
- (setq value (append value (cdr pair))))
- ((not match)
- (throw 'found (cdr pair)))))
+ (if (and (eq match 'function)
+ (functionp (car pair)))
+ (when (funcall (car pair) folder)
+ (throw 'found (cdr pair)))
+ (if (string-match (car pair) folder)
+ (cond ((eq match 'all)
+ (setq value (append value (list (cdr pair)))))
+ ((eq match 'all-list)
+ (setq value (append value (cdr pair))))
+ ((or (not match) (eq match 'function))
+ (throw 'found (cdr pair))))))
(setq alist (cdr alist)))
value)))
-(defmacro wl-match-string (pos string)
+(defun wl-match-string (pos string)
"Substring POSth matched STRING."
- (` (substring (, string) (match-beginning (, pos)) (match-end (, pos)))))
+ (substring string (match-beginning pos) (match-end pos)))
-(defmacro wl-match-buffer (pos)
+(defun wl-match-buffer (pos)
"Substring POSth matched from the current buffer."
- (` (buffer-substring-no-properties
- (match-beginning (, pos)) (match-end (, pos)))))
+ (buffer-substring-no-properties
+ (match-beginning pos) (match-end pos)))
(put 'wl-as-coding-system 'lisp-indent-function 1)
(put 'wl-as-mime-charset 'lisp-indent-function 1)
(eval-and-compile
- (if wl-on-mule3
- (defmacro wl-as-coding-system (coding-system &rest body)
- (` (let ((coding-system-for-read (, coding-system))
- (coding-system-for-write (, coding-system)))
- (,@ body))))
- (if wl-on-mule
- (defmacro wl-as-coding-system (coding-system &rest body)
- (` (let ((file-coding-system-for-read (, coding-system))
- (file-coding-system (, coding-system)))
- (,@ body)))))))
+ (cond
+ (wl-on-mule3
+ (defmacro wl-as-coding-system (coding-system &rest body)
+ `(let ((coding-system-for-read ,coding-system)
+ (coding-system-for-write ,coding-system))
+ ,@body)))
+ (wl-on-mule
+ (defmacro wl-as-coding-system (coding-system &rest body)
+ `(let ((file-coding-system-for-read ,coding-system)
+ (file-coding-system ,coding-system))
+ ,@body)))
+ (t
+ (defmacro wl-as-coding-system (coding-system &rest body)
+ `(progn ,@body)))))
(defmacro wl-as-mime-charset (mime-charset &rest body)
- (` (wl-as-coding-system (mime-charset-to-coding-system (, mime-charset))
- (,@ body))))
+ `(wl-as-coding-system (mime-charset-to-coding-system ,mime-charset)
+ ,@body))
(defalias 'wl-string 'elmo-string)
(make-obsolete 'wl-string 'elmo-string)
-;; Check if active region exists or not.
-(if (boundp 'mark-active)
- (defmacro wl-region-exists-p ()
- 'mark-active)
- (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.
(setq loop (- loop 1)))
ret-val))
-(defun wl-list-diff (list1 list2)
- "Return a list of elements of LIST1 that do not appear in LIST2."
- (let ((list1 (copy-sequence list1)))
- (while list2
- (setq list1 (delq (car list2) list1))
- (setq list2 (cdr list2)))
- list1))
-
(defun wl-append-assoc-list (item value alist)
"make assoc list '((item1 value1-1 value1-2 ...)) (item2 value2-1 ...)))"
(let ((entry (assoc item alist)))
(setq keys (cdr keys)))
alist)
+(defun wl-filter-associations (keys alist)
+ (let (entry result)
+ (while keys
+ (when (setq entry (assq (car keys) alist))
+ (setq result (cons entry result)))
+ (setq keys (cdr keys)))
+ result))
+
(defun wl-inverse-alist (keys alist)
"Inverse ALIST, copying.
Return an association list represents the inverse mapping of ALIST,
(setq keys (cdr keys)))
result))
-(eval-when-compile
- (require 'static))
(static-unless (fboundp 'pp)
(defvar pp-escape-newlines t)
(defun pp (object &optional stream)
(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))))
- (timezone-absolute-from-gregorian
- (nth 1 dat) (nth 2 dat) (car dat))))
-
(defun wl-url-news (url &rest args)
(interactive "sURL: ")
(if (string-match "^news:\\(.*\\)$" url)
(setq fld-name nil))
(if (eq (length (setq port
(elmo-match-string 2 url))) 0)
- (setq port (int-to-string elmo-nntp-default-port)))
+ (setq port (number-to-string elmo-nntp-default-port)))
(if (eq (length (setq server
(elmo-match-string 1 url))) 0)
(setq server elmo-nntp-default-server))
folder nil nil nil t)
(wl-summary-goto-folder-subr
folder 'update nil nil t)
- (goto-char (point-min))
- (re-search-forward (concat "^ *" msg) nil t)
+ (wl-summary-jump-to-msg (string-to-number msg))
(wl-summary-redisplay)))
(message "Not a nntp: url."))))
(defmacro wl-concat-list (list separator)
- (` (mapconcat 'identity (delete "" (delq nil (, list))) (, separator))))
-
-(defmacro wl-current-message-buffer ()
- (` (save-excursion
- (if (buffer-live-p wl-current-summary-buffer)
- (set-buffer wl-current-summary-buffer))
- wl-message-buffer)))
-
-(defmacro wl-kill-buffers (regexp)
- (` (mapcar (function
- (lambda (x)
- (if (and (buffer-name x)
- (string-match (, regexp) (buffer-name x)))
- (and (get-buffer x)
- (kill-buffer x)))))
- (buffer-list))))
+ `(mapconcat 'identity (delete "" (delq nil ,list)) ,separator))
+
+(defun wl-current-message-buffer ()
+ (when (buffer-live-p wl-current-summary-buffer)
+ (with-current-buffer wl-current-summary-buffer
+ (or wl-message-buffer
+ (and (wl-summary-message-number)
+ (wl-message-buffer-display
+ wl-summary-buffer-elmo-folder
+ (wl-summary-message-number)
+ wl-summary-buffer-display-mime-mode
+ nil nil))))))
+
+(defun wl-kill-buffers (regexp)
+ (mapc
+ (lambda (x)
+ (if (and (buffer-name x)
+ (string-match regexp (buffer-name x)))
+ (and (get-buffer x)
+ (kill-buffer x))))
+ (buffer-list)))
(defun wl-collect-summary ()
(let (result)
- (mapcar
- (function (lambda (x)
- (if (and (string-match "^Summary"
- (buffer-name x))
- (save-excursion
- (set-buffer x)
- (equal major-mode 'wl-summary-mode)))
- (setq result (nconc result (list x))))))
+ (mapc
+ (lambda (x)
+ (if (and (string-match "^Summary"
+ (buffer-name x))
+ (with-current-buffer x
+ (eq major-mode 'wl-summary-mode)))
+ (setq result (nconc result (list x)))))
(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))
+ (let ((draft-regexp (concat "^" (regexp-quote wl-draft-folder)))
+ result)
+ (dolist (buffer (buffer-list))
+ (when (with-current-buffer buffer
+ (and (eq major-mode 'wl-draft-mode)
+ (buffer-name)
+ (string-match draft-regexp (buffer-name))))
+ (setq result (cons buffer result))))
+ (nreverse result)))
+
+(defvar wl-inhibit-save-drafts nil)
+(defvar wl-disable-auto-save nil)
+(make-variable-buffer-local 'wl-disable-auto-save)
+
+(defun wl-save-drafts ()
+ "Save all drafts. Return nil if there is no draft buffer."
+ (if wl-inhibit-save-drafts
+ 'inhibited
+ (let ((wl-inhibit-save-drafts t)
+ (msg (current-message))
+ (buffers (wl-collect-draft)))
+ (save-excursion
+ (dolist (buffer buffers)
+ (set-buffer buffer)
+ (when (and (not wl-disable-auto-save)
+ (buffer-modified-p))
+ (wl-draft-save))))
+ (message "%s" (or msg ""))
+ buffers)))
(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)
(static-if (fboundp 'local-variable-p)
(defalias 'wl-local-variable-p 'local-variable-p)
(defmacro wl-local-variable-p (symbol &optional buffer)
- (` (if (assq (, symbol) (buffer-local-variables (, buffer)))
- t))))
+ `(if (assq ,symbol (buffer-local-variables ,buffer))
+ t)))
(defun wl-number-base36 (num len)
(if (if (< len 0)
("Jul" . "07") ("Aug" . "08")
("Sep" . "09") ("Oct" . "10")
("Nov" . "11") ("Dec" . "12"))))))
- (list (string-to-int (concat (nth 6 cts) m
- (substring (nth 2 cts) 0 1)))
- (string-to-int (concat (substring (nth 2 cts) 1)
- (nth 4 cts) (nth 5 cts)
- (nth 6 cts))))))))
+ (list (string-to-number (concat (nth 6 cts) m
+ (substring (nth 2 cts) 0 1)))
+ (string-to-number (concat (substring (nth 2 cts) 1)
+ (nth 4 cts) (nth 5 cts)
+ (nth 6 cts))))))))
(concat
(if (memq system-type '(ms-dos emx vax-vms))
(let ((user (downcase (user-login-name))))
(defvar wl-load-profile-function 'wl-local-load-profile)
(defun wl-local-load-profile ()
"Load `wl-init-file'."
- (message "Initializing ...")
+ (message "Initializing...")
(load wl-init-file 'noerror 'nomessage))
(defun wl-load-profile ()
;;;
-(defmacro wl-count-lines ()
- (` (save-excursion
- (beginning-of-line)
- (count-lines 1 (point)))))
+(defsubst wl-count-lines ()
+ (count-lines 1 (point-at-bol)))
(defun wl-horizontal-recenter ()
"Recenter the current buffer horizontally."
(set-window-hscroll (get-buffer-window (current-buffer) t) 0))
max))))
+;; Draft auto-save
+(defun wl-auto-save-drafts ()
+ (unless (wl-save-drafts)
+ (wl-stop-save-drafts)))
+
+(static-cond
+ (wl-on-xemacs
+ (defvar wl-save-drafts-timer-name "wl-save-drafts")
+
+ (defun wl-start-save-drafts ()
+ (when (numberp wl-auto-save-drafts-interval)
+ (unless (get-itimer wl-save-drafts-timer-name)
+ (start-itimer wl-save-drafts-timer-name
+ 'wl-auto-save-drafts
+ wl-auto-save-drafts-interval
+ wl-auto-save-drafts-interval
+ t))))
+
+ (defun wl-stop-save-drafts ()
+ (when (get-itimer wl-save-drafts-timer-name)
+ (delete-itimer wl-save-drafts-timer-name))))
+ (t
+ (defun wl-start-save-drafts ()
+ (when (numberp wl-auto-save-drafts-interval)
+ (require 'timer)
+ (if (get 'wl-save-drafts 'timer)
+ (progn
+ (timer-set-idle-time (get 'wl-save-drafts 'timer)
+ wl-auto-save-drafts-interval t)
+ (timer-activate-when-idle (get 'wl-save-drafts 'timer)))
+ (put 'wl-save-drafts 'timer
+ (run-with-idle-timer
+ wl-auto-save-drafts-interval t 'wl-auto-save-drafts)))))
+
+ (defun wl-stop-save-drafts ()
+ (when (get 'wl-save-drafts 'timer)
+ (cancel-timer (get 'wl-save-drafts 'timer))))))
+
+(defun wl-set-auto-save-draft (&optional arg)
+ (interactive "P")
+ (unless (setq wl-disable-auto-save
+ (cond
+ ((null arg) (not wl-disable-auto-save))
+ ((< (prefix-numeric-value arg) 0) t)
+ (t nil)))
+ (wl-start-save-drafts))
+ (when (interactive-p)
+ (message "Auto save is %s (in this buffer)"
+ (if wl-disable-auto-save "disabled" "enabled"))))
+
;; Biff
(static-cond
(wl-on-xemacs
(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))
+ wl-biff-check-interval wl-biff-check-interval
+ wl-biff-use-idle-timer))))
+ (t
(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
+ (if wl-biff-use-idle-timer
+ (if (get 'wl-biff 'timer)
+ (progn (timer-set-idle-time (get 'wl-biff 'timer)
+ wl-biff-check-interval t)
+ (timer-activate-when-idle (get 'wl-biff 'timer)))
+ (put 'wl-biff 'timer
+ (run-with-idle-timer
+ wl-biff-check-interval t 'wl-biff-event-handler)))
+ (if (get 'wl-biff 'timer)
+ (progn
+ (timer-set-time (get 'wl-biff 'timer)
(timer-next-integral-multiple-of-time
(current-time) wl-biff-check-interval)
- wl-biff-check-interval
- 'wl-biff-event-handler)))))
+ wl-biff-check-interval)
+ (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.
(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)))
+ (timer-activate timer)))))))
(defsubst wl-biff-notify (new-mails notify-minibuf)
(when (and (not wl-modeline-biff-status) (> new-mails 0))
(while flist
(setq folder (wl-folder-get-elmo-folder (car flist))
flist (cdr flist))
- (when (elmo-folder-plugged-p folder)
+ (elmo-folder-set-biff-internal folder t)
+ (when (and (elmo-folder-plugged-p folder)
+ (elmo-folder-exists-p folder))
(setq new-mails
(+ new-mails
(nth 0 (wl-biff-check-folder folder))))))
(defun wl-biff-check-folder (folder)
(if (eq (elmo-folder-type-internal folder) 'pop3)
- (unless (elmo-pop3-get-session folder 'if-exists)
+ (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)
(wl-biff-notify (car diff) (nth 2 data)))
(defun wl-biff-check-folder-async (folder notify-minibuf)
- (when (elmo-folder-plugged-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 (elmo-folder-name-internal folder)
- (get-buffer wl-folder-buffer-name)
- notify-minibuf))
- (elmo-folder-diff-async folder))
- (unwind-protect
- (wl-biff-notify (car (wl-biff-check-folder folder))
- notify-minibuf)
- (setq wl-biff-check-folders-running nil)))))
+ (if (and (elmo-folder-plugged-p folder)
+ (wl-folder-entity-exists-p (elmo-folder-name-internal folder)))
+ (progn
+ (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 (elmo-folder-name-internal folder)
+ (get-buffer wl-folder-buffer-name)
+ notify-minibuf))
+ (elmo-folder-diff-async folder))
+ (unwind-protect
+ (wl-biff-notify (car (wl-biff-check-folder folder))
+ notify-minibuf)
+ (setq wl-biff-check-folders-running nil))))
+ (setq wl-biff-check-folders-running nil)))
(if (and (fboundp 'regexp-opt)
(not (featurep 'xemacs)))
(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)))
+(defalias 'wl-expand-newtext 'elmo-expand-newtext)
+(defalias 'wl-regexp-opt 'elmo-regexp-opt)
+
+(defun wl-region-exists-p ()
+ "Return non-nil if a region exists on current buffer."
+ (static-if (featurep 'xemacs)
+ (region-active-p)
+ (and transient-mark-mode mark-active)))
+
+(defun wl-deactivate-region ()
+ "Deactivate region on current buffer"
+ (static-if (not (featurep 'xemacs))
+ (setq mark-active nil)))
(defvar wl-line-string)
(defun wl-line-parse-format (format spec-alist)
(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*")))))
+ `(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*"))))
+
+(defsubst wl-copy-local-variables (src dst local-variables)
+ "Copy value of LOCAL-VARIABLES from SRC buffer to DST buffer."
+ (with-current-buffer dst
+ (dolist (variable local-variables)
+ (set (make-local-variable variable)
+ (with-current-buffer src
+ (symbol-value variable))))))
+
+;;; Search Condition
+(defun wl-search-condition-fields ()
+ (let ((denial-fields
+ (nconc (mapcar 'capitalize elmo-msgdb-extra-fields)
+ (mapcar 'capitalize wl-additional-search-condition-fields)
+ '("Flag" "Since" "Before"
+ "From" "Subject" "To" "Cc" "Body" "ToCc"
+ "Larger" "Smaller"))))
+ (append '("Last" "First")
+ denial-fields
+ (mapcar (lambda (f) (concat "!" f))
+ denial-fields))))
+
+(defun wl-read-search-condition (default)
+ "Read search condition string interactively."
+ (wl-read-search-condition-internal "Search by" default))
+
+(defun wl-read-search-condition-internal (prompt default &optional paren)
+ (let* ((completion-ignore-case t)
+ (field (completing-read
+ (format "%s (%s): " prompt default)
+ (mapcar #'list
+ (append '("AND" "OR") (wl-search-condition-fields)))))
+ value)
+ (setq field (if (string= field "")
+ (setq field default)
+ field))
+ (cond
+ ((or (string= field "AND") (string= field "OR"))
+ (concat (if paren "(" "")
+ (wl-read-search-condition-internal
+ (concat field "(1) Search by") default 'paren)
+ (if (string= field "AND") "&" "|")
+ (wl-read-search-condition-internal
+ (concat field "(2) Search by") default 'paren)
+ (if paren ")" "")))
+ ((string-match "Since\\|Before" field)
+ (let ((default (format-time-string "%Y-%m-%d")))
+ (setq value (completing-read
+ (format "Value for '%s' [%s]: " field default)
+ (mapcar
+ (lambda (x)
+ (list (format "%s" (car x))))
+ elmo-date-descriptions)))
+ (concat (downcase field) ":"
+ (if (equal value "") default value))))
+ ((string-match "!?Flag" field)
+ (while (null value)
+ (setq value (downcase
+ (completing-read
+ (format "Value for '%s': " field)
+ (mapcar (lambda (f) (list (capitalize (symbol-name f))))
+ (elmo-uniq-list
+ (append
+ '(unread answered forwarded digest any)
+ (copy-sequence elmo-global-flags))
+ #'delq)))))
+ (unless (elmo-flag-valid-p value)
+ (message "Invalid char in `%s'" value)
+ (setq value nil)
+ (sit-for 1)))
+ (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
+ value)
+ (setq value (prin1-to-string value)))
+ (concat (downcase field) ":" value))
+ (t
+ (setq value (read-from-minibuffer (format "Value for '%s': " field)))
+ (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
+ value)
+ (setq value (prin1-to-string value)))
+ (concat (downcase field) ":" value)))))
+
+(defun wl-y-or-n-p-with-scroll (prompt &optional scroll-by-SPC)
+ (let ((prompt (concat prompt (if scroll-by-SPC
+ "<y/n/SPC(down)/BS(up)> "
+ "<y/n/j(down)/k(up)> "))))
+ (catch 'done
+ (while t
+ (discard-input)
+ (case (let ((cursor-in-echo-area t))
+ (cdr (wl-read-event-char prompt)))
+ ((?y ?Y)
+ (throw 'done t))
+ ((string-to-char " ")
+ (if scroll-by-SPC
+ (ignore-errors (scroll-up))
+ (throw 'done t)))
+ ((?v ?j ?J next)
+ (ignore-errors (scroll-up)))
+ ((?^ ?k ?K prior backspace)
+ (ignore-errors (scroll-down)))
+ (t
+ (throw 'done nil)))))))
+
+(defun wl-find-region (beg-regexp end-regexp)
+ (if (or (re-search-forward end-regexp nil t)
+ (re-search-backward end-regexp nil t))
+ (let ((end (match-end 0))
+ (beg (re-search-backward beg-regexp nil t)))
+ (if beg
+ (cons beg end)))))
+
+(defun wl-simple-display-progress (label action current total)
+ (message "%s... %d%%"
+ action
+ (if (> total 0) (floor (* (/ current (float total)) 100)) 0)))
+
+(when (fboundp 'progress-feedback-with-label)
+ (defun wl-display-progress-with-gauge (label action current total)
+ (progress-feedback-with-label
+ label
+ "%s..."
+ (if (> total 0) (floor (* (/ current (float total)) 100)) 0)
+ action)))
+
+(defun wl-progress-callback-function (label action current total)
+ (case current
+ (query
+ (let ((threshold (if (consp wl-display-progress-threshold)
+ (cdr (or (assq label wl-display-progress-threshold)
+ (assq t wl-display-progress-threshold)))
+ wl-display-progress-threshold)))
+ (and threshold
+ (>= total threshold))))
+ (start
+ (message "%s..." action))
+ (done
+ (message "%s...done" action))
+ (t
+ (when wl-display-progress-function
+ (funcall wl-display-progress-function label action current total)))))
+
+;; read multiple strings with completion
+(defun wl-completing-read-multiple-1 (prompt
+ table
+ &optional predicate
+ require-match initial-input
+ hist def inherit-input-method)
+ "Read multiple strings in the minibuffer"
+ (split-string
+ (completing-read prompt table predicate nil
+ initial-input hist def inherit-input-method)
+ ","))
+
+(static-when (fboundp 'completing-read-multiple)
+ (eval-when-compile
+ (require 'crm))
+ (defun wl-completing-read-multiple-2 (prompt
+ table
+ &optional predicate
+ require-match initial-input
+ hist def inherit-input-method)
+ "Read multiple strings in the minibuffer"
+ (let ((ret (completing-read-multiple prompt table predicate
+ require-match initial-input
+ hist def inherit-input-method)))
+ (if (and def (equal ret '("")))
+ (split-string def crm-separator)
+ ret))))
+
+(static-cond
+ ((not (fboundp 'completing-read-multiple))
+ (defalias 'wl-completing-read-multiple 'wl-completing-read-multiple-1))
+ ((< emacs-major-version 22)
+ (defun wl-completing-read-multiple (prompt
+ table
+ &optional predicate
+ require-match initial-input
+ hist def inherit-input-method)
+ "Read multiple strings in the minibuffer"
+ (if require-match
+ (wl-completing-read-multiple-1 prompt table predicate
+ nil initial-input
+ hist def inherit-input-method)
+ (wl-completing-read-multiple-2 prompt table predicate
+ nil initial-input
+ hist def inherit-input-method))))
+ (t
+ (defalias 'wl-completing-read-multiple 'completing-read-multiple)))
+
+
+(cond
+ ((fboundp 'shell-command-read-minibuffer)
+ (defun wl-read-shell-command (prompt &optional
+ initial-contents keymap read hist)
+ (shell-command-read-minibuffer prompt default-directory
+ initial-contents keymap read hist)))
+ (t
+ (defalias 'wl-read-shell-command 'read-from-minibuffer)))
(require 'product)
(product-provide (provide 'wl-util) (require 'wl-version))
projects / elisp / wanderlust.git / blobdiff