X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-util.el;h=30f0740521033d0e8cb4e2652db43ba72160242c;hb=65ba135032b2614fa07c206f8cd2d8a48ba8b9e3;hp=d949fe170855d22b102a98ec32dd04ae11cf997b;hpb=6496fb940b09542445ce0dc3b262bb903ab5502e;p=elisp%2Fwanderlust.git diff --git a/wl/wl-util.el b/wl/wl-util.el index d949fe1..30f0740 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) (eval-when-compile (require 'elmo-util)) -(condition-case nil (require 'tm-edit) (error nil)) (condition-case nil (require 'pp) (error nil)) (eval-when-compile @@ -57,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. @@ -180,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))) @@ -288,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)) @@ -303,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 () @@ -525,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) @@ -551,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 @@ -563,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 @@ -587,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) @@ -650,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 ...") + (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)) ;;; @@ -829,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 @@ -842,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 '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)) + (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) @@ -864,20 +868,21 @@ 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) + (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) @@ -892,6 +897,89 @@ is enclosed by at least one regexp grouping construct." (concat open-paren (mapconcat 'regexp-quote strings "\\|") close-paren)))) +(defalias 'wl-expand-newtext 'elmo-expand-newtext) + +(defun wl-region-exists-p () + "Return non-nil if a region exists on current buffer." + (static-if (featurep 'xemacs) + (and zmacs-regions zmacs-region-active-p) + (and transient-mark-mode mark-active))) + +(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))