X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-util.el;h=13576d451737ea6079ea4f221cc8f933d1607cbc;hb=e68fd9084cb93ed29625ed700a1a77cd86ecc335;hp=53676d62be74550252a70d6b35c4d83433715034;hpb=12486e286f2e8098a18078919ee9f29074f737c2;p=elisp%2Fwanderlust.git diff --git a/wl/wl-util.el b/wl/wl-util.el index 53676d6..13576d4 100644 --- a/wl/wl-util.el +++ b/wl/wl-util.el @@ -1,8 +1,8 @@ -;;; wl-util.el -- Utility modules for Wanderlust. +;;; wl-util.el --- Utility modules for Wanderlust. -;; Copyright 1998,1999,2000 Yuuichi Teranishi -;; Copyright 2000 A. SAGATA -;; Katsumi Yamaoka +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 2000 A. SAGATA +;; Copyright (C) 2000 Katsumi Yamaoka ;; Author: Yuuichi Teranishi ;; A. SAGATA @@ -32,18 +32,14 @@ ;;; Code: ;; - -(require 'product) -(product-provide (provide 'wl-util) (require 'wl-version)) +(require 'bytecomp) (eval-when-compile (require 'elmo-util)) -(condition-case nil (require 'tm-edit) (error nil)) (condition-case nil (require 'pp) (error nil)) (eval-when-compile (require 'time-stamp) - (defalias-maybe 'read-event 'ignore) (defalias-maybe 'next-command-event 'ignore) (defalias-maybe 'event-to-character 'ignore) (defalias-maybe 'key-press-event-p 'ignore) @@ -60,14 +56,8 @@ (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. @@ -151,28 +141,6 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (append list (list element)) list)) -(defun wl-read-event-char () - "Get the next event." - (let ((event (read-event))) - ;; should be gnus-characterp, but this can't be called in XEmacs anyway - (cons (and (numberp event) event) event))) - -(defun wl-xmas-read-event-char () - "Get the next event." - (let ((event (next-command-event))) - (sit-for 0) - ;; We junk all non-key events. Is this naughty? - (while (not (or (key-press-event-p event) - (button-press-event-p event))) - (dispatch-event event) - (setq event (next-command-event))) - (cons (and (key-press-event-p event) - (event-to-character event)) - event))) - -(if wl-on-xemacs - (fset 'wl-read-event-char 'wl-xmas-read-event-char)) - (defmacro wl-push (v l) "Insert V at the head of the list stored in L." (list 'setq l (list 'cons v l))) @@ -205,39 +173,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 + (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (insert string) + (when (> (current-column) (abs width)) + (when (> (move-to-column (abs width)) (abs width)) + (condition-case nil ; ignore error + (backward-char 1) + (error))) + (setq string (buffer-substring (point-min) (point)))) + (if (= (current-column) (abs width)) string - (concat string - (format (format "%%%ds" - (- width (current-column))) - " ")))))) - -(defun wl-display-bytes (num) - (let (result remain) - (cond - ((> (setq result (/ num 1000000)) 0) - (setq remain (% num 1000000)) - (if (> remain 400000) - (setq result (+ 1 result))) - (format "%dM" result)) - ((> (setq result (/ num 1000)) 0) - (setq remain (% num 1000)) - (if (> remain 400) - (setq result (+ 1 result))) - (format "%dK" result)) - (t (format "%dB" result))))) + (let ((paddings (make-string (- (abs width) (current-column)) + (or padding ?\ )))) + (if (< width 0) + (concat paddings string) + (concat string paddings)))))))) (defun wl-mode-line-buffer-identification (&optional id) (let ((priorities '(biff plug title))) @@ -313,13 +292,7 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (defmacro wl-as-coding-system (coding-system &rest body) (` (let ((file-coding-system-for-read (, coding-system)) (file-coding-system (, coding-system))) - (,@ body)))) - (if wl-on-nemacs - (defmacro wl-as-coding-system (coding-system &rest body) - (` (let ((default-kanji-fileio-code (, coding-system)) - (kanji-fileio-code (, coding-system)) - kanji-expected-code) - (,@ body)))))))) + (,@ body))))))) (defmacro wl-as-mime-charset (mime-charset &rest body) (` (wl-as-coding-system (mime-charset-to-coding-system (, mime-charset)) @@ -328,17 +301,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) -(defun wl-parse-newsgroups (string &optional subscribe-only) - (let* ((nglist (wl-parse string "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")) - ret-val) - (if (not subscribe-only) - nglist - (while nglist - (if (intern-soft (car nglist) wl-folder-newsgroups-hashtb) - (wl-append ret-val (list (car nglist)))) - (setq nglist (cdr nglist))) - ret-val))) - ;; Check if active region exists or not. (if (boundp 'mark-active) (defmacro wl-region-exists-p () @@ -550,14 +512,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) @@ -576,8 +538,8 @@ that `read' can handle, whenever this is possible." (defmacro wl-current-message-buffer () (` (save-excursion (if (buffer-live-p wl-current-summary-buffer) - (set-buffer wl-current-summary-buffer)) - wl-message-buf-name))) + (set-buffer wl-current-summary-buffer)) + wl-message-buffer))) (defmacro wl-kill-buffers (regexp) (` (mapcar (function @@ -588,17 +550,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 @@ -612,8 +563,25 @@ that `read' can handle, whenever this is possible." (buffer-list)) result)) +(defun wl-collect-draft () + (let ((draft-regexp (concat + "^" (regexp-quote + (elmo-localdir-folder-directory-internal + (wl-folder-get-elmo-folder wl-draft-folder))))) + result buf) + (mapcar + (function (lambda (x) + (if (and + (setq buf (with-current-buffer x + wl-draft-buffer-file-name)) + (string-match draft-regexp buf)) + (setq result (nconc result (list x)))))) + (buffer-list)) + result)) + (static-if (fboundp 'read-directory-name) - (defalias 'wl-read-directory-name 'read-directory-name) + (defun wl-read-directory-name (prompt dir) + (read-directory-name prompt dir dir)) (defun wl-read-directory-name (prompt dir) (let ((dir (read-file-name prompt dir))) (unless (file-directory-p dir) @@ -675,27 +643,36 @@ 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-func 'wl-local-load-profile) +(defvar wl-load-profile-function 'wl-local-load-profile) (defun wl-local-load-profile () "Load `wl-init-file'." (message "Initializing ...") (load wl-init-file 'noerror 'nomessage)) (defun wl-load-profile () - "Call `wl-load-profile-func' function." - (funcall wl-load-profile-func)) + "Call `wl-load-profile-function' function." + (funcall wl-load-profile-function)) ;;; @@ -747,20 +724,24 @@ that `read' can handle, whenever this is possible." (start-itimer wl-biff-timer-name 'wl-biff-check-folders wl-biff-check-interval wl-biff-check-interval)))) - ((condition-case nil (require 'timer) (error nil));; FSFmacs 19+ + ((and (condition-case nil (require 'timer) (error nil));; FSFmacs 19+ + (fboundp 'timer-activate)) (defun wl-biff-stop () - (put 'wl-biff 'timer nil)) + (when (get 'wl-biff 'timer) + (cancel-timer (get 'wl-biff 'timer)))) (defun wl-biff-start () (require 'timer) (when wl-biff-check-folder-list (wl-biff-check-folders) - (put 'wl-biff 'timer (run-at-time - (timer-next-integral-multiple-of-time - (current-time) wl-biff-check-interval) - wl-biff-check-interval - 'wl-biff-event-handler)))) + (if (get 'wl-biff 'timer) + (timer-activate (get 'wl-biff 'timer)) + (put 'wl-biff 'timer (run-at-time + (timer-next-integral-multiple-of-time + (current-time) wl-biff-check-interval) + wl-biff-check-interval + 'wl-biff-event-handler))))) (defun-maybe timer-next-integral-multiple-of-time (time secs) "Yield the next value after TIME that is an integral multiple of SECS. @@ -824,11 +805,15 @@ This function is imported from Emacs 20.7." (fset 'wl-biff-start 'ignore))) (defsubst wl-biff-notify (new-mails notify-minibuf) + (when (and (not wl-modeline-biff-status) (> new-mails 0)) + (run-hooks 'wl-biff-notify-hook)) + (when (and wl-modeline-biff-status (eq new-mails 0)) + (run-hooks 'wl-biff-unnotify-hook)) (setq wl-modeline-biff-status (> new-mails 0)) (force-mode-line-update t) (when notify-minibuf (cond ((zerop new-mails) (message "No mail.")) - ((eq 1 new-mails) (message "You have a new mail.")) + ((= 1 new-mails) (message "You have a new mail.")) (t (message "You have %d new mails." new-mails))))) ;; Internal variable. @@ -846,10 +831,11 @@ This function is imported from Emacs 20.7." (flist (or wl-biff-check-folder-list (list wl-default-folder))) folder) (if (eq (length flist) 1) - (wl-biff-check-folder-async (car flist) (interactive-p)) + (wl-biff-check-folder-async (wl-folder-get-elmo-folder + (car flist) 'biff) (interactive-p)) (unwind-protect (while flist - (setq folder (car flist) + (setq folder (wl-folder-get-elmo-folder (car flist)) flist (cdr flist)) (when (elmo-folder-plugged-p folder) (setq new-mails @@ -859,20 +845,21 @@ This function is imported from Emacs 20.7." (wl-biff-notify new-mails (interactive-p))))))) (defun wl-biff-check-folder (folder) - (if (eq (elmo-folder-get-type folder) 'pop3) - ;; pop3 biff should share the session. - (prog2 - (elmo-commit folder) ; Close session. - (wl-folder-check-one-entity folder) - (elmo-commit folder)) - (let ((elmo-network-session-name-prefix "BIFF-")) - (wl-folder-check-one-entity folder)))) + (if (eq (elmo-folder-type-internal folder) 'pop3) + (unless (elmo-pop3-get-session folder 'if-exists) + (wl-folder-check-one-entity (elmo-folder-name-internal folder) + 'biff)) + (wl-folder-check-one-entity (elmo-folder-name-internal folder) + 'biff))) (defun wl-biff-check-folder-async-callback (diff data) (if (nth 1 data) (with-current-buffer (nth 1 data) - (wl-folder-entity-hashtb-set wl-folder-entity-hashtb (nth 0 data) - (list (car diff) 0 (cdr diff)) + (wl-folder-entity-hashtb-set wl-folder-entity-hashtb + (nth 0 data) + (list (nth 0 diff) + (- (nth 1 diff) (nth 0 diff)) + (nth 2 diff)) (current-buffer)))) (setq wl-folder-info-alist-modified t) (setq wl-biff-check-folders-running nil) @@ -881,20 +868,144 @@ This function is imported from Emacs 20.7." (defun wl-biff-check-folder-async (folder notify-minibuf) (when (elmo-folder-plugged-p folder) - (let ((type (elmo-folder-get-type folder))) - (if (and (eq type 'imap4) - (wl-folder-use-server-diff-p folder)) - ;; Check asynchronously only when IMAP4 and use server diff. - (progn - (setq elmo-folder-diff-async-callback - 'wl-biff-check-folder-async-callback) - (setq elmo-folder-diff-async-callback-data - (list folder (get-buffer wl-folder-buffer-name) - 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)))) + (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 (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)))) + +(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))) + +(defvar wl-line-string) +(defun wl-line-parse-format (format spec-alist) + "Make a formatter from FORMAT and SPEC-ALIST." + (let (f spec specs stack) + (setq f + (with-temp-buffer + (insert format) + (goto-char (point-min)) + (while (search-forward "%" nil t) + (cond + ((looking-at "%") + (goto-char (match-end 0))) + ((looking-at "\\(-?\\(0?\\)[0-9]*\\)\\([^0-9]\\)") + (cond + ((string= (match-string 3) "(") + (if (zerop (length (match-string 1))) + (error "No number specification for %%( line format")) + (push (list + (match-beginning 0) ; start + (match-end 0) ; start-content + (string-to-number + (match-string 1)) ; width + specs) ; specs + stack) + (setq specs nil)) + ((string= (match-string 3) ")") + (let ((entry (pop stack)) + form) + (unless entry + (error + "No matching %%( parenthesis in summary line format")) + (goto-char (car entry)) ; start + (setq form (buffer-substring (nth 1 entry) ; start-content + (- (match-beginning 0) 1))) + (delete-region (car entry) (match-end 0)) + (insert "s") + (setq specs + (append + (nth 3 entry) + (list (list 'wl-set-string-width (nth 2 entry) + (append + (list 'format form) + specs))))))) + (t + (setq spec + (if (setq spec (assq (string-to-char (match-string 3)) + spec-alist)) + (nth 1 spec) + (match-string 3))) + (unless (string= "" (match-string 1)) + (setq spec (list 'wl-set-string-width + (string-to-number (match-string 1)) + spec + (unless (string= "" (match-string 2)) + (string-to-char (match-string 2)))))) + (replace-match "s" 'fixed) + (setq specs (append specs + (list + (list + 'setq 'wl-line-string + spec))))))))) + (buffer-string))) + (append (list 'format f) specs))) + +(defmacro wl-line-formatter-setup (formatter format alist) + (` (let (byte-compile-warnings) + (setq (, formatter) + (byte-compile + (list 'lambda () + (wl-line-parse-format (, format) (, alist))))) + (when (get-buffer "*Compile-Log*") + (bury-buffer "*Compile-Log*")) + (when (get-buffer "*Compile-Log-Show*") + (bury-buffer "*Compile-Log-Show*"))))) + +(require 'product) +(product-provide (provide 'wl-util) (require 'wl-version)) ;;; wl-util.el ends here