X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=wl%2Fwl-util.el;h=30f0740521033d0e8cb4e2652db43ba72160242c;hb=65ba135032b2614fa07c206f8cd2d8a48ba8b9e3;hp=2b0ff82e1d1cd237b3c4ce1b18bd998cce9b7998;hpb=806725e3db0748ddc973ba045053a6681e840287;p=elisp%2Fwanderlust.git diff --git a/wl/wl-util.el b/wl/wl-util.el index 2b0ff82..30f0740 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). @@ -28,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) @@ -56,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\" @@ -147,32 +141,12 @@ 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))) (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) @@ -191,47 +165,58 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, (wl-push (cdr keve) unread-command-events)))) ;(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 + (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))) @@ -286,7 +271,7 @@ If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, 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) @@ -307,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)) @@ -322,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 () @@ -414,8 +382,9 @@ changing the value of `foo'." alist) (defun wl-inverse-alist (keys alist) - "Inverse ALIST, copying. Return an association list represents -the inverse mapping of ALIST, from objects to KEYS. + "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 @@ -543,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) @@ -569,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 @@ -581,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 @@ -605,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) @@ -668,24 +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 () - (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)) ;;; @@ -737,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. @@ -814,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. @@ -834,26 +829,37 @@ This function is imported from Emacs 20.7." (message "Checking new mails...")) (let ((new-mails 0) (flist (or wl-biff-check-folder-list (list wl-default-folder))) - (elmo-network-session-name-prefix "BIFF-") 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 (+ new-mails - (nth 0 (wl-folder-check-one-entity folder)))))) + (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 (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) @@ -862,18 +868,119 @@ This function is imported from Emacs 20.7." (defun wl-biff-check-folder-async (folder notify-minibuf) (when (elmo-folder-plugged-p folder) - (if (and (eq (elmo-folder-get-type folder) 'imap4) - (wl-folder-use-server-diff-p folder)) + (elmo-folder-set-biff-internal folder t) + (if (and (eq (elmo-folder-type-internal folder) 'imap4) + (elmo-folder-use-flag-p folder)) ;; Check asynchronously only when IMAP4 and use server diff. (progn (setq elmo-folder-diff-async-callback 'wl-biff-check-folder-async-callback) (setq elmo-folder-diff-async-callback-data - (list folder (get-buffer wl-folder-buffer-name) + (list (elmo-folder-name-internal folder) + (get-buffer wl-folder-buffer-name) notify-minibuf)) (elmo-folder-diff-async folder)) - (wl-biff-notify (car (wl-folder-check-one-entity folder)) - notify-minibuf) - (setq wl-biff-check-folders-running nil)))) + (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)))) + +(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)) ;;; wl-util.el ends here