X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-util.el;h=bfc84c34acea06bf390be82b37c7eec37f4f7f42;hb=54340051deb1c71b4618ea5b7e3d4fed9f8d259c;hp=cce302f0a1133fe6fdd6d55e4130caaae165b493;hpb=1749663c3b00d5a615706c7f17adbbef42704dfa;p=elisp%2Fwanderlust.git diff --git a/wl/wl-util.el b/wl/wl-util.el index cce302f..bfc84c3 100644 --- a/wl/wl-util.el +++ b/wl/wl-util.el @@ -1,4 +1,4 @@ -;;; wl-util.el -- Utility modules for Wanderlust. +;;; wl-util.el --- Utility modules for Wanderlust. ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi ;; Copyright (C) 2000 A. SAGATA @@ -32,11 +32,10 @@ ;;; Code: ;; +(require 'bytecomp) +(require 'elmo-util) +(require 'elmo-flag) -(eval-when-compile - (require 'elmo-util)) - -(condition-case nil (require 'tm-edit) (error nil)) (condition-case nil (require 'pp) (error nil)) (eval-when-compile @@ -155,7 +154,7 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (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 ?\ ) (and cmd @@ -165,6 +164,11 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (funcall func)) (wl-push (cdr keve) unread-command-events)))) +(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) @@ -174,39 +178,50 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, ;;(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) +(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 + (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))) @@ -250,13 +265,17 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, 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))) @@ -273,22 +292,20 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (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)))) - (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)))))))) + (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)) @@ -297,14 +314,6 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (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. @@ -337,14 +346,6 @@ or between BEG and 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))) @@ -508,14 +509,14 @@ that `read' can handle, whenever this is possible." "^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-nntp-default-port))) + (setq port (int-to-string elmo-nntp-default-port))) (if (eq (length (setq server - (elmo-match-string 1 url))) 0) - (setq server elmo-nntp-default-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) @@ -523,19 +524,23 @@ that `read' can handle, whenever this is possible." 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))) +(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)))))) (defmacro wl-kill-buffers (regexp) (` (mapcar (function @@ -546,17 +551,6 @@ that `read' can handle, whenever this is possible." (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 @@ -570,8 +564,33 @@ that `read' can handle, whenever this is possible." (buffer-list)) result)) +(defun wl-collect-draft () + (let ((draft-regexp (concat + "^" (regexp-quote wl-draft-folder))) + result buf) + (mapcar + (function (lambda (x) + (if (with-current-buffer x + (and (eq major-mode 'wl-draft-mode) + (buffer-name) + (string-match draft-regexp (buffer-name)))) + (setq result (nconc result (list x)))))) + (buffer-list)) + result)) + +(defun wl-save-drafts () + (let ((msg (current-message)) + (buffers (wl-collect-draft))) + (save-excursion + (while buffers + (set-buffer (car buffers)) + (if (buffer-modified-p) (wl-draft-save)) + (setq buffers (cdr buffers)))) + (message "%s" (or msg "")))) + (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) @@ -633,22 +652,31 @@ that `read' can handle, whenever this is possible." ;; 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 () "Return Message-ID field value." - (concat "<" (wl-unique-id) "@" - (or wl-message-id-domain - (if wl-local-domain - (concat (system-name) "." wl-local-domain) - (system-name))) - ">")) + (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-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 () @@ -689,6 +717,34 @@ that `read' can handle, whenever this is possible." (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) max)))) +;; Draft auto-save +(static-cond + (wl-on-xemacs + (defvar wl-save-drafts-timer-name "wl-save-drafts") + + (defun wl-set-save-drafts () + (if (numberp wl-auto-save-drafts-interval) + (unless (get-itimer wl-save-drafts-timer-name) + (start-itimer wl-save-drafts-timer-name 'wl-save-drafts + wl-auto-save-drafts-interval wl-auto-save-drafts-interval + t)) + (when (get-itimer wl-save-drafts-timer-name) + (delete-itimer wl-save-drafts-timer-name))))) + (t + (defun wl-set-save-drafts () + (if (numberp wl-auto-save-drafts-interval) + (progn + (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-save-drafts)))) + (when (get 'wl-save-drafts 'timer) + (cancel-timer (get 'wl-save-drafts 'timer))))))) + ;; Biff (static-cond (wl-on-xemacs @@ -701,13 +757,11 @@ that `read' can handle, whenever this is possible." (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)))) @@ -715,14 +769,27 @@ that `read' can handle, whenever this is possible." (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. @@ -780,10 +847,7 @@ This function is imported from Emacs 20.7." (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)) @@ -813,12 +877,13 @@ This function is imported from Emacs 20.7." folder) (if (eq (length flist) 1) (wl-biff-check-folder-async (wl-folder-get-elmo-folder - (car flist)) (interactive-p)) + (car flist) 'biff) (interactive-p)) (unwind-protect (while flist (setq folder (wl-folder-get-elmo-folder (car flist)) flist (cdr flist)) - (when (elmo-folder-plugged-p folder) + (when (and (elmo-folder-plugged-p folder) + (elmo-folder-exists-p folder)) (setq new-mails (+ new-mails (nth 0 (wl-biff-check-folder folder)))))) @@ -827,20 +892,20 @@ This function is imported from Emacs 20.7." (defun wl-biff-check-folder (folder) (if (eq (elmo-folder-type-internal 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))))) + (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)) + (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) @@ -848,22 +913,26 @@ This function is imported from Emacs 20.7." (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 (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))) @@ -877,38 +946,168 @@ is enclosed by at least one regexp grouping construct." (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." + (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*"))))) + +(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-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) + (denial-fields (nconc (mapcar 'capitalize elmo-msgdb-extra-fields) + '("Flag" "Since" "Before" + "From" "Subject" "To" "Cc" "Body" "ToCc"))) + (field (completing-read + (format "%s (%s): " prompt default) + (mapcar 'list + (append '("AND" "OR" "Last" "First") + denial-fields + (mapcar (lambda (f) (concat "!" f)) + denial-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 (function + (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 + elmo-global-flags + '(unread answered forwarded digest any)) + #'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))))) (require 'product) (product-provide (provide 'wl-util) (require 'wl-version))