;;; 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)
+(defsubst wl-set-string-width (width string &optional padding ignore-invalid)
"Make a new string which have specified WIDTH and content of STRING.
-If WIDTH is negative number, padding spaces are added to the head and
-otherwise, padding spaces are added to the tail of the 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)))
(setq string (truncate-string-to-width string (abs width))))
(if (= (string-width string) (abs width))
string
- (if (< width 0)
- (concat (format (format "%%%ds"
- (- (abs width) (string-width string)))
- " ")
- string)
- (concat string
- (format (format "%%%ds"
- (- (abs width) (string-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 (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)
- (if (> (current-column) (abs width))
- (if (> (move-to-column (abs width)) (abs width))
- (progn
- (condition-case nil ; ignore error
- (backward-char 1)
- (error))
- (if (< width 0)
- (concat " " (buffer-substring (point-min) (point)))
- (concat (buffer-substring (point-min) (point)) " ")))
- (buffer-substring (point-min) (point)))
- (if (= (current-column) (abs width))
- 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
+ (let ((paddings (make-string (- (abs width) (current-column))
+ (or padding (string-to-char " ")))))
(if (< width 0)
- (concat (format (format "%%%ds"
- (- (abs width) (current-column)))
- " ")
- string)
- (concat string
- (format (format "%%%ds"
- (- (abs width) (current-column)))
- " ")))))))))
+ (concat paddings string)
+ (concat string paddings))))))))
(defun wl-mode-line-buffer-identification (&optional id)
(let ((priorities '(biff plug title)))
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)
- "Make a formatter from FORMAT and SPEC-ALIST.
-WIDTH is the width of the result string."
+ "Make a formatter from FORMAT and SPEC-ALIST."
(let (f spec specs stack)
(setq f
(with-temp-buffer
(cond
((looking-at "%")
(goto-char (match-end 0)))
- ((looking-at "\\(-?[0-9]*\\)\\([^0-9]\\)")
+ ((looking-at "\\(-?\\(0?\\)[0-9]*\\)\\([^0-9]\\)")
(cond
- ((string= (match-string 2) "(")
+ ((string= (match-string 3) "(")
(if (zerop (length (match-string 1)))
- (error "No number specification for %( line format"))
- (push (list
+ (error "No number specification for %%( line format"))
+ (push (list
(match-beginning 0) ; start
(match-end 0) ; start-content
(string-to-number
specs) ; specs
stack)
(setq specs nil))
- ((string= (match-string 2) ")")
+ ((string= (match-string 3) ")")
(let ((entry (pop stack))
form)
(unless entry
(error
- "No matching %( parenthesis in summary line format"))
+ "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)))
specs)))))))
(t
(setq spec
- (if (setq spec (assq (string-to-char (match-string 2))
+ (if (setq spec (assq (string-to-char (match-string 3))
spec-alist))
(nth 1 spec)
- (match-string 2)))
+ (match-string 3)))
(unless (string= "" (match-string 1))
(setq spec (list 'wl-set-string-width
(string-to-number (match-string 1))
- spec)))
+ spec
+ (unless (string= "" (match-string 2))
+ (string-to-char (match-string 2))))))
(replace-match "s" 'fixed)
- (setq specs (append specs (list spec))))))))
+ (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*")))))
+ `(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