X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=wl%2Fwl-util.el;h=04d180c2016680bd3d9a1ff2e45725208c4bb32e;hb=3498ab2a49b1048d1d8c1359afcabc6b06fe99b3;hp=2444b60bb163fe9ba45d72a0ca54653a594d50dd;hpb=e3e5f572d472484c24a40f53375103b9c9a0a7a9;p=elisp%2Fwanderlust.git diff --git a/wl/wl-util.el b/wl/wl-util.el index 2444b60..04d180c 100644 --- a/wl/wl-util.el +++ b/wl/wl-util.el @@ -1,8 +1,12 @@ -;;; wl-util.el -- Utility modules for Wanderlust. +;;; wl-util.el --- Utility modules for Wanderlust. -;; Copyright 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 2000 A. SAGATA +;; Copyright (C) 2000 Katsumi Yamaoka ;; Author: Yuuichi Teranishi +;; A. SAGATA +;; Katsumi Yamaoka ;; Keywords: mail, net news ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -24,44 +28,25 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; +(require 'bytecomp) +(require 'elmo-util) +(require 'elmo-flag) + +(condition-case nil (require 'pp) (error nil)) -(provide 'wl-util) -(eval-when-compile - (provide 'elmo-util)) - -(condition-case () - (require 'tm-edit) - (error)) -(condition-case () - (require 'pp) - (error)) (eval-when-compile - (mapcar - (function - (lambda (symbol) - (unless (boundp symbol) - (set (make-local-variable symbol) nil)))) - '(mule-version - nemacs-version - emacs-beta-version - xemacs-codename - mime-edit-insert-user-agent-field - mime-edit-user-agent-value - mime-editor/version - mime-editor/codename)) (require 'time-stamp) - (defun-maybe read-event ()) - (defun-maybe next-command-event ()) - (defun-maybe event-to-character (a)) - (defun-maybe key-press-event-p (a)) - (defun-maybe button-press-event-p (a)) - (defun-maybe set-process-kanji-code (a b)) - (defun-maybe set-process-coding-system (a b c)) - (defun-maybe dispatch-event (a))) + (defalias-maybe 'next-command-event 'ignore) + (defalias-maybe 'event-to-character 'ignore) + (defalias-maybe 'key-press-event-p 'ignore) + (defalias-maybe 'button-press-event-p 'ignore) + (defalias-maybe 'set-process-kanji-code 'ignore) + (defalias-maybe 'set-process-coding-system 'ignore) + (defalias-maybe 'dispatch-event 'ignore)) (defalias 'wl-set-work-buf 'elmo-set-work-buf) (make-obsolete 'wl-set-work-buf 'elmo-set-work-buf) @@ -71,18 +56,12 @@ (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 \" and \"foo\" @@ -157,151 +136,17 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (nreverse list)) ; jwz: fixed order ))) -(defun wl-version (&optional with-codename) - (format "%s %s%s" wl-appname wl-version - (if with-codename - (format " - \"%s\"" wl-codename) ""))) - -(defun wl-version-show () - (interactive) - (message "%s" (wl-version t))) - -;; from gnus -(defun wl-extended-emacs-version (&optional with-codename) - "Stringified Emacs version" - (interactive) - (cond - ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) - (concat "Emacs " (wl-match-string 1 emacs-version) - (and (boundp 'mule-version)(concat "/Mule " mule-version)))) - ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" - emacs-version) - (concat (wl-match-string 1 emacs-version) - (format " %d.%d" emacs-major-version emacs-minor-version) - (if (and (boundp 'emacs-beta-version) - emacs-beta-version) - (format "b%d" emacs-beta-version)) - (if with-codename - (if (boundp 'xemacs-codename) - (concat " - \"" xemacs-codename "\""))))) - (t emacs-version))) - -(defun wl-extended-emacs-version2 (&optional delimiter with-codename) - "Stringified Emacs version" - (interactive) - (cond - ((and (boundp 'mule-version) - mule-version - (string-match "\\([0-9]+\.[0-9]+\\)\\(.*$\\)" mule-version)) - (format "Mule%s%s@%d.%d%s" - (or delimiter " ") - (wl-match-string 1 mule-version) - emacs-major-version - emacs-minor-version - (if with-codename - (wl-match-string 2 mule-version) - ""))) - ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) - (if (boundp 'nemacs-version) - (concat "Nemacs" (or delimiter " ") - nemacs-version - "@" - (substring emacs-version - (match-beginning 1) - (match-end 1))) - (concat "Emacs" (or delimiter " ") - (wl-match-string 1 emacs-version)))) - ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" - emacs-version) - (concat (wl-match-string 1 emacs-version) - (or delimiter " ") - (format "%d.%d" emacs-major-version emacs-minor-version) - (if (and (boundp 'emacs-beta-version) - emacs-beta-version) - (format "b%d" emacs-beta-version)) - (if (and with-codename - (boundp 'xemacs-codename) - xemacs-codename) - (format " (%s)" xemacs-codename)))) - (t emacs-version))) - -(defun wl-extended-emacs-version3 (&optional delimiter with-codename) - "Stringified Emacs version" - (interactive) - (cond - ((and (boundp 'mule-version) - mule-version - (string-match "\\([0-9]+\.[0-9]+\\)\\(.*$\\)" mule-version)) - (format "Emacs%s%d.%d Mule%s%s%s" - (or delimiter " ") - emacs-major-version - emacs-minor-version - (or delimiter " ") - (wl-match-string 1 mule-version) - (if with-codename - (wl-match-string 2 mule-version) - ""))) - ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) - (if (boundp 'nemacs-version) - (let ((nemacs-codename-assoc '(("3.3.2" . " (FUJIMUSUME)") - ("3.3.1" . " (HINAMATSURI)") - ("3.2.3" . " (YUMENO-AWAYUKI)")))) - (format "Emacs%s%s Nemacs%s%s%s" - (or delimiter " ") - (wl-match-string 1 emacs-version) - (or delimiter " ") - nemacs-version - (or (and with-codename - (cdr (assoc nemacs-version - nemacs-codename-assoc))) - ""))) - (concat "Emacs" (or delimiter " ") - (wl-match-string 1 emacs-version)))) - ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" - emacs-version) - (concat (wl-match-string 1 emacs-version) - (or delimiter " ") - (format "%d.%d" emacs-major-version emacs-minor-version) - (if (and (boundp 'emacs-beta-version) - emacs-beta-version) - (format "b%d" emacs-beta-version)) - (if (and with-codename - (boundp 'xemacs-codename) - xemacs-codename) - (format " (%s)" xemacs-codename)))) - (t emacs-version))) - (defun wl-append-element (list element) (if element (append list (list element)) list)) -(defun wl-read-event-char () - "Get the next event." - (let ((event (read-event))) - ;; should be gnus-characterp, but this can't be called in XEmacs anyway - (cons (and (numberp event) event) event))) - -(defun wl-xmas-read-event-char () - "Get the next event." - (let ((event (next-command-event))) - (sit-for 0) - ;; We junk all non-key events. Is this naughty? - (while (not (or (key-press-event-p event) - (button-press-event-p event))) - (dispatch-event event) - (setq event (next-command-event))) - (cons (and (key-press-event-p event) - (event-to-character event)) - event))) - -(if running-xemacs - (fset 'wl-read-event-char 'wl-xmas-read-event-char)) - (defmacro wl-push (v l) + "Insert V at the head of the list stored in L." (list 'setq l (list 'cons v l))) (defmacro wl-pop (l) + "Remove the head of the list stored in L." (list 'car (list 'prog1 l (list 'setq l (list 'cdr l))))) (defun wl-ask-folder (func mes-string) @@ -309,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 @@ -319,111 +164,97 @@ 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) - -;(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 + (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))))) - -(defun wl-generate-user-agent-string () - "A candidate of wl-generate-mailer-string-func. -Insert User-Agent field instead of X-Mailer field." - (let ((mime-user-agent (and (boundp 'mime-edit-insert-user-agent-field) - mime-edit-insert-user-agent-field - mime-edit-user-agent-value))) - (if mime-user-agent - (concat "User-Agent: " - wl-appname "/" wl-version - " (" wl-codename ") " - mime-user-agent) - (if (and (boundp 'mime-editor/version) - mime-editor/version) - (concat "User-Agent: " - wl-appname "/" wl-version - " (" wl-codename ") " - "tm/" mime-editor/version - (if (and (boundp 'mime-editor/codename) - mime-editor/codename) - (concat " (" mime-editor/codename ")")) - (if (and (boundp 'mime-library-product) - mime-library-product) - (concat " " (aref mime-library-product 0) - "/" - (mapconcat 'int-to-string - (aref mime-library-product 1) - ".") - " (" (aref mime-library-product 2) ")")) - (condition-case nil - (progn - (require 'apel-ver) - (concat " " (apel-version))) - (file-error nil)) - " " (wl-extended-emacs-version3 "/" t)) - (concat "User-Agent: " wl-appname "/" wl-version " (" wl-codename ") " - (wl-extended-emacs-version3 "/" t)))))) - -(defun wl-make-modeline-subr () - (let* ((duplicated (copy-sequence mode-line-format)) - (cur-entry duplicated) - return-modeline) - (if (memq 'wl-plug-state-indicator mode-line-format) - duplicated - (catch 'done - (while cur-entry - (if (or (and (symbolp (car cur-entry)) - (eq 'mode-line-buffer-identification - (car cur-entry))) - (and (consp (car cur-entry)) - (or - (eq 'modeline-buffer-identification - (car (car cur-entry))) - (eq 'modeline-buffer-identification - (cdr (car cur-entry)))))) - (progn - (setq return-modeline (append return-modeline - (list 'wl-plug-state-indicator) - cur-entry)) - (throw 'done return-modeline)) - (setq return-modeline (append return-modeline - (list (car cur-entry))))) - (setq cur-entry (cdr cur-entry))))))) + (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))) + (let ((items (reverse wl-mode-line-display-priority-list)) + item) + (while items + (setq item (car items) + items (cdr items)) + (unless (memq item '(biff plug)) + (setq item 'title)) + (setq priorities (cons item (delq item priorities))))) + (let (priority result) + (while priorities + (setq priority (car priorities) + priorities (cdr priorities)) + (cond + ((eq 'biff priority) + (when wl-biff-check-folder-list + (setq result (append result '((wl-modeline-biff-status + wl-modeline-biff-state-on + wl-modeline-biff-state-off)))))) + ((eq 'plug priority) + (when wl-show-plug-status-on-modeline + (setq result (append result '((wl-modeline-plug-status + wl-modeline-plug-state-on + wl-modeline-plug-state-off)))))) + (t + (setq result (append result (or id '("Wanderlust: %12b"))))))) + (prog1 + (setq mode-line-buffer-identification (if (stringp (car result)) + result + (cons "" result))) + (force-mode-line-update t))))) (defalias 'wl-display-error 'elmo-display-error) (make-obsolete 'wl-display-error 'elmo-display-error) @@ -434,18 +265,22 @@ Insert User-Agent field instead of X-Mailer field." 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) - "Substring POSth matched string." + "Substring POSth matched STRING." (` (substring (, string) (match-beginning (, pos)) (match-end (, pos))))) (defmacro wl-match-buffer (pos) @@ -457,22 +292,20 @@ Insert User-Agent field instead of X-Mailer field." (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)) @@ -481,25 +314,6 @@ Insert User-Agent field instead of X-Mailer field." (defalias 'wl-string 'elmo-string) (make-obsolete 'wl-string 'elmo-string) -(defun wl-parse-newsgroups (string &optional subscribe-only) - (let* ((nglist (wl-parse string "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")) - spec ret-val) - (if (not subscribe-only) - nglist - (while nglist - (if (intern-soft (car nglist) wl-folder-newsgroups-hashtb) - (wl-append ret-val (list (car nglist)))) - (setq nglist (cdr nglist))) - ret-val))) - -;; Check if active region exists or not. -(if (boundp 'mark-active) - (defmacro wl-region-exists-p () - '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. @@ -532,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))) @@ -552,12 +358,43 @@ or between BEG and END." (list (list item value)))))) (defun wl-delete-alist (key alist) - "Delete all entries in ALIST that have a key eq to KEY." + "Delete by side effect any entries specified with KEY from ALIST. +Return the modified ALIST. Key comparison is done with `assq'. +Write `(setq foo (wl-delete-alist key foo))' to be sure of changing +the value of `foo'." (let (entry) (while (setq entry (assq key alist)) (setq alist (delq entry alist))) alist)) +(defun wl-delete-associations (keys alist) + "Delete by side effect any entries specified with KEYS from ALIST. +Return the modified ALIST. KEYS must be a list of keys for ALIST. +Deletion is done with `wl-delete-alist'. +Write `(setq foo (wl-delete-associations keys foo))' to be sure of +changing the value of `foo'." + (while keys + (setq alist (wl-delete-alist (car keys) alist)) + (setq keys (cdr keys))) + alist) + +(defun wl-inverse-alist (keys alist) + "Inverse ALIST, copying. +Return an association list represents the inverse mapping of ALIST, +from objects to KEYS. +The objects mapped (cdrs of elements of the ALIST) are shared." + (let (x y tmp result) + (while keys + (setq x (car keys)) + (setq y (cdr (assq x alist))) + (if y + (if (setq tmp (assoc y result)) + (setq result (cons (append tmp (list x)) + (delete tmp result))) + (setq result (cons (list y x) result)))) + (setq keys (cdr keys))) + result)) + (eval-when-compile (require 'static)) (static-unless (fboundp 'pp) @@ -633,11 +470,11 @@ that `read' can handle, whenever this is possible." (defsubst wl-get-date-iso8601 (date) (or (get-text-property 0 'wl-date date) (let* ((d1 (timezone-fix-time date nil nil)) - (time (format "%04d%02d%02dT%02d%02d%02d" - (aref d1 0) (aref d1 1) (aref d1 2) - (aref d1 3) (aref d1 4) (aref d1 5)))) - (put-text-property 0 1 'wl-date time date) - time))) + (time (format "%04d%02d%02dT%02d%02d%02d" + (aref d1 0) (aref d1 1) (aref d1 2) + (aref d1 3) (aref d1 4) (aref d1 5)))) + (put-text-property 0 1 'wl-date time date) + time))) (defun wl-make-date-string () (let ((s (current-time-string))) @@ -645,13 +482,13 @@ that `read' can handle, whenever this is possible." s) (concat (wl-match-string 1 s) ", " (timezone-make-date-arpa-standard s (current-time-zone))))) - + (defun wl-date-iso8601 (date) "Convert the DATE to YYMMDDTHHMMSS." (condition-case () (wl-get-date-iso8601 date) (error ""))) - + (defun wl-day-number (date) (let ((dat (mapcar '(lambda (s) (and s (string-to-int s)) ) (timezone-parse-date date)))) @@ -672,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-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) @@ -687,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-buf-name))) +(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 @@ -709,17 +550,6 @@ that `read' can handle, whenever this is possible." (and (get-buffer x) (kill-buffer x))))) (buffer-list)))) - -(defun wl-sendlog-time () - (static-if (fboundp 'format-time-string) - (format-time-string "%Y/%m/%d %T") - (let ((date (current-time-string))) - (format "%s/%02d/%02d %s" - (substring date -4) - (cdr (assoc (upcase (substring date 4 7)) - timezone-months-assoc)) - (string-to-int (substring date 8 10)) - (substring date 11 19))))) (defun wl-collect-summary () (let (result) @@ -734,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) @@ -797,23 +652,464 @@ 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 () - (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)) + +;;; + +(defmacro wl-count-lines () + (` (save-excursion + (beginning-of-line) + (count-lines 1 (point))))) + +(defun wl-horizontal-recenter () + "Recenter the current buffer horizontally." + (beginning-of-line) + (re-search-forward "[[<]" (point-at-eol) t) + (if (< (current-column) (/ (window-width) 2)) + (set-window-hscroll (get-buffer-window (current-buffer) t) 0) + (let* ((orig (point)) + (end (window-end (get-buffer-window (current-buffer) t))) + (max 0)) + (when end + ;; Find the longest line currently displayed in the window. + (goto-char (window-start)) + (while (and (not (eobp)) + (< (point) end)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (goto-char orig) + ;; Scroll horizontally to center (sort of) the point. + (if (> max (window-width)) + (set-window-hscroll + (get-buffer-window (current-buffer) t) + (min (- (current-column) (/ (window-width) 3)) + (+ 2 (- max (window-width))))) + (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) + max)))) + +;; 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 + (defvar wl-biff-timer-name "wl-biff") + + (defun wl-biff-stop () + (when (get-itimer wl-biff-timer-name) + (delete-itimer wl-biff-timer-name))) + + (defun wl-biff-start () + (wl-biff-stop) + (when wl-biff-check-folder-list + (start-itimer wl-biff-timer-name 'wl-biff-check-folders + 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 + (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) + (timer-activate (get 'wl-biff 'timer))) + (put 'wl-biff 'timer + (run-at-time + (timer-next-integral-multiple-of-time + (current-time) wl-biff-check-interval) + wl-biff-check-interval + 'wl-biff-event-handler)))))) + + (defun-maybe timer-next-integral-multiple-of-time (time secs) + "Yield the next value after TIME that is an integral multiple of SECS. +More precisely, the next value, after TIME, that is an integral multiple +of SECS seconds since the epoch. SECS may be a fraction. +This function is imported from Emacs 20.7." + (let ((time-base (ash 1 16))) + (if (fboundp 'atan) + ;; Use floating point, taking care to not lose precision. + (let* ((float-time-base (float time-base)) + (million 1000000.0) + (time-usec (+ (* million + (+ (* float-time-base (nth 0 time)) + (nth 1 time))) + (nth 2 time))) + (secs-usec (* million secs)) + (mod-usec (mod time-usec secs-usec)) + (next-usec (+ (- time-usec mod-usec) secs-usec)) + (time-base-million (* float-time-base million))) + (list (floor next-usec time-base-million) + (floor (mod next-usec time-base-million) million) + (floor (mod next-usec million)))) + ;; Floating point is not supported. + ;; Use integer arithmetic, avoiding overflow if possible. + (let* ((mod-sec (mod (+ (* (mod time-base secs) + (mod (nth 0 time) secs)) + (nth 1 time)) + secs)) + (next-1-sec (+ (- (nth 1 time) mod-sec) secs))) + (list (+ (nth 0 time) (floor next-1-sec time-base)) + (mod next-1-sec time-base) + 0))))) + + (defun wl-biff-event-handler () + ;; PAKURing from FSF:time.el + (wl-biff-check-folders) + ;; Do redisplay right now, if no input pending. + (sit-for 0) + (let* ((current (current-time)) + (timer (get 'wl-biff 'timer)) + ;; Compute the time when this timer will run again, next. + (next-time (timer-relative-time + (list (aref timer 1) (aref timer 2) (aref timer 3)) + (* 5 (aref timer 4)) 0))) + ;; If the activation time is far in the past, + ;; skip executions until we reach a time in the future. + ;; This avoids a long pause if Emacs has been suspended for hours. + (or (> (nth 0 next-time) (nth 0 current)) + (and (= (nth 0 next-time) (nth 0 current)) + (> (nth 1 next-time) (nth 1 current))) + (and (= (nth 0 next-time) (nth 0 current)) + (= (nth 1 next-time) (nth 1 current)) + (> (nth 2 next-time) (nth 2 current))) + (progn + (timer-set-time timer (timer-next-integral-multiple-of-time + current wl-biff-check-interval) + wl-biff-check-interval) + (timer-activate timer))))))) + +(defsubst wl-biff-notify (new-mails notify-minibuf) + (when (and (not wl-modeline-biff-status) (> new-mails 0)) + (run-hooks 'wl-biff-notify-hook)) + (when (and wl-modeline-biff-status (eq new-mails 0)) + (run-hooks 'wl-biff-unnotify-hook)) + (setq wl-modeline-biff-status (> new-mails 0)) + (force-mode-line-update t) + (when notify-minibuf + (cond ((zerop new-mails) (message "No mail.")) + ((= 1 new-mails) (message "You have a new mail.")) + (t (message "You have %d new mails." new-mails))))) + +;; Internal variable. +(defvar wl-biff-check-folders-running nil) + +(defun wl-biff-check-folders () + (interactive) + (if wl-biff-check-folders-running + (when (interactive-p) + (message "Biff process is running.")) + (setq wl-biff-check-folders-running t) + (when (interactive-p) + (message "Checking new mails...")) + (let ((new-mails 0) + (flist (or wl-biff-check-folder-list (list wl-default-folder))) + folder) + (if (eq (length flist) 1) + (wl-biff-check-folder-async (wl-folder-get-elmo-folder + (car flist) 'biff) (interactive-p)) + (unwind-protect + (while flist + (setq folder (wl-folder-get-elmo-folder (car flist)) + flist (cdr flist)) + (when (and (elmo-folder-plugged-p folder) + (elmo-folder-exists-p folder)) + (setq new-mails + (+ new-mails + (nth 0 (wl-biff-check-folder folder)))))) + (setq wl-biff-check-folders-running nil) + (wl-biff-notify new-mails (interactive-p))))))) + +(defun wl-biff-check-folder (folder) + (if (eq (elmo-folder-type-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 (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) + (sit-for 0) + (wl-biff-notify (car diff) (nth 2 data))) + +(defun wl-biff-check-folder-async (folder notify-minibuf) + (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))) + (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) +(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 + '(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))))) + +(require 'product) +(product-provide (provide 'wl-util) (require 'wl-version)) ;;; wl-util.el ends here