X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-util.el;h=c493d00f8fd9f0f50e41bd7ed525cb77ac37fdc1;hb=ee2dd54f276eeeca395eccf46c125c45bce5c6d8;hp=84f7df7fedae5843184994c34e629f6c71cfc135;hpb=be8d7b821412989340e00791d88ba789fa044e7e;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-util.el b/elmo/elmo-util.el index 84f7df7..c493d00 100644 --- a/elmo/elmo-util.el +++ b/elmo/elmo-util.el @@ -1,6 +1,6 @@ ;;; elmo-util.el -- Utilities for Elmo. -;; Copyright 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi ;; Author: Yuuichi Teranishi ;; Keywords: mail, net news @@ -36,16 +36,6 @@ (require 'eword-decode) (require 'utf7) -(eval-when-compile - (condition-case nil - (progn - (require 'ssl) - (require 'starttls)) - (error)) - (defun-maybe starttls-negotiate (a)) - (defun-maybe starttls-open-stream (a b c d)) - (defun-maybe open-ssl-stream (a b c d))) - (defmacro elmo-set-buffer-multibyte (flag) "Set the multibyte flag of the current buffer to FLAG." (cond ((boundp 'MULE) @@ -69,7 +59,7 @@ ;; base64 encoding/decoding (require 'mel) -(fset 'elmo-base64-encode-string +(fset 'elmo-base64-encode-string (mel-find-function 'mime-encode-string "base64")) (fset 'elmo-base64-decode-string (mel-find-function 'mime-decode-string "base64")) @@ -78,113 +68,10 @@ ;; Check make-symbolic-link() instead. -- 981002 by Fuji (if (fboundp 'make-symbolic-link) ;; xxx (defalias 'elmo-add-name-to-file 'add-name-to-file) - (defun elmo-add-name-to-file + (defun elmo-add-name-to-file (filename newname &optional ok-if-already-exists) (copy-file filename newname ok-if-already-exists t))) -(require 'broken) -(broken-facility timezone-y2k - "timezone.el does not clear Y2K." - (or (not (featurep 'timezone)) - (string= (aref (timezone-parse-date "Sat, 1 Jan 00 07:00:00 JST") 0) - "2000"))) - -(when-broken timezone-y2k - (defun timezone-parse-date (date) - "Parse DATE and return a vector [YEAR MONTH DAY TIME TIMEZONE]. -19 is prepended to year if necessary. Timezone may be nil if nothing. -Understands the following styles: - (1) 14 Apr 89 03:20[:12] [GMT] - (2) Fri, 17 Mar 89 4:01[:33] [GMT] - (3) Mon Jan 16 16:12[:37] [GMT] 1989 - (4) 6 May 1992 1641-JST (Wednesday) - (5) 22-AUG-1993 10:59:12.82 - (6) Thu, 11 Apr 16:17:12 91 [MET] - (7) Mon, 6 Jul 16:47:20 T 1992 [MET]" - (condition-case nil - (progn - ;; Get rid of any text properties. - (and (stringp date) - (or (text-properties-at 0 date) - (next-property-change 0 date)) - (setq date (copy-sequence date)) - (set-text-properties 0 (length date) nil date)) - (let ((date (or date "")) - (year nil) - (month nil) - (day nil) - (time nil) - (zone nil)) ;This may be nil. - (cond ((string-match - "\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\'" date) - ;; Styles: (6) and (7) without timezone - (setq year 6 month 3 day 2 time 4 zone nil)) - ((string-match - "\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date) - ;; Styles: (6) and (7) with timezone and buggy timezone - (setq year 6 month 3 day 2 time 4 zone 7)) - ((string-match - "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]*\\'" date) - ;; Styles: (1) and (2) without timezone - (setq year 3 month 2 day 1 time 4 zone nil)) - ((string-match - "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date) - ;; Styles: (1) and (2) with timezone and buggy timezone - (setq year 3 month 2 day 1 time 4 zone 5)) - ((string-match - "\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([0-9]+\\)" date) - ;; Styles: (3) without timezone - (setq year 4 month 1 day 2 time 3 zone nil)) - ((string-match - "\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([-+a-zA-Z0-9]+\\)[ \t]+\\([0-9]+\\)" date) - ;; Styles: (3) with timezone - (setq year 5 month 1 day 2 time 3 zone 4)) - ((string-match - "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date) - ;; Styles: (4) with timezone - (setq year 3 month 2 day 1 time 4 zone 5)) - ((string-match - "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\.[0-9]+" date) - ;; Styles: (5) without timezone. - (setq year 3 month 2 day 1 time 4 zone nil)) - ) - (if year - (progn - (setq year - (substring date (match-beginning year) - (match-end year))) - (if (< (length year) 4) - (let ((yr (string-to-int year))) - (when (>= yr 100) - (setq yr (- yr 100))) - (setq year (format "%d%02d" - (if (< yr 70) - 20 - 19) - yr)))) - (let ((string (substring date - (match-beginning month) - (+ (match-beginning month) 3)))) - (setq month - (int-to-string - (cdr (assoc (upcase string) - timezone-months-assoc))))) - (setq day - (substring date (match-beginning day) (match-end day))) - (setq time - (substring date (match-beginning time) - (match-end time))))) - (if zone - (setq zone - (substring date (match-beginning zone) - (match-end zone)))) - (if year - (vector year month day time zone) - (vector "0" "0" "0" "0" nil)) - ) - ) - (t (signal 'invalid-date (list date)))))) - (defsubst elmo-call-func (folder func-name &rest args) (let* ((spec (if (stringp folder) (elmo-folder-get-spec folder) @@ -198,8 +85,16 @@ Understands the following styles: spec args))) +;; Nemacs's `read' is different. +(static-if (fboundp 'nemacs-version) + (defun elmo-read (obj) + (prog1 (read obj) + (if (bufferp obj) + (or (bobp) (forward-char -1))))) + (defalias 'elmo-read 'read)) + (defmacro elmo-set-work-buf (&rest body) - "Execute BODY on work buffer. Work buffer remains." + "Execute BODY on work buffer. Work buffer remains." (` (save-excursion (set-buffer (get-buffer-create elmo-work-buf-name)) (elmo-set-buffer-multibyte default-enable-multibyte-characters) @@ -207,13 +102,13 @@ Understands the following styles: (,@ body)))) (defmacro elmo-match-substring (pos string from) - "Substring of POSth matched string of STRING. " - (` (substring (, string) + "Substring of POSth matched string of STRING." + (` (substring (, string) (+ (match-beginning (, pos)) (, from)) (match-end (, pos))))) (defmacro elmo-match-string (pos string) - "Substring POSth matched string." + "Substring POSth matched STRING." (` (substring (, string) (match-beginning (, pos)) (match-end (, pos))))) (defmacro elmo-match-buffer (pos) @@ -243,7 +138,7 @@ File content is decoded with MIME-CHARSET." (elmo-set-buffer-multibyte default-enable-multibyte-characters) (decode-mime-charset-region (point-min) (point-max) mime-charset)) (condition-case nil - (read (current-buffer)) + (read (current-buffer)) (error (unless no-err (message "Warning: Loading object from %s failed." filename) @@ -262,7 +157,7 @@ File content is encoded with MIME-CHARSET." (if (file-writable-p filename) (progn (when mime-charset - ;;(elmo-set-buffer-multibyte default-enable-multibyte-characters) +;;; (elmo-set-buffer-multibyte default-enable-multibyte-characters) (encode-mime-charset-region (point-min) (point-max) mime-charset)) (as-binary-output-file (write-region (point-min) (point-max) filename nil 'no-msg))) @@ -274,7 +169,7 @@ Directory of the file is created if it doesn't exist. File content is encoded with MIME-CHARSET." (elmo-set-work-buf (prin1 object (current-buffer)) - ;;(princ "\n" (current-buffer)) +;;;(princ "\n" (current-buffer)) (elmo-save-buffer filename mime-charset))) (defsubst elmo-imap4-decode-folder-string (string) @@ -287,57 +182,60 @@ File content is encoded with MIME-CHARSET." (utf7-encode-string string 'imap) string)) -(defun elmo-network-get-spec (folder default-server default-port default-tls) - (let (server port tls) - (if (string-match "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!*\\)$" folder) - (progn - (if (match-beginning 1) - (setq server (elmo-match-substring 1 folder 1)) - (setq server default-server)) - (if (match-beginning 2) - (setq port - (string-to-int (elmo-match-substring 2 folder 1))) - (setq port default-port)) - (setq tls (elmo-match-string 3 folder)) - (if (and (match-beginning 3) - (> (length tls) 0)) - (setq tls (if (= 2 (length tls)) 'starttls - (string= tls "!"))) - (setq tls default-tls)) - (setq folder (substring folder 0 (match-beginning 0)))) - (setq server default-server - port default-port - tls default-tls)) - (cons folder (list server port tls)))) +(defun elmo-get-network-stream-type (stream-type stream-type-alist) + (catch 'found + (while stream-type-alist + (if (eq (nth 1 (car stream-type-alist)) stream-type) + (throw 'found (car stream-type-alist))) + (setq stream-type-alist (cdr stream-type-alist))))) + +(defun elmo-network-get-spec (folder server port stream-type stream-type-alist) + (setq stream-type (elmo-get-network-stream-type + stream-type stream-type-alist)) + (when (string-match "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!.*\\)?$" folder) + (if (match-beginning 1) + (setq server (elmo-match-substring 1 folder 1))) + (if (match-beginning 2) + (setq port (string-to-int (elmo-match-substring 2 folder 1)))) + (if (match-beginning 3) + (setq stream-type (assoc (elmo-match-string 3 folder) + stream-type-alist))) + (setq folder (substring folder 0 (match-beginning 0)))) + (cons folder (list server port stream-type))) (defun elmo-imap4-get-spec (folder) - (let ((default-user elmo-default-imap4-user) - (default-server elmo-default-imap4-server) - (default-port elmo-default-imap4-port) - (default-tls elmo-default-imap4-ssl) + (let ((default-user elmo-default-imap4-user) + (default-server elmo-default-imap4-server) + (default-port elmo-default-imap4-port) + (default-stream-type elmo-default-imap4-stream-type) + (stream-type-alist elmo-network-stream-type-alist) spec mailbox user auth) (when (string-match "\\(.*\\)@\\(.*\\)" default-server) - ;; case: default-imap4-server is specified like + ;; case: default-imap4-server is specified like ;; "hoge%imap.server@gateway". (setq default-user (elmo-match-string 1 default-server)) (setq default-server (elmo-match-string 2 default-server))) - (setq spec (elmo-network-get-spec - folder default-server default-port default-tls)) + (if elmo-imap4-stream-type-alist + (setq stream-type-alist + (append elmo-imap4-stream-type-alist stream-type-alist))) + (setq spec (elmo-network-get-spec + folder default-server default-port default-stream-type + stream-type-alist)) (setq folder (car spec)) (when (string-match "^\\(%\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?" folder) (progn - (setq mailbox (if (match-beginning 2) + (setq mailbox (if (match-beginning 2) (elmo-match-string 2 folder) elmo-default-imap4-mailbox)) (setq user (if (match-beginning 3) (elmo-match-substring 3 folder 1) default-user)) (setq auth (if (match-beginning 4) - (elmo-match-substring 4 folder 1) + (intern (elmo-match-substring 4 folder 1)) elmo-default-imap4-authenticate-type)) - (append (list 'imap4 + (append (list 'imap4 (elmo-imap4-encode-folder-string mailbox) user auth) (cdr spec)))))) @@ -357,11 +255,11 @@ File content is encoded with MIME-CHARSET." (defsubst elmo-imap4-spec-port (spec) (nth 5 spec)) -(defsubst elmo-imap4-spec-ssl (spec) +(defsubst elmo-imap4-spec-stream-type (spec) (nth 6 spec)) -(defsubst elmo-imap4-spec-folder (spec) ;; obsolete - (nth 1 spec)) +(defalias 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox) +(make-obsolete 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox) (defsubst elmo-imap4-connection-get-process (conn) (nth 1 conn)) @@ -373,20 +271,25 @@ File content is encoded with MIME-CHARSET." (nth 2 conn)) (defun elmo-nntp-get-spec (folder) - (let (spec group user) + (let ((stream-type-alist elmo-network-stream-type-alist) + spec group user) + (if elmo-nntp-stream-type-alist + (setq stream-type-alist + (append elmo-nntp-stream-type-alist stream-type-alist))) (setq spec (elmo-network-get-spec folder elmo-default-nntp-server elmo-default-nntp-port - elmo-default-nntp-ssl)) + elmo-default-nntp-stream-type + stream-type-alist)) (setq folder (car spec)) (when (string-match "^\\(-\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?" folder) - (setq group + (setq group (if (match-beginning 2) (elmo-match-string 2 folder))) - (setq user - (if (match-beginning 3) + (setq user + (if (match-beginning 3) (elmo-match-substring 3 folder 1) elmo-default-nntp-user)) (append (list 'nntp group user) @@ -395,7 +298,7 @@ File content is encoded with MIME-CHARSET." (defsubst elmo-nntp-spec-group (spec) (nth 1 spec)) -(defsubst elmo-nntp-spec-username (spec) +(defsubst elmo-nntp-spec-username (spec) (nth 2 spec)) ;; future use? @@ -407,7 +310,7 @@ File content is encoded with MIME-CHARSET." (defsubst elmo-nntp-spec-port (spec) (nth 4 spec)) -(defsubst elmo-nntp-spec-ssl (spec) +(defsubst elmo-nntp-spec-stream-type (spec) (nth 5 spec)) (defun elmo-localdir-get-spec (folder) @@ -421,9 +324,9 @@ File content is encoded with MIME-CHARSET." ) (if (file-name-absolute-p fld-name) (setq path (expand-file-name fld-name)) +;;; (setq path (expand-file-name fld-name +;;; elmo-localdir-folder-path)) (setq path fld-name)) - ;(setq path (expand-file-name fld-name - ;elmo-localdir-folder-path))) (list (if (elmo-folder-maildir-p folder) 'maildir 'localdir) path)))) @@ -458,7 +361,7 @@ File content is encoded with MIME-CHARSET." (elmo-match-string 2 folder))) 0) (setq fld-name "") ) - (list 'localnews + (list 'localnews (elmo-replace-in-string fld-name "\\." "/"))))) (defun elmo-cache-get-spec (folder) @@ -494,11 +397,16 @@ File content is encoded with MIME-CHARSET." (list 'archive fld-name (intern-soft type) prefix)))) (defun elmo-pop3-get-spec (folder) - (let (spec user auth) + (let ((stream-type-alist elmo-network-stream-type-alist) + spec user auth) + (if elmo-pop3-stream-type-alist + (setq stream-type-alist + (append elmo-pop3-stream-type-alist stream-type-alist))) (setq spec (elmo-network-get-spec folder elmo-default-pop3-server elmo-default-pop3-port - elmo-default-pop3-ssl)) + elmo-default-pop3-stream-type + stream-type-alist)) (setq folder (car spec)) (when (string-match "^\\(&\\)\\([^:/!]*\\)\\(/[^/:@!]+\\)?" @@ -508,7 +416,7 @@ File content is encoded with MIME-CHARSET." (if (eq (length user) 0) (setq user elmo-default-pop3-user)) (setq auth (if (match-beginning 3) - (elmo-match-substring 3 folder 1) + (intern (elmo-match-substring 3 folder 1)) elmo-default-pop3-authenticate-type)) (append (list 'pop3 user auth) (cdr spec))))) @@ -525,7 +433,7 @@ File content is encoded with MIME-CHARSET." (defsubst elmo-pop3-spec-port (spec) (nth 4 spec)) -(defsubst elmo-pop3-spec-ssl (spec) +(defsubst elmo-pop3-spec-stream-type (spec) (nth 5 spec)) (defun elmo-internal-get-spec (folder) @@ -550,23 +458,13 @@ File content is encoded with MIME-CHARSET." ","))))) (defun elmo-filter-get-spec (folder) - (save-match-data - (when (string-match - "^\\(/\\)\\(.*\\)$" - folder) - (let ((spec (elmo-match-string 2 folder)) - filter) - (when (string-match "\\([^/]+\\)/" spec) - (setq filter (elmo-match-string 1 spec)) - (setq spec (substring spec (match-end 0)))) - (cond - ((string-match "^\\(last\\|first\\):\\(.*\\)$" filter) ; partial - (setq filter (vector 'partial - (elmo-match-string 1 filter) - (elmo-match-string 2 filter)))) - (t - (setq filter (elmo-parse-search-condition filter)))) - (list 'filter filter spec))))) + (when (string-match "^\\(/\\)\\(.*\\)$" folder) + (let ((folder (elmo-match-string 2 folder)) + pair) + (setq pair (elmo-parse-search-condition folder)) + (if (string-match "^ */\\(.*\\)$" (cdr pair)) + (list 'filter (car pair) (elmo-match-string 1 (cdr pair))) + (error "Folder syntax error `%s'" folder))))) (defun elmo-pipe-get-spec (folder) (when (string-match "^\\(|\\)\\([^|]*\\)|\\(.*\\)$" folder) @@ -575,53 +473,155 @@ File content is encoded with MIME-CHARSET." (elmo-match-string 3 folder)))) (defun elmo-folder-get-spec (folder) - "return spec of folder" + "Return spec of FOLDER." (let ((type (elmo-folder-get-type folder))) (if type - (funcall (intern (concat "elmo-" (symbol-name type) "-get-spec")) - folder) + (save-match-data + (funcall (intern (concat "elmo-" (symbol-name type) "-get-spec")) + folder)) (error "%s is not supported folder type" folder)))) -(defun elmo-parse-search-condition (condition) - (let ((terms (split-string condition "|")) ; split by OR - term ret-val) - (while terms - (setq term (car terms)) - (cond - ((string-match "^\\([a-zA-Z\\-]+\\)=\\(.*\\)$" term) - (if (save-match-data - (string-match "tocc" (elmo-match-string 1 term))) ;; syntax sugar - (setq ret-val (nconc - ret-val - (list (vector 'match "to" - (elmo-match-string 2 term)) - (vector 'match "cc" - (elmo-match-string 2 term))))) - (setq ret-val (cons (vector 'match - (elmo-match-string 1 term) - (elmo-match-string 2 term)) - ret-val)))) - ((string-match "^\\([a-zA-Z\\-]+\\)!=\\(.*\\)$" term) - (if (save-match-data - (string-match "tocc" (elmo-match-string 1 term))) ;; syntax sugar - (setq ret-val (nconc - ret-val - (list (vector 'unmatch "to" - (elmo-match-string 2 term)) - (vector 'unmatch "cc" - (elmo-match-string 2 term))))) - (setq ret-val (cons (vector 'unmatch - (elmo-match-string 1 term) - (elmo-match-string 2 term)) - ret-val)))) - ((string-match "^\\(since\\|before\\):\\(.*\\)$" term) - (setq ret-val (cons (vector 'date - (elmo-match-string 1 term) - (elmo-match-string 2 term)) - ret-val)))) - (setq terms (cdr terms))) - ret-val)) +;;; Search Condition + +(defconst elmo-condition-atom-regexp "[^/ \")|&]*") + +(defun elmo-read-search-condition (default) + "Read search condition string interactively." + (elmo-read-search-condition-internal "Search by" default)) + +(defun elmo-read-search-condition-internal (prompt default) + (let* ((completion-ignore-case t) + (field (completing-read + (format "%s (%s): " prompt default) + (mapcar 'list + (append '("AND" "OR" + "Last" "First" + "From" "Subject" "To" "Cc" "Body" + "Since" "Before" "ToCc" + "!From" "!Subject" "!To" "!Cc" "!Body" + "!Since" "!Before" "!ToCc") + elmo-msgdb-extra-fields)))) + value) + (setq field (if (string= field "") + (setq field default) + field)) + (cond + ((or (string= field "AND") (string= field "OR")) + (concat "(" + (elmo-read-search-condition-internal + (concat field "(1) Search by") default) + (if (string= field "AND") "&" "|") + (elmo-read-search-condition-internal + (concat field "(2) Search by") default) + ")")) + ((string-match "Since\\|Before" field) + (concat (downcase field) ":" + (completing-read (format "Value for '%s': " field) + (mapcar (function + (lambda (x) + (list (format "%s" (car x))))) + elmo-date-descriptions)))) + (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))))) + +(defsubst elmo-condition-parse-error () + (error "Syntax error in '%s'" (buffer-string))) +(defun elmo-parse-search-condition (condition) + "Parse CONDITION. +Return value is a cons cell of (STRUCTURE . REST)" + (with-temp-buffer + (insert condition) + (goto-char (point-min)) + (cons (elmo-condition-parse) (buffer-substring (point) (point-max))))) + +;; condition ::= or-expr +(defun elmo-condition-parse () + (or (elmo-condition-parse-or-expr) + (elmo-condition-parse-error))) + +;; or-expr ::= and-expr / +;; and-expr "|" or-expr +(defun elmo-condition-parse-or-expr () + (let ((left (elmo-condition-parse-and-expr))) + (if (looking-at "| *") + (progn + (goto-char (match-end 0)) + (list 'or left (elmo-condition-parse-or-expr))) + left))) + +;; and-expr ::= primitive / +;; primitive "&" and-expr +(defun elmo-condition-parse-and-expr () + (let ((left (elmo-condition-parse-primitive))) + (if (looking-at "& *") + (progn + (goto-char (match-end 0)) + (list 'and left (elmo-condition-parse-and-expr))) + left))) + +;; primitive ::= "(" expr ")" / +;; ["!"] search-key SPACE* ":" SPACE* search-value +(defun elmo-condition-parse-primitive () + (cond + ((looking-at "( *") + (goto-char (match-end 0)) + (prog1 (elmo-condition-parse) + (unless (looking-at ") *") + (elmo-condition-parse-error)) + (goto-char (match-end 0)))) +;; search-key ::= [A-Za-z-]+ +;; ;; "since" / "before" / "last" / "first" / +;; ;; "body" / field-name + ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *") + (goto-char (match-end 0)) + (let ((search-key (vector + (if (match-beginning 1) 'unmatch 'match) + (elmo-match-buffer 2) + (elmo-condition-parse-search-value)))) + ;; syntax sugar. + (if (string= (aref search-key 1) "tocc") + (if (eq (aref search-key 0) 'match) + (list 'or + (vector 'match "to" (aref search-key 2)) + (vector 'match "cc" (aref search-key 2))) + (list 'and + (vector 'unmatch "to" (aref search-key 2)) + (vector 'unmatch "cc" (aref search-key 2)))) + search-key))))) + +;; search-value ::= quoted / time / number / atom +;; quoted ::= +;; time ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" / +;; number SPACE* "daysago" / +;; number "-" month "-" number ; ex. 10-May-2000 +;; number ::= [0-9]+ +;; month ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" / +;; "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec" +;; atom ::= ATOM_CHARS* +;; SPACE ::= +;; ATOM_CHARS ::= +;; specials ::= SPACE / <"> / / <)> / <|> / <&> +;; ;; These characters should be quoted. +(defun elmo-condition-parse-search-value () + (cond + ((looking-at "\"") + (elmo-read (current-buffer))) + ((or (looking-at "yesterday") (looking-at "lastweek") + (looking-at "lastmonth") (looking-at "lastyear") + (looking-at "[0-9]+ *daysago") + (looking-at "[0-9]+-[A-Za-z]+-[0-9]+") + (looking-at "[0-9]+") + (looking-at elmo-condition-atom-regexp)) + (prog1 (elmo-match-buffer 0) + (goto-char (match-end 0)))) + (t (error "Syntax error '%s'" (buffer-string))))) + +;;; (defun elmo-multi-get-real-folder-number (folder number) (let* ((spec (elmo-folder-get-spec folder)) (flds (cdr spec)) @@ -667,7 +667,11 @@ File content is encoded with MIME-CHARSET." (defun elmo-uniq-list (lst) "Distractively uniqfy elements of LST." (let ((tmp lst)) - (while tmp (setq tmp (setcdr tmp (and (cdr tmp) (delete (car tmp) (cdr tmp))))))) + (while tmp (setq tmp + (setcdr tmp + (and (cdr tmp) + (delete (car tmp) + (cdr tmp))))))) lst) (defun elmo-string-partial-p (string) @@ -692,12 +696,12 @@ File content is encoded with MIME-CHARSET." (elmo-set-work-buf (as-binary-output-file (insert string) - (write-region (point-min) (point-max) + (write-region (point-min) (point-max) filename nil 'no-msg)) ))) (defun elmo-max-of-list (nlist) - (let ((l nlist) + (let ((l nlist) (max-num 0)) (while l (if (< max-num (car l)) @@ -720,7 +724,7 @@ File content is encoded with MIME-CHARSET." elmo-msgdb-dir)) (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")) insert-file-contents-pre-hook ; To avoid autoconv-xmas... - insert-file-contents-post-hook + insert-file-contents-post-hook ret-val) (if (not (file-readable-p filename)) () @@ -728,11 +732,16 @@ File content is encoded with MIME-CHARSET." (insert-file-contents filename) (setq ret-val (condition-case nil - (read (current-buffer)) + (read (current-buffer)) (error nil nil)))) (kill-buffer tmp-buffer) ret-val))) +(defun elmo-passwd-alist-clear () + "Clear password cache." + (interactive) + (setq elmo-passwd-alist nil)) + (defun elmo-passwd-alist-save () "Save password into file." (interactive) @@ -744,39 +753,45 @@ File content is encoded with MIME-CHARSET." (erase-buffer) (prin1 elmo-passwd-alist tmp-buffer) (princ "\n" tmp-buffer) -; (if (and (file-exists-p filename) -; (not (equal 384 (file-modes filename)))) -; (error "%s is not safe.chmod 600 %s!" filename filename)) +;;; (if (and (file-exists-p filename) +;;; (not (equal 384 (file-modes filename)))) +;;; (error "%s is not safe.chmod 600 %s!" filename filename)) (if (file-writable-p filename) (progn - (write-region (point-min) (point-max) + (write-region (point-min) (point-max) filename nil 'no-msg) (set-file-modes filename 384)) (message (format "%s is not writable." filename))) (kill-buffer tmp-buffer)))) -(defun elmo-get-passwd (user-at-host) +(defun elmo-get-passwd (key) "Get password from password pool." - (let (data pass) + (let (pair pass) (if (not elmo-passwd-alist) (setq elmo-passwd-alist (elmo-passwd-alist-load))) - (setq data (assoc user-at-host elmo-passwd-alist)) - (if data - (elmo-base64-decode-string (cdr data)) - (setq pass (elmo-read-passwd (format "Password for %s: " - user-at-host) t)) + (setq pair (assoc key elmo-passwd-alist)) + (if pair + (elmo-base64-decode-string (cdr pair)) + (setq pass (elmo-read-passwd (format "Password for %s: " + key) t)) (setq elmo-passwd-alist (append elmo-passwd-alist - (list (cons user-at-host + (list (cons key (elmo-base64-encode-string pass))))) + (if elmo-passwd-life-time + (run-with-timer elmo-passwd-life-time nil + (` (lambda () (elmo-remove-passwd (, key)))))) pass))) -(defun elmo-remove-passwd (user-at-host) +(defun elmo-remove-passwd (key) "Remove password from password pool (for failure)." - (setq elmo-passwd-alist - (delete (assoc user-at-host elmo-passwd-alist) - elmo-passwd-alist - ))) + (let (pass-cons) + (if (setq pass-cons (assoc key elmo-passwd-alist)) + (progn + (unwind-protect + (fillarray (cdr pass-cons) 0)) + (setq elmo-passwd-alist + (delete pass-cons elmo-passwd-alist)))))) (defmacro elmo-read-char-exclusive () (cond ((featurep 'xemacs) @@ -833,8 +848,8 @@ File content is encoded with MIME-CHARSET." ;; from subr.el (defun elmo-replace-in-string (str regexp newtext &optional literal) - "Replaces all matches in STR for REGEXP with NEWTEXT string, - and returns the new string. + "Replace all matches in STR for REGEXP with NEWTEXT string. +And returns the new string. Optional LITERAL non-nil means do a literal replacement. Otherwise treat \\ in NEWTEXT string as special: \\& means substitute original matched text, @@ -849,29 +864,29 @@ Otherwise treat \\ in NEWTEXT string as special: start (match-end 0) rtn-str (concat - rtn-str - (substring str prev-start match) - (cond (literal newtext) - (t (mapconcat - (function - (lambda (c) - (if special - (progn - (setq special nil) - (cond ((eq c ?\\) "\\") - ((eq c ?&) - (elmo-match-string 0 str)) - ((and (>= c ?0) (<= c ?9)) - (if (> c (+ ?0 (length - (match-data)))) - ; Invalid match num - (error "Invalid match num: %c" c) - (setq c (- c ?0)) - (elmo-match-string c str))) - (t (char-to-string c)))) - (if (eq c ?\\) (progn (setq special t) nil) - (char-to-string c))))) - newtext "")))))) + rtn-str + (substring str prev-start match) + (cond (literal newtext) + (t (mapconcat + (function + (lambda (c) + (if special + (progn + (setq special nil) + (cond ((eq c ?\\) "\\") + ((eq c ?&) + (elmo-match-string 0 str)) + ((and (>= c ?0) (<= c ?9)) + (if (> c (+ ?0 (length + (match-data)))) + ;; Invalid match num + (error "Invalid match num: %c" c) + (setq c (- c ?0)) + (elmo-match-string c str))) + (t (char-to-string c)))) + (if (eq c ?\\) (progn (setq special t) nil) + (char-to-string c))))) + newtext "")))))) (concat rtn-str (substring str start)))) (defun elmo-string-to-list (string) @@ -981,7 +996,7 @@ Otherwise treat \\ in NEWTEXT string as special: (defun elmo-delete-plugged (&optional server port alist) (let* ((alist (or alist elmo-plugged-alist)) (alist2 alist)) - (cond ((and (not port) (not server)) + (cond ((and (not port) (not server)) (setq alist nil)) ((not port) ;; delete plugged all port of server @@ -992,16 +1007,16 @@ Otherwise treat \\ in NEWTEXT string as special: (t ;; delete plugged one port of server (setq alist - (delete (assoc (cons server port) alist)) alist))) + (delete (assoc (cons server port) alist) alist)))) alist)) (defun elmo-disk-usage (path) "Get disk usage (bytes) in PATH." - (let ((file-attr + (let ((file-attr (condition-case () (file-attributes path) (error nil)))) (if file-attr (if (nth 0 file-attr) ; directory - (let ((files (condition-case () + (let ((files (condition-case () (directory-files path t "^[^\\.]") (error nil))) (result 0.0)) @@ -1013,7 +1028,7 @@ Otherwise treat \\ in NEWTEXT string as special: (float (nth 7 file-attr)))))) (defun elmo-get-last-accessed-time (path &optional dir) - "Returns last accessed time." + "Return the last accessed time of PATH." (let ((last-accessed (nth 4 (file-attributes (or (and dir (expand-file-name path dir)) @@ -1024,7 +1039,7 @@ Otherwise treat \\ in NEWTEXT string as special: 0))) (defun elmo-get-last-modification-time (path &optional dir) - "Returns last accessed time." + "Return the last accessed time of PATH." (let ((last-modified (nth 5 (file-attributes (or (and dir (expand-file-name path dir)) @@ -1033,17 +1048,16 @@ Otherwise treat \\ in NEWTEXT string as special: (float 65536)) (nth 1 last-modified))))) (defun elmo-make-directory (path) - "create directory recursively." + "Create directory recursively." (let ((parent (directory-file-name (file-name-directory path)))) (if (null (file-directory-p parent)) (elmo-make-directory parent)) (make-directory path) (if (string= path (expand-file-name elmo-msgdb-dir)) - (set-file-modes path 448) ; 700 - ))) + (set-file-modes path (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700 (defun elmo-delete-directory (path &optional no-hierarchy) - "delete directory recursively." + "Delete directory recursively." (let ((dirent (directory-files path)) relpath abspath hierarchy) (while dirent @@ -1085,14 +1099,14 @@ Otherwise treat \\ in NEWTEXT string as special: (while numbers (setq cur-number (+ cur-number 1)) (setq one-list nil) - (while (and numbers + (while (and numbers (eq 0 (/ (- (car numbers) (* elmo-multi-divide-number cur-number)) elmo-multi-divide-number))) (setq one-list (nconc - one-list - (list + one-list + (list (if as-is (car numbers) (% (car numbers) @@ -1110,7 +1124,7 @@ Otherwise treat \\ in NEWTEXT string as special: ret-val)) (defun elmo-list-diff (list1 list2 &optional mes) - (if mes + (if mes (message mes)) (let ((clist1 (copy-sequence list1)) (clist2 (copy-sequence list2))) @@ -1125,7 +1139,7 @@ Otherwise treat \\ in NEWTEXT string as special: (list clist1 clist2))) (defun elmo-list-bigger-diff (list1 list2 &optional mes) - "Returns a list (- +). + is bigger than max of LIST1, in LIST2" + "Returns a list (- +). + is bigger than max of LIST1, in LIST2." (if (null list2) (cons list1 nil) (let* ((l1 list1) @@ -1158,7 +1172,7 @@ Otherwise treat \\ in NEWTEXT string as special: result dels news) (while (or list1-list list2-list) - (setq result (elmo-list-bigger-diff (car list1-list) (car list2-list) + (setq result (elmo-list-bigger-diff (car list1-list) (car list2-list) mes)) (setq dels (append dels (car result))) (setq news (append news (cadr result))) @@ -1176,16 +1190,18 @@ Otherwise treat \\ in NEWTEXT string as special: t)) (defun elmo-folder-identical-system-p (folder1 folder2) - "folder1 and folder2 should be real folder (not virtual)." + "FOLDER1 and FOLDER2 should be real folder (not virtual)." (cond ((eq (elmo-folder-get-type folder1) 'imap4) (let ((spec1 (elmo-folder-get-spec folder1)) (spec2 (elmo-folder-get-spec folder2))) - (and (elmo-imap4-identical-name-space-p - (nth 1 spec1) (nth 1 spec2)) - (string= (elmo-imap4-spec-hostname spec1) - (elmo-imap4-spec-hostname spec2)) ; hostname - (string= (elmo-imap4-spec-username spec1) - (elmo-imap4-spec-username spec2))))) ; username + (and +;;; No use. +;;; (elmo-imap4-identical-name-space-p +;;; (nth 1 spec1) (nth 1 spec2)) + (string= (elmo-imap4-spec-hostname spec1) + (elmo-imap4-spec-hostname spec2)) ; hostname + (string= (elmo-imap4-spec-username spec1) + (elmo-imap4-spec-username spec2))))) ; username (t (elmo-folder-direct-copy-p folder1 folder2)))) @@ -1213,85 +1229,94 @@ Otherwise treat \\ in NEWTEXT string as special: (defmacro elmo-filter-value (filter) (` (aref (, filter) 2))) -(defsubst elmo-buffer-field-condition-match (condition) - (let (term) - (catch 'done - (while condition - (goto-char (point-min)) - (setq term (car condition)) - (cond - ((and (eq (elmo-filter-type term) 'date) - (string= (elmo-filter-key term) "since")) - (let ((date (elmo-date-get-datevec (elmo-filter-value term)))) - (if (string< - (timezone-make-sortable-date (aref date 0) - (aref date 1) - (aref date 2) - (timezone-make-time-string - (aref date 3) - (aref date 4) - (aref date 5))) - (timezone-make-date-sortable (std11-field-body "date"))) - (throw 'done t)))) - ((and (eq (elmo-filter-type term) 'date) - (string= (elmo-filter-key term) "before")) - (let ((date (elmo-date-get-datevec (elmo-filter-value term)))) - (if (string< - (timezone-make-date-sortable (std11-field-body "date")) - (timezone-make-sortable-date (aref date 0) - (aref date 1) - (aref date 2) - (timezone-make-time-string - (aref date 3) - (aref date 4) - (aref date 5)))) - (throw 'done t)))) - ((eq (elmo-filter-type term) 'match) - (if (string= "body" (elmo-filter-key term)) - (progn - (re-search-forward "^$" nil t) ; goto body - (if (search-forward (elmo-filter-value term) nil t) - (throw 'done t))) - (let ((fval (eword-decode-string - (or (std11-field-body (elmo-filter-key term)) "")))) - (if (and fval (string-match (elmo-filter-value term) - fval)) - (throw 'done t))))) - ((eq (elmo-filter-type term) 'unmatch) - (if (string= "body" (elmo-filter-key term)) - (progn - (re-search-forward "^$" nil t) ; goto body - (if (not (search-forward (elmo-filter-value term) nil t)) - (throw 'done t))) - (let ((fval (eword-decode-string - (or (std11-field-body (elmo-filter-key term)) "")))) - (if fval - (if (not (string-match (elmo-filter-value term) - fval)) - (throw 'done t)) - (throw 'done t)))))) ; OK? - (setq condition (cdr condition))) - (throw 'done nil)))) - -(defsubst elmo-file-field-condition-match (file condition) +(defsubst elmo-buffer-field-primitive-condition-match (condition + number + number-list) + (let (result) + (goto-char (point-min)) + (cond + ((string= (elmo-filter-key condition) "last") + (setq result (<= (length (memq number number-list)) + (string-to-int (elmo-filter-value condition))))) + ((string= (elmo-filter-key condition) "first") + (setq result (< (- (length number-list) + (length (memq number number-list))) + (string-to-int (elmo-filter-value condition))))) + ((string= (elmo-filter-key condition) "since") + (let ((date (elmo-date-get-datevec (elmo-filter-value condition)))) + (setq result + (string< + (timezone-make-sortable-date (aref date 0) + (aref date 1) + (aref date 2) + (timezone-make-time-string + (aref date 3) + (aref date 4) + (aref date 5))) + (timezone-make-date-sortable (std11-field-body "date")))))) + ((string= (elmo-filter-key condition) "before") + (let ((date (elmo-date-get-datevec (elmo-filter-value condition)))) + (setq result + (string< + (timezone-make-date-sortable (std11-field-body "date")) + (timezone-make-sortable-date (aref date 0) + (aref date 1) + (aref date 2) + (timezone-make-time-string + (aref date 3) + (aref date 4) + (aref date 5))))))) + ((string= (elmo-filter-key condition) "body") + (and (re-search-forward "^$" nil t) ; goto body + (setq result (search-forward (elmo-filter-value condition) + nil t)))) + (t + (let ((fval (std11-field-body (elmo-filter-key condition)))) + (if (eq (length fval) 0) (setq fval nil)) + (if fval (setq fval (eword-decode-string fval))) + (setq result (and fval (string-match + (elmo-filter-value condition) fval)))))) + (if (eq (elmo-filter-type condition) 'unmatch) + (setq result (not result))) + result)) + +(defun elmo-condition-find-key-internal (condition key) + (cond + ((vectorp condition) + (if (string= (elmo-filter-key condition) key) + (throw 'found t))) + ((or (eq (car condition) 'and) + (eq (car condition) 'or)) + (elmo-condition-find-key-internal (nth 1 condition) key) + (elmo-condition-find-key-internal (nth 2 condition) key)))) + +(defun elmo-condition-find-key (condition key) + (catch 'found + (elmo-condition-find-key-internal condition key))) + +(defun elmo-buffer-field-condition-match (condition number number-list) + (cond + ((vectorp condition) + (elmo-buffer-field-primitive-condition-match + condition number number-list)) + ((eq (car condition) 'and) + (and (elmo-buffer-field-condition-match + (nth 1 condition) number number-list) + (elmo-buffer-field-condition-match + (nth 2 condition) number number-list))) + ((eq (car condition) 'or) + (or (elmo-buffer-field-condition-match + (nth 1 condition) number number-list) + (elmo-buffer-field-condition-match + (nth 2 condition) number number-list))))) + +(defsubst elmo-file-field-condition-match (file condition number number-list) (elmo-set-work-buf - (as-binary-input-file - (insert-file-contents file)) + (as-binary-input-file (insert-file-contents file)) (elmo-set-buffer-multibyte default-enable-multibyte-characters) + ;; Should consider charset? (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset) - (elmo-buffer-field-condition-match condition))) - -(defun elmo-cross-device-link-error-p (err) - (let ((errobj err) - cur) - (catch 'done - (while errobj - (if (and (stringp (setq cur (car errobj))) - (or (string-match "cross-device" cur) - (string-match "operation not supported" cur))) - (throw 'done t)) - (setq errobj (cdr errobj))) - nil))) + (elmo-buffer-field-condition-match condition number number-list))) (defmacro elmo-get-hash-val (string hashtable) (let ((sym (list 'intern-soft string hashtable))) @@ -1301,12 +1326,25 @@ Otherwise treat \\ in NEWTEXT string as special: (defmacro elmo-set-hash-val (string value hashtable) (list 'set (list 'intern string hashtable) value)) +(defmacro elmo-clear-hash-val (string hashtable) + (static-if (fboundp 'unintern) + (list 'unintern string hashtable) + (list 'makunbound (list 'intern string hashtable)))) + +(defmacro elmo-unintern (string) + "`unintern' symbol named STRING, When can use `unintern'. +Emacs 19.28 or earlier does not have `unintern'." + (static-if (fboundp 'unintern) + (list 'unintern string))) + ;; Make a hash table (default and minimum size is 1024). (defun elmo-make-hash (&optional hashsize) - (make-vector (if hashsize (max (elmo-create-hash-size hashsize) 1024) 1024) 0)) + (make-vector + (if hashsize (max (min (elmo-create-hash-size hashsize) + elmo-hash-maximum-size) 1024) 1024) 0)) (defsubst elmo-mime-string (string) - "Normalize MIME encoded string." + "Normalize MIME encoded STRING." (and string (let (str) (elmo-set-work-buf @@ -1368,36 +1406,36 @@ Otherwise treat \\ in NEWTEXT string as special: (defvar elmo-msgid-replace-chars nil) (defsubst elmo-replace-msgid-as-filename (msgid) - "Replace message-id string as filename." + "Replace Message-ID string (MSGID) as filename." (setq msgid (elmo-replace-in-string msgid " " " ")) (if (null elmo-msgid-replace-chars) - (setq elmo-msgid-replace-chars - (regexp-quote (mapconcat + (setq elmo-msgid-replace-chars + (regexp-quote (mapconcat 'car elmo-msgid-replace-string-alist "")))) (while (string-match (concat "[" elmo-msgid-replace-chars "]") msgid) - (setq msgid (concat + (setq msgid (concat (substring msgid 0 (match-beginning 0)) - (cdr (assoc - (substring msgid + (cdr (assoc + (substring msgid (match-beginning 0) (match-end 0)) elmo-msgid-replace-string-alist)) (substring msgid (match-end 0))))) msgid) (defsubst elmo-recover-msgid-from-filename (filename) - "Recover Message-ID from filename." + "Recover Message-ID from FILENAME." (let (tmp result) (while (string-match " " filename) - (setq tmp (substring filename + (setq tmp (substring filename (match-beginning 0) (+ (match-end 0) 1))) (if (string= tmp " ") (setq tmp " ") - (setq tmp (car (rassoc tmp + (setq tmp (car (rassoc tmp elmo-msgid-replace-string-alist)))) (setq result - (concat result + (concat result (substring filename 0 (match-beginning 0)) tmp)) (setq filename (substring filename (+ (match-end 0) 1)))) @@ -1406,28 +1444,19 @@ Otherwise treat \\ in NEWTEXT string as special: (defsubst elmo-copy-file (src dst) (condition-case err (elmo-add-name-to-file src dst t) - (error (if (elmo-cross-device-link-error-p err) - (copy-file src dst t) - (error "copy file failed"))))) - -(defmacro elmo-buffer-exists-p (buffer) - (` (when (, buffer) - (funcall (if (stringp (, buffer)) 'get-buffer 'buffer-name) - (, buffer))))) - -(defmacro elmo-kill-buffer (buffer) - (` (when (elmo-buffer-exists-p (, buffer)) - (kill-buffer (, buffer))))) - -(defun elmo-delete-lists (keys list) - "Delete all entries in LIST that equal to KEYS." - (while keys - (setq list (delete (car keys) list)) - (setq keys (cdr keys))) - list) + (error (copy-file src dst t)))) + +(defsubst elmo-buffer-exists-p (buffer) + (if (bufferp buffer) + (buffer-live-p buffer) + (get-buffer buffer))) + +(defsubst elmo-kill-buffer (buffer) + (when (elmo-buffer-exists-p buffer) + (kill-buffer buffer))) (defun elmo-delete-if (pred lst) - "Returns new list contains items which don't satisfy PRED in LST." + "Return new list contain items which don't satisfy PRED in LST." (let (result) (while lst (unless (funcall pred (car lst)) @@ -1436,14 +1465,17 @@ Otherwise treat \\ in NEWTEXT string as special: result)) (defun elmo-list-delete (list1 list2) - "Any element of list1 is deleted from list2." + "Delete by side effect any occurrences equal to elements of LIST1 from LIST2. +Return the modified LIST2. Deletion is done with `delete'. +Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing +the value of `foo'." (while list1 (setq list2 (delete (car list1) list2)) - (setq list1 (cdr list1))) + (setq list1 (cdr list1))) list2) (defun elmo-list-member (list1 list2) - "If any element of list1 is member of list2, returns t." + "If any element of LIST1 is member of LIST2, return t." (catch 'done (while list1 (if (member (car list1) list2) @@ -1461,12 +1493,12 @@ Otherwise treat \\ in NEWTEXT string as special: (if (fboundp 'display-error) (defalias 'elmo-display-error 'display-error) (defun elmo-display-error (error-object stream) - "a tiny function to display error-object to the stream." + "A tiny function to display ERROR-OBJECT to the STREAM." (let ((first t) (errobj error-object) err-mes) (while errobj - (setq err-mes (concat err-mes (format + (setq err-mes (concat err-mes (format (if (stringp (car errobj)) "%s" (if (boundp 'nemacs-version) @@ -1477,14 +1509,29 @@ Otherwise treat \\ in NEWTEXT string as special: (setq first nil)) (princ err-mes stream)))) -(if (fboundp 'lprogress-display) - (defalias 'elmo-display-progress 'lprogress-display) - (defun elmo-display-progress (label format &optional value &rest args) - "Print a progress message." - (if (and (null format) (null args)) - (message nil) - (apply (function message) (concat format " %d%%") - (nconc args (list value)))))) +(if (fboundp 'define-error) + (defalias 'elmo-define-error 'define-error) + (defun elmo-define-error (error doc &optional parents) + (or parents + (setq parents 'error)) + (let ((conds (get parents 'error-conditions))) + (or conds + (error "Not an error symbol: %s" error)) + (setplist error + (list 'error-message doc + 'error-conditions (cons error conds)))))) + +(cond ((fboundp 'lprogress-display) + (defalias 'elmo-display-progress 'lprogress-display)) + ((fboundp 'progress-feedback-with-label) + (defalias 'elmo-display-progress 'progress-feedback-with-label)) + (t + (defun elmo-display-progress (label format &optional value &rest args) + "Print a progress message." + (if (and (null format) (null args)) + (message nil) + (apply (function message) (concat format " %d%%") + (nconc args (list value))))))) (defun elmo-time-expire (before-time diff-time) (let* ((current (current-time)) @@ -1497,43 +1544,25 @@ Otherwise treat \\ in NEWTEXT string as special: (and (eq (car diff) 0) (< diff-time (nth 1 diff))))) -(defun elmo-open-network-stream (name buffer host service ssl) - (let ((auto-plugged (and elmo-auto-change-plugged - (> elmo-auto-change-plugged 0))) - process) - (if (eq ssl 'starttls) - (require 'starttls) - (if ssl (require 'ssl))) - (condition-case err - (let (process-connection-type) - (setq process - (if (eq ssl 'starttls) - (starttls-open-stream name buffer host service) - (if ssl - (open-ssl-stream name buffer host service) - (open-network-stream name buffer host service))))) - (error - (when auto-plugged - (elmo-set-plugged nil host service (current-time)) - (message "Auto plugged off at %s:%d" host service) - (sit-for 1)) - (signal (car err) (cdr err)))) - (when process - (process-kill-without-query process) - (when auto-plugged - (elmo-set-plugged t host service)) - process))) - (if (fboundp 'std11-fetch-field) (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region (defalias 'elmo-field-body 'std11-field-body)) (defmacro elmo-string (string) - "String without text property" + "STRING without text property." (` (let ((obj (copy-sequence (, string)))) (set-text-properties 0 (length obj) nil obj) obj))) +(defun elmo-flatten (list-of-list) + "Flatten LIST-OF-LIST." + (unless (null list-of-list) + (append (if (and (car list-of-list) + (listp (car list-of-list))) + (car list-of-list) + (list (car list-of-list))) + (elmo-flatten (cdr list-of-list))))) + (defun elmo-y-or-n-p (prompt &optional auto default) "Same as `y-or-n-p'. But if optional argument AUTO is non-nil, DEFAULT is returned." @@ -1542,7 +1571,7 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (y-or-n-p prompt))) (defun elmo-string-member (string slist) - "Returns t if STRING is a member of the SLIST." + "Return t if STRING is a member of the SLIST." (catch 'found (while slist (if (and (stringp (car slist)) @@ -1558,6 +1587,14 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (throw 'member (car list))) (setq list (cdr list)))))) +(defun elmo-string-matched-member (str list &optional case-ignore) + (let ((case-fold-search case-ignore)) + (catch 'member + (while list + (if (string-match str (car list)) + (throw 'member (car list))) + (setq list (cdr list)))))) + (defsubst elmo-string-delete-match (string pos) (concat (substring string 0 (match-beginning pos)) @@ -1611,6 +1648,64 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (throw 'loop a)) (setq alist (cdr alist)))))) -(provide 'elmo-util) +;;; Number set defined by OKAZAKI Tetsurou +;; +;; number ::= [0-9]+ +;; beg ::= number +;; end ::= number +;; number-range ::= "(" beg " . " end ")" ;; cons cell +;; number-set-elem ::= number / number-range +;; number-set ::= "(" *number-set-elem ")" ;; list + +(defun elmo-number-set-member (number number-set) + "Return non-nil if NUMBER is an element of NUMBER-SET. +The value is actually the tail of NUMBER-RANGE whose car contains NUMBER." + (or (memq number number-set) + (let (found) + (while (and number-set (not found)) + (if (and (consp (car number-set)) + (and (<= (car (car number-set)) number) + (<= number (cdr (car number-set))))) + (setq found t) + (setq number-set (cdr number-set)))) + number-set))) + +(defun elmo-number-set-append-list (number-set list) + "Append LIST of numbers to the NUMBER-SET. +NUMBER-SET is altered." + (let ((appended number-set)) + (while list + (setq appended (elmo-number-set-append appended (car list))) + (setq list (cdr list))) + appended)) + +(defun elmo-number-set-append (number-set number) + "Append NUMBER to the NUMBER-SET. +NUMBER-SET is altered." + (let ((number-set-1 number-set) + found elem) + (while (and number-set (not found)) + (setq elem (car number-set)) + (cond + ((and (consp elem) + (eq (+ 1 (cdr elem)) number)) + (setcdr elem number) + (setq found t)) + ((and (integerp elem) + (eq (+ 1 elem) number)) + (setcar number-set (cons elem number)) + (setq found t)) + ((or (and (integerp elem) (eq elem number)) + (and (consp elem) + (<= (car elem) number) + (<= number (cdr elem)))) + (setq found t))) + (setq number-set (cdr number-set))) + (if (not found) + (setq number-set-1 (nconc number-set-1 (list number)))) + number-set-1)) + +(require 'product) +(product-provide (provide 'elmo-util) (require 'elmo-version)) ;;; elmo-util.el ends here