X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-util.el;h=4a175fb6e5e709061d7ac4d569adcb3d38bc0d66;hb=8e6795e82e1498243ed69ef03c69bf7a70944cd8;hp=362a3614154b4d1238d8f6460c5e004b9c39321b;hpb=2e9f5d2e3f003da464c20fe9924d1e80849265e6;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-util.el b/elmo/elmo-util.el index 362a361..feecd12 100644 --- a/elmo/elmo-util.el +++ b/elmo/elmo-util.el @@ -1,6 +1,6 @@ -;;; elmo-util.el -- Utilities for Elmo. +;;; 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 @@ -24,38 +24,24 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; +(eval-when-compile (require 'cl)) (require 'elmo-vars) (require 'elmo-date) -(eval-when-compile (require 'cl)) +(require 'mcharset) +(require 'pces) (require 'std11) (require 'eword-decode) (require 'utf7) +(require 'poem) +(require 'emu) -(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) - (list 'setq 'mc-flag flag)) - ((featurep 'xemacs) - flag) - ((and (boundp 'emacs-major-version) (>= emacs-major-version 20)) - (list 'set-buffer-multibyte flag)) - (t - flag))) +(eval-and-compile + (autoload 'md5 "md5")) (defvar elmo-work-buf-name " *elmo work*") (defvar elmo-temp-buf-name " *elmo temp*") @@ -82,173 +68,132 @@ (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) - folder)) - (type (symbol-name (car spec))) - (backend-str (concat "elmo-" type)) - (backend-sym (intern backend-str))) - (unless (featurep backend-sym) - (require backend-sym)) - (apply (intern (format "%s-%s" backend-str func-name)) - spec - args))) - (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) + (set-buffer-multibyte default-enable-multibyte-characters) (erase-buffer) (,@ body)))) -(defmacro elmo-match-substring (pos string from) - "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 (, string) (match-beginning (, pos)) (match-end (, pos))))) - -(defmacro elmo-match-buffer (pos) - "Substring POSth matched from the current buffer." - (` (buffer-substring-no-properties - (match-beginning (, pos)) (match-end (, pos))))) +(put 'elmo-set-work-buf 'lisp-indent-function 0) +(def-edebug-spec elmo-set-work-buf t) (defmacro elmo-bind-directory (dir &rest body) "Set current directory DIR and execute BODY." (` (let ((default-directory (file-name-as-directory (, dir)))) (,@ body)))) -(defmacro elmo-folder-get-type (folder) - "Get type of FOLDER." - (` (and (stringp (, folder)) - (cdr (assoc (string-to-char (, folder)) elmo-spec-alist))))) +(put 'elmo-bind-directory 'lisp-indent-function 1) +(def-edebug-spec elmo-bind-directory + (form &rest form)) + +(defconst elmo-multibyte-buffer-name " *elmo-multibyte-buffer*") + +(defmacro elmo-with-enable-multibyte (&rest body) + "Evaluate BODY with `default-enable-multibyte-character'." + `(with-current-buffer (get-buffer-create elmo-multibyte-buffer-name) + ,@body)) + +(put 'elmo-with-enable-multibyte 'lisp-indent-function 0) +(def-edebug-spec elmo-with-enable-multibyte t) + +(eval-when-compile + (unless (fboundp 'coding-system-base) + (defalias 'coding-system-base 'ignore)) + (unless (fboundp 'coding-system-name) + (defalias 'coding-system-name 'ignore)) + (unless (fboundp 'find-file-coding-system-for-read-from-filename) + (defalias 'find-file-coding-system-for-read-from-filename 'ignore)) + (unless (fboundp 'find-operation-coding-system) + (defalias 'find-operation-coding-system 'ignore))) + +(defun elmo-set-auto-coding (&optional filename) + "Find coding system used to decode the contents of the current buffer. +This function looks for the coding system magic cookie or examines the +coding system specified by `file-coding-system-alist' being associated +with FILENAME which defaults to `buffer-file-name'." + (cond + ((boundp 'set-auto-coding-function) ;; Emacs + (if filename + (or (funcall (symbol-value 'set-auto-coding-function) + filename (- (point-max) (point-min))) + (car (find-operation-coding-system 'insert-file-contents + filename))) + (let (auto-coding-alist) + (condition-case nil + (funcall (symbol-value 'set-auto-coding-function) + nil (- (point-max) (point-min))) + (error nil))))) + ((featurep 'file-coding) ;; XEmacs + (let ((case-fold-search t) + (end (point-at-eol)) + codesys start) + (or + (and (re-search-forward "-\\*-+[\t ]*" end t) + (progn + (setq start (match-end 0)) + (re-search-forward "[\t ]*-+\\*-" end t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)") + (re-search-forward + "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)" + end t))) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:" + nil t) + (progn + (setq start (match-end 0)) + (re-search-forward "^[\t ]*;+[\t ]*End:" nil t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (re-search-forward + "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)" + end t)) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (progn + (goto-char (point-min)) + (setq case-fold-search nil) + (re-search-forward "^;;;coding system: " + ;;(+ (point-min) 3000) t)) + nil t)) + (looking-at "[^\t\n\r ]+") + (find-coding-system + (setq codesys (intern (match-string 0)))) + codesys) + (and filename + (setq codesys + (find-file-coding-system-for-read-from-filename + filename)) + (coding-system-name (coding-system-base codesys)))))))) (defun elmo-object-load (filename &optional mime-charset no-err) "Load OBJECT from the file specified by FILENAME. File content is decoded with MIME-CHARSET." - (if (not (file-readable-p filename)) - nil - (elmo-set-work-buf - (as-binary-input-file - (insert-file-contents filename)) - (when 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)) - (error (unless no-err - (message "Warning: Loading object from %s failed." - filename) - (elmo-object-save filename nil)) - nil))))) + (if (not (file-readable-p filename)) + nil + (with-temp-buffer + (insert-file-contents-as-binary filename) + (let ((coding-system (or (elmo-set-auto-coding) + (mime-charset-to-coding-system + mime-charset)))) + (when coding-system + (decode-coding-region (point-min) (point-max) coding-system))) + (goto-char (point-min)) + (condition-case nil + (read (current-buffer)) + (error (unless no-err + (message "Warning: Loading object from %s failed." + filename) + (elmo-object-save filename nil mime-charset)) + nil))))) (defsubst elmo-save-buffer (filename &optional mime-charset) "Save current buffer to the file specified by FILENAME. @@ -262,373 +207,200 @@ File content is encoded with MIME-CHARSET." (if (file-writable-p filename) (progn (when mime-charset - ;;(elmo-set-buffer-multibyte default-enable-multibyte-characters) +;;; (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))) - (message (format "%s is not writable." filename))))) + (message "%s is not writable." filename)))) (defun elmo-object-save (filename object &optional mime-charset) "Save OBJECT to the file specified by FILENAME. 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)) - (elmo-save-buffer filename mime-charset))) - -(defsubst elmo-imap4-decode-folder-string (string) - (if elmo-imap4-use-modified-utf7 - (utf7-decode-string string 'imap) - string)) - -(defsubst elmo-imap4-encode-folder-string (string) - (if elmo-imap4-use-modified-utf7 - (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-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) - spec mailbox user auth) - (when (string-match "\\(.*\\)@\\(.*\\)" default-server) - ;; 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)) - (setq folder (car spec)) - (when (string-match - "^\\(%\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?" - folder) - (progn - (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) - elmo-default-imap4-authenticate-type)) - (append (list 'imap4 - (elmo-imap4-encode-folder-string mailbox) - user auth) - (cdr spec)))))) - -(defsubst elmo-imap4-spec-mailbox (spec) - (nth 1 spec)) - -(defsubst elmo-imap4-spec-username (spec) - (nth 2 spec)) - -(defsubst elmo-imap4-spec-auth (spec) - (nth 3 spec)) - -(defsubst elmo-imap4-spec-hostname (spec) - (nth 4 spec)) - -(defsubst elmo-imap4-spec-port (spec) - (nth 5 spec)) - -(defsubst elmo-imap4-spec-ssl (spec) - (nth 6 spec)) - -(defsubst elmo-imap4-spec-folder (spec) ;; obsolete - (nth 1 spec)) - -(defsubst elmo-imap4-connection-get-process (conn) - (nth 1 conn)) - -(defsubst elmo-imap4-connection-get-buffer (conn) - (nth 0 conn)) - -(defsubst elmo-imap4-connection-get-cwf (conn) - (nth 2 conn)) - -(defun elmo-nntp-get-spec (folder) - (let (spec group user) - (setq spec (elmo-network-get-spec folder - elmo-default-nntp-server - elmo-default-nntp-port - elmo-default-nntp-ssl)) - (setq folder (car spec)) - (when (string-match - "^\\(-\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?" - folder) - (setq group - (if (match-beginning 2) - (elmo-match-string 2 folder))) - (setq user - (if (match-beginning 3) - (elmo-match-substring 3 folder 1) - elmo-default-nntp-user)) - (append (list 'nntp group user) - (cdr spec))))) - -(defsubst elmo-nntp-spec-group (spec) - (nth 1 spec)) - -(defsubst elmo-nntp-spec-username (spec) - (nth 2 spec)) - -;; future use? -;; (defsubst elmo-nntp-spec-auth (spec)) - -(defsubst elmo-nntp-spec-hostname (spec) - (nth 3 spec)) - -(defsubst elmo-nntp-spec-port (spec) - (nth 4 spec)) - -(defsubst elmo-nntp-spec-ssl (spec) - (nth 5 spec)) - -(defun elmo-localdir-get-spec (folder) - (let (fld-name path) - (when (string-match - "^\\(\\+\\)\\(.*\\)$" - folder) - (if (eq (length (setq fld-name - (elmo-match-string 2 folder))) 0) - (setq fld-name "") - ) - (if (file-name-absolute-p fld-name) - (setq path (expand-file-name fld-name)) - (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)))) - -(defun elmo-maildir-get-spec (folder) - (let (fld-name path) - (when (string-match - "^\\(\\.\\)\\(.*\\)$" - folder) - (if (eq (length (setq fld-name - (elmo-match-string 2 folder))) 0) - (setq fld-name "")) - (if (file-name-absolute-p fld-name) - (setq path (expand-file-name fld-name)) - (setq path fld-name)) - (list 'maildir path)))) - -(defun elmo-folder-maildir-p (folder) - (catch 'found - (let ((li elmo-maildir-list)) - (while li - (if (string-match (car li) folder) - (throw 'found t)) - (setq li (cdr li)))))) - -(defun elmo-localnews-get-spec (folder) - (let (fld-name) - (when (string-match - "^\\(=\\)\\(.*\\)$" - folder) - (if (eq (length (setq fld-name - (elmo-match-string 2 folder))) 0) - (setq fld-name "") - ) - (list 'localnews - (elmo-replace-in-string fld-name "\\." "/"))))) - -(defun elmo-cache-get-spec (folder) - (let (fld-name) - (when (string-match - "^\\(!\\)\\(.*\\)$" - folder) - (if (eq (length (setq fld-name - (elmo-match-string 2 folder))) 0) - (setq fld-name "") - ) - (list 'cache - (elmo-replace-in-string fld-name "\\." "/"))))) - -;; Archive interface by OKUNISHI Fujikazu -(defun elmo-archive-get-spec (folder) - (require 'elmo-archive) - (let (fld-name type prefix) - (when (string-match - "^\\(\\$\\)\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$" - folder) - ;; Drive letter is OK! - (if (eq (length (setq fld-name - (elmo-match-string 2 folder))) 0) - (setq fld-name "") - ) - (if (eq (length (setq type - (elmo-match-string 3 folder))) 0) - (setq type (symbol-name elmo-archive-default-type))) - (if (eq (length (setq prefix - (elmo-match-string 4 folder))) 0) - (setq prefix "")) - (list 'archive fld-name (intern-soft type) prefix)))) - -(defun elmo-pop3-get-spec (folder) - (let (spec user auth) - (setq spec (elmo-network-get-spec folder - elmo-default-pop3-server - elmo-default-pop3-port - elmo-default-pop3-ssl)) - (setq folder (car spec)) - (when (string-match - "^\\(&\\)\\([^:/!]*\\)\\(/[^/:@!]+\\)?" - folder) - (setq user (if (match-beginning 2) - (elmo-match-string 2 folder))) - (if (eq (length user) 0) - (setq user elmo-default-pop3-user)) - (setq auth (if (match-beginning 3) - (elmo-match-substring 3 folder 1) - elmo-default-pop3-authenticate-type)) - (append (list 'pop3 user auth) - (cdr spec))))) - -(defsubst elmo-pop3-spec-username (spec) - (nth 1 spec)) - -(defsubst elmo-pop3-spec-auth (spec) - (nth 2 spec)) - -(defsubst elmo-pop3-spec-hostname (spec) - (nth 3 spec)) - -(defsubst elmo-pop3-spec-port (spec) - (nth 4 spec)) - -(defsubst elmo-pop3-spec-ssl (spec) - (nth 5 spec)) - -(defun elmo-internal-get-spec (folder) - (if (string-match "\\('\\)\\([^/]*\\)/?\\(.*\\)$" folder) - (let* ((item (downcase (elmo-match-string 2 folder))) - (sym (and (> (length item) 0) (intern item)))) - (cond ((or (null sym) - (eq sym 'mark)) - (list 'internal sym (elmo-match-string 3 folder))) - ((eq sym 'cache) - (list 'cache (elmo-match-string 3 folder))) - (t (error "Invalid internal folder spec")))))) - -(defun elmo-multi-get-spec (folder) - (save-match-data - (when (string-match - "^\\(\\*\\)\\(.*\\)$" - folder) - (append (list 'multi) - (split-string - (elmo-match-string 2 folder) - ","))))) - -(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))))) - -(defun elmo-pipe-get-spec (folder) - (when (string-match "^\\(|\\)\\([^|]*\\)|\\(.*\\)$" folder) - (list 'pipe - (elmo-match-string 2 folder) - (elmo-match-string 3 folder)))) - -(defun elmo-folder-get-spec (folder) - "return spec of folder" - (let ((type (elmo-folder-get-type folder))) - (if type - (funcall (intern (concat "elmo-" (symbol-name type) "-get-spec")) - folder) - (error "%s is not supported folder type" folder)))) + (with-temp-buffer + (let (print-length print-level) + (prin1 object (current-buffer))) + (when mime-charset + (let ((coding (mime-charset-to-coding-system + (or (detect-mime-charset-region (point-min) (point-max)) + mime-charset)))) + (goto-char (point-min)) + (insert ";;; -*- mode: emacs-lisp; coding: " + (symbol-name coding) " -*-\n") + (encode-coding-region (point-min) (point-max) coding))) + (elmo-save-buffer filename))) + +;;; Search Condition + +(defconst elmo-condition-atom-regexp "[^/ \")|&]*") + +(defsubst elmo-condition-parse-error () + (error "Syntax error in '%s'" (buffer-string))) (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)) + "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" / "flag" / field-name + ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *") + (goto-char (match-end 0)) + (let ((search-key (vector + (if (match-beginning 1) 'unmatch 'match) + (downcase (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 "-" number "-" number ; ex. 2000-05-10 +;; 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 "\"") + (read (current-buffer))) + ((or (looking-at elmo-condition-atom-regexp) + (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]+-[0-9]+-[0-9]+") + (looking-at "[0-9]+")) + (prog1 (elmo-match-buffer 0) + (goto-char (match-end 0)))) + (t (error "Syntax error '%s'" (buffer-string))))) + +(defmacro elmo-filter-condition-p (filter) + `(or (vectorp ,filter) (consp ,filter))) -(defun elmo-multi-get-real-folder-number (folder number) - (let* ((spec (elmo-folder-get-spec folder)) - (flds (cdr spec)) - (num number) - (fld (nth (- (/ num elmo-multi-divide-number) 1) flds))) - (cons fld (% num elmo-multi-divide-number)))) +(defmacro elmo-filter-type (filter) + `(aref ,filter 0)) + +(defmacro elmo-filter-key (filter) + `(aref ,filter 1)) +(defmacro elmo-filter-value (filter) + `(aref ,filter 2)) + +(defun elmo-condition-match (condition match-primitive args) + (cond + ((vectorp condition) + (if (eq (elmo-filter-type condition) 'unmatch) + (not (apply match-primitive condition args)) + (apply match-primitive condition args))) + ((eq (car condition) 'and) + (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args))) + (cond + ((elmo-filter-condition-p lhs) + (let ((rhs (elmo-condition-match (nth 2 condition) + match-primitive args))) + (cond ((elmo-filter-condition-p rhs) + (list 'and lhs rhs)) + (rhs + lhs)))) + (lhs + (elmo-condition-match (nth 2 condition) match-primitive args))))) + ((eq (car condition) 'or) + (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args))) + (cond + ((elmo-filter-condition-p lhs) + (let ((rhs (elmo-condition-match (nth 2 condition) + match-primitive args))) + (cond ((elmo-filter-condition-p rhs) + (list 'or lhs rhs)) + (rhs + t) + (t + lhs)))) + (lhs + t) + (t + (elmo-condition-match (nth 2 condition) match-primitive args))))))) + +(defun elmo-condition-optimize (condition) + (cond + ((vectorp condition) + (let ((key (elmo-filter-key condition))) + (cond ((cdr (assoc key '(("first" . 0) + ("last" . 0) + ("flag" . 1) + ("body" . 5))))) + ((member key '("since" "before" "from" "subject" "to" "cc")) + 2) + ((member key elmo-msgdb-extra-fields) + 3) + (t + 4)))) + (t + (let ((weight-l (elmo-condition-optimize (nth 1 condition))) + (weight-r (elmo-condition-optimize (nth 2 condition)))) + (if (> weight-l weight-r) + (let ((lhs (nth 1 condition))) + (setcar (nthcdr 1 condition) (nth 2 condition)) + (setcar (nthcdr 2 condition) lhs) + weight-l) + weight-r))))) + +;;; (defsubst elmo-buffer-replace (regexp &optional newtext) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -639,13 +411,20 @@ File content is encoded with MIME-CHARSET." (elmo-set-work-buf (let ((coding-system-for-read 'no-conversion) (coding-system-for-write 'no-conversion)) - (if unibyte (elmo-set-buffer-multibyte nil)) + (if unibyte (set-buffer-multibyte nil)) (insert string) (goto-char (point-min)) (while (search-forward (char-to-string char) nil t) (replace-match "")) (buffer-string))))) +(defsubst elmo-delete-cr-buffer () + "Delete CR from buffer." + (save-excursion + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) )) + (defsubst elmo-delete-cr-get-content-type () (save-excursion (goto-char (point-min)) @@ -664,14 +443,47 @@ File content is encoded with MIME-CHARSET." (replace-match "\n")) (buffer-string)))) -(defun elmo-uniq-list (lst) +(defun elmo-last (list) + (and list (nth (1- (length list)) list))) + +(defun elmo-set-list (vars vals) + (while vars + (when (car vars) + (set (car vars) (car vals))) + (setq vars (cdr vars) + vals (cdr vals)))) + +(defun elmo-uniq-list (lst &optional delete-function) "Distractively uniqfy elements of LST." + (setq delete-function (or delete-function #'delete)) (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) + (funcall delete-function + (car tmp) + (cdr tmp))))))) lst) -(defun elmo-string-partial-p (string) - (and (stringp string) (string-match "message/partial" string))) +(defun elmo-uniq-sorted-list (list &optional equal-function) + "Distractively uniqfy elements of sorted LIST." + (setq equal-function (or equal-function #'equal)) + (let ((list list)) + (while list + (while (funcall equal-function (car list) (cadr list)) + (setcdr list (cddr list))) + (setq list (cdr list)))) + list) + +(defun elmo-list-insert (list element after) + (let* ((match (memq after list)) + (rest (and match (cdr (memq after list))))) + (if match + (progn + (setcdr match (list element)) + (nconc list rest)) + (nconc list (list element))))) (defun elmo-get-file-string (filename &optional remove-final-newline) (elmo-set-work-buf @@ -707,92 +519,100 @@ File content is encoded with MIME-CHARSET." (defun elmo-concat-path (path filename) (if (not (string= path "")) - (if (string= elmo-path-sep (substring path (- (length path) 1))) - (concat path filename) - (concat path elmo-path-sep filename)) + (elmo-replace-in-string + (if (string= elmo-path-sep (substring path (- (length path) 1))) + (concat path filename) + (concat path elmo-path-sep filename)) + (concat (regexp-quote elmo-path-sep)(regexp-quote elmo-path-sep)) + elmo-path-sep) filename)) (defvar elmo-passwd-alist nil) (defun elmo-passwd-alist-load () - (save-excursion + (with-temp-buffer (let ((filename (expand-file-name elmo-passwd-alist-file-name - 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 - ret-val) + elmo-msgdb-directory)) + insert-file-contents-pre-hook ; To avoid autoconv-xmas... + insert-file-contents-post-hook + ret-val) (if (not (file-readable-p filename)) - () - (set-buffer tmp-buffer) - (insert-file-contents filename) - (setq ret-val - (condition-case nil - (read (current-buffer)) - (error nil nil)))) - (kill-buffer tmp-buffer) - ret-val))) + () + (insert-file-contents filename) + (condition-case nil + (read (current-buffer)) + (error nil nil)))))) + +(defun elmo-passwd-alist-clear () + "Clear password cache." + (interactive) + (dolist (pair elmo-passwd-alist) + (when (stringp (cdr-safe pair)) + (fillarray (cdr pair) 0))) + (setq elmo-passwd-alist nil)) (defun elmo-passwd-alist-save () "Save password into file." (interactive) - (save-excursion + (with-temp-buffer (let ((filename (expand-file-name elmo-passwd-alist-file-name - elmo-msgdb-dir)) - (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))) - (set-buffer tmp-buffer) - (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)) + elmo-msgdb-directory)) + print-length print-level) + (prin1 elmo-passwd-alist (current-buffer)) + (princ "\n" (current-buffer)) +;;; (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) - 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) + (progn + (write-region (point-min) (point-max) + filename nil 'no-msg) + (set-file-modes filename 384)) + (message "%s is not writable." filename))))) + +(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 pair (assoc key elmo-passwd-alist)) + (if pair + (elmo-base64-decode-string (cdr pair)) (setq pass (elmo-read-passwd (format "Password for %s: " - user-at-host) t)) + 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) + (while (setq pass-cons (assoc key elmo-passwd-alist)) + (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) - '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?) - (left . ?\C-h)))) - event key) - (while (not - (and - (key-press-event-p (setq event (next-command-event))) - (setq key (or (event-to-character event) - (cdr (assq (event-key event) table))))))) - key)) - ((fboundp 'read-char-exclusive) - '(read-char-exclusive)) - (t - '(read-char)))) + '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?) + (left . ?\C-h)))) + event key) + (while (not + (and + (key-press-event-p (setq event (next-command-event))) + (setq key (or (event-to-character event) + (cdr (assq (event-key event) table))))))) + key)) + ((fboundp 'read-char-exclusive) + '(read-char-exclusive)) + (t + '(read-char)))) (defun elmo-read-passwd (prompt &optional stars) "Read a single line of text from user without echoing, and return it." @@ -831,49 +651,6 @@ File content is encoded with MIME-CHARSET." (message "") ans))) -;; 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. -Optional LITERAL non-nil means do a literal replacement. -Otherwise treat \\ in NEWTEXT string as special: - \\& means substitute original matched text, - \\N means substitute match for \(...\) number N, - \\\\ means insert one \\." - (let ((rtn-str "") - (start 0) - (special) - match prev-start) - (while (setq match (string-match regexp str start)) - (setq prev-start start - 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 "")))))) - (concat rtn-str (substring str start)))) - (defun elmo-string-to-list (string) (elmo-set-work-buf (insert string) @@ -884,6 +661,31 @@ Otherwise treat \\ in NEWTEXT string as special: (goto-char (point-min)) (read (current-buffer)))) +(defun elmo-list-to-string (list) + (let ((tlist list) + str) + (if (listp tlist) + (progn + (setq str "(") + (while (car tlist) + (setq str + (concat str + (if (symbolp (car tlist)) + (symbol-name (car tlist)) + (car tlist)))) + (if (cdr tlist) + (setq str + (concat str " "))) + (setq tlist (cdr tlist))) + (setq str + (concat str ")"))) + (setq str + (if (symbolp tlist) + (symbol-name tlist) + tlist))) + str)) + + (defun elmo-plug-on-by-servers (alist &optional servers) (let ((server-list (or servers elmo-plug-on-servers))) (catch 'plugged @@ -902,23 +704,27 @@ Otherwise treat \\ in NEWTEXT string as special: (setq alist (cdr alist))) (elmo-plug-on-by-servers alist other-servers))) -(defun elmo-plugged-p (&optional server port alist label-exp) +(defun elmo-plugged-p (&optional server port stream-type alist label-exp) (let ((alist (or alist elmo-plugged-alist)) plugged-info) (cond ((and (not port) (not server)) (cond ((eq elmo-plugged-condition 'one) - (catch 'plugged - (while alist - (if (nth 2 (car alist)) - (throw 'plugged t)) - (setq alist (cdr alist))))) + (if alist + (catch 'plugged + (while alist + (if (nth 2 (car alist)) + (throw 'plugged t)) + (setq alist (cdr alist)))) + elmo-plugged)) ((eq elmo-plugged-condition 'all) - (catch 'plugged - (while alist - (if (not (nth 2 (car alist))) - (throw 'plugged nil)) - (setq alist (cdr alist))) - t)) + (if alist + (catch 'plugged + (while alist + (if (not (nth 2 (car alist))) + (throw 'plugged nil)) + (setq alist (cdr alist))) + t) + elmo-plugged)) ((functionp elmo-plugged-condition) (funcall elmo-plugged-condition alist)) (t ;; independent @@ -931,11 +737,12 @@ Otherwise treat \\ in NEWTEXT string as special: (throw 'plugged t))) (setq alist (cdr alist))))) (t - (setq plugged-info (assoc (cons server port) alist)) + (setq plugged-info (assoc (list server port stream-type) alist)) (if (not plugged-info) ;; add elmo-plugged-alist automatically (progn - (elmo-set-plugged elmo-plugged server port nil nil label-exp) + (elmo-set-plugged elmo-plugged server port stream-type + nil nil nil label-exp) elmo-plugged) (if (and elmo-auto-change-plugged (> elmo-auto-change-plugged 0) @@ -945,7 +752,7 @@ Otherwise treat \\ in NEWTEXT string as special: t (nth 2 plugged-info))))))) -(defun elmo-set-plugged (plugged &optional server port time +(defun elmo-set-plugged (plugged &optional server port stream-type time alist label-exp add) (let ((alist (or alist elmo-plugged-alist)) label plugged-info) @@ -963,7 +770,7 @@ Otherwise treat \\ in NEWTEXT string as special: (setq alist (cdr alist)))) (t ;; set plugged one port of server - (setq plugged-info (assoc (cons server port) alist)) + (setq plugged-info (assoc (list server port stream-type) alist)) (setq label (if label-exp (eval label-exp) (nth 1 plugged-info))) @@ -973,9 +780,11 @@ Otherwise treat \\ in NEWTEXT string as special: (setcdr plugged-info (list label plugged time))) (setq alist (setq elmo-plugged-alist - (nconc elmo-plugged-alist - (list - (list (cons server port) label plugged time)))))))) + (nconc + elmo-plugged-alist + (list + (list (list server port stream-type) + label plugged time)))))))) alist)) (defun elmo-delete-plugged (&optional server port alist) @@ -992,7 +801,7 @@ 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) @@ -1010,10 +819,11 @@ Otherwise treat \\ in NEWTEXT string as special: (setq result (+ result (or (elmo-disk-usage (car files)) 0))) (setq files (cdr files))) result) - (float (nth 7 file-attr)))))) + (float (nth 7 file-attr))) + 0))) (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 +834,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)) @@ -1032,18 +842,18 @@ Otherwise treat \\ in NEWTEXT string as special: (setq last-modified (+ (* (nth 0 last-modified) (float 65536)) (nth 1 last-modified))))) -(defun elmo-make-directory (path) - "create directory recursively." +(defun elmo-make-directory (path &optional mode) + "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 (or mode + (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700 (defun elmo-delete-directory (path &optional no-hierarchy) - "delete directory recursively." + "Delete directory recursively." + (if (stringp path) ; nil is not permitted. (let ((dirent (directory-files path)) relpath abspath hierarchy) (while dirent @@ -1057,49 +867,27 @@ Otherwise treat \\ in NEWTEXT string as special: (elmo-delete-directory abspath no-hierarchy)) (delete-file abspath)))) (unless hierarchy - (delete-directory path)))) + (delete-directory path))))) + +(defun elmo-delete-match-files (path regexp &optional remove-if-empty) + "Delete directory files specified by PATH. +If optional REMOVE-IF-EMPTY is non-nil, delete directory itself if +the directory becomes empty after deletion." + (when (stringp path) ; nil is not permitted. + (dolist (file (directory-files path t regexp)) + (delete-file file)) + (if remove-if-empty + (ignore-errors + (delete-directory path) ; should be removed if empty. + )))) (defun elmo-list-filter (l1 l2) - "L1 is filter." - (if (eq l1 t) - ;; t means filter all. - nil - (if l1 - (elmo-delete-if (lambda (x) (not (memq x l1))) l2) - ;; filter is nil - l2))) - -(defun elmo-folder-local-p (folder) - "Return whether FOLDER is a local folder or not." - (let ((type (elmo-folder-get-type folder))) - (memq type '(localdir localnews archive maildir internal cache)))) - -(defun elmo-folder-writable-p (folder) - (let ((type (elmo-folder-get-type folder))) - (memq type '(imap4 localdir archive)))) - -(defun elmo-multi-get-intlist-list (numlist &optional as-is) - (let ((numbers (sort numlist '<)) - (cur-number 0) - one-list int-list-list) - (while numbers - (setq cur-number (+ cur-number 1)) - (setq one-list nil) - (while (and numbers - (eq 0 - (/ (- (car numbers) - (* elmo-multi-divide-number cur-number)) - elmo-multi-divide-number))) - (setq one-list (nconc - one-list - (list - (if as-is - (car numbers) - (% (car numbers) - (* elmo-multi-divide-number cur-number)))))) - (setq numbers (cdr numbers))) - (setq int-list-list (nconc int-list-list (list one-list)))) - int-list-list)) + "Return a list from L2 in which each element is a member of L1." + (let (result) + (dolist (element l2) + (if (memq element l1) + (setq result (cons element result)))) + (nreverse result))) (defsubst elmo-list-delete-if-smaller (list number) (let ((ret-val (copy-sequence list))) @@ -1109,9 +897,34 @@ Otherwise treat \\ in NEWTEXT string as special: (setq list (cdr list))) ret-val)) -(defun elmo-list-diff (list1 list2 &optional mes) - (if mes - (message mes)) +(defun elmo-list-diff (list1 list2) + (let ((clist1 (sort (copy-sequence list1) #'<)) + (clist2 (sort (copy-sequence list2) #'<)) + list1-only list2-only) + (while (or clist1 clist2) + (cond + ((null clist1) + (while clist2 + (setq list2-only (cons (car clist2) list2-only)) + (setq clist2 (cdr clist2)))) + ((null clist2) + (while clist1 + (setq list1-only (cons (car clist1) list1-only)) + (setq clist1 (cdr clist1)))) + ((< (car clist1) (car clist2)) + (while (and clist1 (< (car clist1) (car clist2))) + (setq list1-only (cons (car clist1) list1-only)) + (setq clist1 (cdr clist1)))) + ((< (car clist2) (car clist1)) + (while (and clist2 (< (car clist2) (car clist1))) + (setq list2-only (cons (car clist2) list2-only)) + (setq clist2 (cdr clist2)))) + ((= (car clist1) (car clist2)) + (setq clist1 (cdr clist1) + clist2 (cdr clist2))))) + (list list1-only list2-only))) + +(defun elmo-list-diff-nonsortable (list1 list2) (let ((clist1 (copy-sequence list1)) (clist2 (copy-sequence list2))) (while list2 @@ -1120,12 +933,10 @@ Otherwise treat \\ in NEWTEXT string as special: (while list1 (setq clist2 (delq (car list1) clist2)) (setq list1 (cdr list1))) - (if mes - (message (concat mes "done."))) (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) @@ -1152,170 +963,54 @@ Otherwise treat \\ in NEWTEXT string as special: (setq l1 (cdr l1))) (cons diff1 (list l2))))) -(defun elmo-multi-list-bigger-diff (list1 list2 &optional mes) - (let ((list1-list (elmo-multi-get-intlist-list list1 t)) - (list2-list (elmo-multi-get-intlist-list list2 t)) - result - dels news) - (while (or list1-list 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))) - (setq list1-list (cdr list1-list)) - (setq list2-list (cdr list2-list))) - (cons dels (list news)))) - -(defvar elmo-imap4-name-space-regexp-list nil) -(defun elmo-imap4-identical-name-space-p (fld1 fld2) - ;; only on UW? - (if (or (eq (string-to-char fld1) ?#) - (eq (string-to-char fld2) ?#)) - (string= (car (split-string fld1 "/")) - (car (split-string fld2 "/"))) - t)) - -(defun elmo-folder-identical-system-p (folder1 folder2) - "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 - (t - (elmo-folder-direct-copy-p folder1 folder2)))) - -(defconst elmo-folder-direct-copy-alist - '((localdir . (localdir localnews archive)) - (maildir . (maildir localdir localnews archive)) - (localnews . (localdir localnews archive)) - (archive . (localdir localnews archive)) - (cache . (localdir localnews archive)))) - -(defun elmo-folder-direct-copy-p (src-folder dst-folder) - (let ((src-type (car (elmo-folder-get-spec src-folder))) - (dst-type (car (elmo-folder-get-spec dst-folder))) - dst-copy-type) - (and (setq dst-copy-type - (cdr (assq src-type elmo-folder-direct-copy-alist))) - (memq dst-type dst-copy-type)))) - -(defmacro elmo-filter-type (filter) - (` (aref (, filter) 0))) - -(defmacro elmo-filter-key (filter) - (` (aref (, filter) 1))) - -(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) - (elmo-set-work-buf - (as-binary-input-file - (insert-file-contents file)) - (elmo-set-buffer-multibyte default-enable-multibyte-characters) - (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))) - (defmacro elmo-get-hash-val (string hashtable) - (let ((sym (list 'intern-soft string hashtable))) - (list 'if (list 'boundp sym) - (list 'symbol-value sym)))) + (static-if (fboundp 'unintern) + `(symbol-value (intern-soft ,string ,hashtable)) + `(let ((sym (intern-soft ,string ,hashtable))) + (and (boundp sym) + (symbol-value sym))))) (defmacro elmo-set-hash-val (string value hashtable) - (list 'set (list 'intern string hashtable) value)) + `(set (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 a new hash table which have HASHSIZE size." + (make-vector + (if hashsize + (max + ;; Prime numbers as lengths tend to result in good + ;; hashing; lengths one less than a power of two are + ;; also good. + (min + (let ((i 1)) + (while (< (- i 1) hashsize) + (setq i (* 2 i))) + (- i 1)) + elmo-hash-maximum-size) + elmo-hash-minimum-size) + elmo-hash-minimum-size) + 0)) (defsubst elmo-mime-string (string) - "Normalize MIME encoded string." - (and string - (let (str) - (elmo-set-work-buf - (elmo-set-buffer-multibyte default-enable-multibyte-characters) - (setq str (eword-decode-string - (decode-mime-charset-string string elmo-mime-charset))) - (setq str (encode-mime-charset-string str elmo-mime-charset)) - (elmo-set-buffer-multibyte nil) - str)))) + "Normalize MIME encoded STRING." + (and string + (elmo-with-enable-multibyte + (encode-mime-charset-string + (or (ignore-errors + (eword-decode-and-unfold-unstructured-field-body string)) + string) + elmo-mime-charset)))) (defsubst elmo-collect-field (beg end downcase-field-name) (save-excursion @@ -1352,41 +1047,48 @@ Otherwise treat \\ in NEWTEXT string as special: (setq dest (cons (cons name body) dest)))) dest))) -(defun elmo-create-hash-size (min) - (let ((i 1)) - (while (< i min) - (setq i (* 2 i))) - i)) - -(defun elmo-safe-filename (folder) - (elmo-replace-in-string - (elmo-replace-in-string - (elmo-replace-in-string folder "/" " ") - ":" "__") - "|" "_or_")) - -(defvar elmo-msgid-replace-chars nil) - -(defsubst elmo-replace-msgid-as-filename (msgid) - "Replace message-id string as filename." +(defun elmo-safe-filename (filename) + (let* ((replace-alist '(("/" . " ") + (":" . "__") + ("|" . "_or_") + ("\"" . "_Q_"))) + (regexp (concat "[" + (regexp-quote (mapconcat 'car replace-alist "")) + "]")) + (rest filename) + converted) + (while (string-match regexp rest) + (setq converted (concat converted + (substring rest 0 (match-beginning 0)) + (cdr (assoc (substring rest + (match-beginning 0) + (match-end 0)) + replace-alist))) + rest (substring rest (match-end 0)))) + (concat converted rest))) + +(defvar elmo-filename-replace-chars nil) + +(defsubst elmo-replace-string-as-filename (msgid) + "Replace string as filename." (setq msgid (elmo-replace-in-string msgid " " " ")) - (if (null elmo-msgid-replace-chars) - (setq elmo-msgid-replace-chars + (if (null elmo-filename-replace-chars) + (setq elmo-filename-replace-chars (regexp-quote (mapconcat - 'car elmo-msgid-replace-string-alist "")))) - (while (string-match (concat "[" elmo-msgid-replace-chars "]") + 'car elmo-filename-replace-string-alist "")))) + (while (string-match (concat "[" elmo-filename-replace-chars "]") msgid) (setq msgid (concat (substring msgid 0 (match-beginning 0)) (cdr (assoc (substring msgid (match-beginning 0) (match-end 0)) - elmo-msgid-replace-string-alist)) + elmo-filename-replace-string-alist)) (substring msgid (match-end 0))))) msgid) -(defsubst elmo-recover-msgid-from-filename (filename) - "Recover Message-ID from filename." +(defsubst elmo-recover-string-from-filename (filename) + "Recover string from FILENAME." (let (tmp result) (while (string-match " " filename) (setq tmp (substring filename @@ -1395,7 +1097,7 @@ Otherwise treat \\ in NEWTEXT string as special: (if (string= tmp " ") (setq tmp " ") (setq tmp (car (rassoc tmp - elmo-msgid-replace-string-alist)))) + elmo-filename-replace-string-alist)))) (setq result (concat result (substring filename 0 (match-beginning 0)) @@ -1403,47 +1105,43 @@ Otherwise treat \\ in NEWTEXT string as special: (setq filename (substring filename (+ (match-end 0) 1)))) (concat result filename))) -(defsubst elmo-copy-file (src dst) +(defsubst elmo-copy-file (src dst &optional ok-if-already-exists) (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) + (elmo-add-name-to-file src dst ok-if-already-exists) + (error (copy-file src dst ok-if-already-exists 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)) - (setq result (nconc result (list (car lst))))) + (setq result (cons (car lst) result))) (setq lst (cdr lst))) - result)) - -(defun elmo-list-delete (list1 list2) - "Any element of list1 is deleted from list2." + (nreverse result))) + +(defun elmo-list-delete (list1 list2 &optional delete-function) + "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'. +If optional DELETE-FUNCTION is speficied, it is used as delete procedure." + (setq delete-function (or delete-function 'delete)) (while list1 - (setq list2 (delete (car list1) list2)) + (setq list2 (funcall delete-function (car list1) list2)) (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,7 +1159,7 @@ 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) @@ -1469,22 +1167,101 @@ Otherwise treat \\ in NEWTEXT string as special: (setq err-mes (concat err-mes (format (if (stringp (car errobj)) "%s" - (if (boundp 'nemacs-version) - "%s" - "%S")) (car errobj)))) + "%S") + (car errobj)))) (setq errobj (cdr errobj)) (if errobj (setq err-mes (concat err-mes (if first ": " ", ")))) (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 'progress-feedback-with-label) + (defalias 'elmo-display-progress 'progress-feedback-with-label)) + ((fboundp 'lprogress-display) + (defalias 'elmo-display-progress 'lprogress-display)) + (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))))))) + +(defvar elmo-progress-counter-alist nil) + +(defmacro elmo-progress-counter-value (counter) + (` (aref (cdr (, counter)) 0))) + +(defmacro elmo-progress-counter-all-value (counter) + (` (aref (cdr (, counter)) 1))) + +(defmacro elmo-progress-counter-format (counter) + (` (aref (cdr (, counter)) 2))) + +(defmacro elmo-progress-counter-set-value (counter value) + (` (aset (cdr (, counter)) 0 (, value)))) + +(defun elmo-progress-set (label all-value &optional format) + (unless (assq label elmo-progress-counter-alist) + (setq elmo-progress-counter-alist + (cons (cons label (vector 0 all-value (or format ""))) + elmo-progress-counter-alist)))) + +(defun elmo-progress-clear (label) + (let ((counter (assq label elmo-progress-counter-alist))) + (when counter + (elmo-display-progress label + (elmo-progress-counter-format counter) + 100) + (setq elmo-progress-counter-alist + (delq counter elmo-progress-counter-alist))))) + +(defun elmo-progress-notify (label &optional value op &rest args) + (let ((counter (assq label elmo-progress-counter-alist))) + (when counter + (let* ((value (or value 1)) + (cur-value (elmo-progress-counter-value counter)) + (all-value (elmo-progress-counter-all-value counter)) + (new-value (if (eq op 'set) value (+ cur-value value))) + (cur-rate (/ (* cur-value 100) all-value)) + (new-rate (/ (* new-value 100) all-value))) + (elmo-progress-counter-set-value counter new-value) + (unless (= cur-rate new-rate) + (apply 'elmo-display-progress + label + (elmo-progress-counter-format counter) + new-rate + args)) + (when (>= new-rate 100) + (elmo-progress-clear label)))))) + +(put 'elmo-with-progress-display 'lisp-indent-function '2) +(def-edebug-spec elmo-with-progress-display + (form (symbolp form &optional form) &rest form)) + +(defmacro elmo-with-progress-display (condition spec &rest body) + "Evaluate BODY with progress gauge if CONDITION is non-nil. +SPEC is a list as followed (LABEL MAX-VALUE [FORMAT])." + (let ((label (car spec)) + (max-value (cadr spec)) + (fmt (caddr spec))) + `(unwind-protect + (progn + (when ,condition + (elmo-progress-set (quote ,label) ,max-value ,fmt)) + ,@body) + (elmo-progress-clear (quote ,label))))) (defun elmo-time-expire (before-time diff-time) (let* ((current (current-time)) @@ -1497,43 +1274,45 @@ 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)) +(defun elmo-unfold-field-body (name) + (let ((value (elmo-field-body name))) + (and value + (std11-unfold-string value)))) + +(defun elmo-decoded-field-body (field-name &optional mode) + (let ((field-body (elmo-field-body field-name))) + (and field-body + (or (ignore-errors + (elmo-with-enable-multibyte + (mime-decode-field-body field-body field-name mode))) + field-body)))) + +(defun elmo-address-quote-specials (word) + "Make quoted string of WORD if needed." + (let ((lal (std11-lexical-analyze word))) + (if (or (assq 'specials lal) + (assq 'domain-literal lal)) + (prin1-to-string word) + word))) + (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) + (and obj (set-text-properties 0 (length obj) nil obj)) obj))) +(defun elmo-flatten (list-of-list) + "Flatten LIST-OF-LIST." + (if list-of-list + (apply #'nconc + (mapcar (lambda (element) + (if (consp element) element (list element))) + 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,13 +1321,34 @@ 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." (catch 'found - (while slist - (if (and (stringp (car slist)) - (string= string (car slist))) - (throw 'found t)) - (setq slist (cdr slist))))) + (dolist (element slist) + (cond ((null element)) + ((stringp element) + (when (string= string element) + (throw 'found t))) + ((symbolp element) + (when (string= string (symbol-value element)) + (throw 'found t))))))) + +(static-cond ((fboundp 'member-ignore-case) + (defalias 'elmo-string-member-ignore-case 'member-ignore-case)) + ((fboundp 'compare-strings) + (defun elmo-string-member-ignore-case (elt list) + "Like `member', but ignores differences in case and text representation. +ELT must be a string. Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t)))) + (setq list (cdr list))) + list)) + (t + (defun elmo-string-member-ignore-case (elt list) + "Like `member', but ignores differences in case and text representation. +ELT must be a string. Upper-case and lower-case letters are treated as equal." + (let ((str (downcase elt))) + (while (and list (not (string= str (downcase (car list))))) + (setq list (cdr list))) + list)))) (defun elmo-string-match-member (str list &optional case-ignore) (let ((case-fold-search case-ignore)) @@ -1558,6 +1358,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)) @@ -1600,6 +1408,16 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (throw 'loop a)) (setq alist (cdr alist)))))) +(defun elmo-string-assoc-all (key alist) + (let (matches) + (while alist + (if (string= key (car (car alist))) + (setq matches + (cons (car alist) + matches))) + (setq alist (cdr alist))) + matches)) + (defun elmo-string-rassoc (key alist) (let (a) (catch 'loop @@ -1611,6 +1429,935 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (throw 'loop a)) (setq alist (cdr alist)))))) -(provide 'elmo-util) +(defun elmo-string-rassoc-all (key alist) + (let (matches) + (while alist + (if (string= key (cdr (car alist))) + (setq matches + (cons (car alist) + matches))) + (setq alist (cdr alist))) + matches)) + +(defun elmo-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))) + +;;; Folder parser utils. +(defconst elmo-quoted-specials-list '(?\\ ?\")) + +(defun elmo-quoted-token (string) + (concat "\"" + (std11-wrap-as-quoted-pairs string elmo-quoted-specials-list) + "\"")) + +(defun elmo-token-valid-p (token requirement) + (cond ((null requirement)) + ((stringp requirement) + (string-match requirement token)) + ((functionp requirement) + (funcall requirement token)))) + +(defun elmo-parse-token (string &optional seps requirement) + "Parse atom from STRING using SEPS as a string of separator char list." + (let ((len (length string)) + (seps (and seps (string-to-char-list seps))) + (i 0) + (sep nil) + content c in) + (if (eq len 0) + (cons "" "") + (while (and (< i len) (or in (null sep))) + (setq c (aref string i)) + (cond + ((and in (eq c ?\\)) + (setq i (1+ i) + content (cons (aref string i) content) + i (1+ i))) + ((eq c ?\") + (setq in (not in) + i (1+ i))) + (in (setq content (cons c content) + i (1+ i))) + ((memq c seps) + (setq sep c)) + (t (setq content (cons c content) + i (1+ i))))) + (if in (error "Parse error in quoted")) + (let ((atom (if (null content) + "" + (char-list-to-string (nreverse content))))) + (if (elmo-token-valid-p atom requirement) + (cons atom (substring string i)) + (cons "" string)))))) + +(defun elmo-parse-prefixed-element (prefix string &optional seps requirement) + (let (parsed) + (if (and (not (eq (length string) 0)) + (eq (aref string 0) prefix) + (setq parsed (elmo-parse-token (substring string 1) seps)) + (elmo-token-valid-p (car parsed) requirement)) + parsed + (cons "" string)))) + +(defun elmo-collect-separators (spec) + (when (listp spec) + (let ((result (elmo-collect-separators-internal spec))) + (and result + (char-list-to-string (elmo-uniq-list result #'delq)))))) + +(defun elmo-collect-separators-internal (specs &optional separators) + (while specs + (let ((spec (car specs))) + (cond + ((listp spec) + (setq separators (elmo-collect-separators-internal spec separators) + specs (cdr specs))) + ((characterp spec) + (setq separators (cons spec separators) + specs nil)) + (t + (setq specs nil))))) + separators) + +(defun elmo-collect-trail-separators (element specs) + (cond + ((symbolp specs) + (eq specs element)) + ((vectorp specs) + (eq (aref specs 0) element)) + ((listp specs) + (let (spec result) + (while (setq spec (car specs)) + (if (setq result (elmo-collect-trail-separators element spec)) + (setq result (concat (if (stringp result) result) + (elmo-collect-separators (cdr specs))) + specs nil) + (setq specs (cdr specs)))) + result)))) + +(defun elmo-parse-separated-tokens (string spec) + (let ((result (elmo-parse-separated-tokens-internal string spec))) + (if (eq (car result) t) + (cons nil (cdr result)) + result))) + +(defun elmo-parse-separated-tokens-internal (string spec &optional separators) + (cond + ((symbolp spec) + (let ((parse (elmo-parse-token string separators))) + (cons (list (cons spec (car parse))) (cdr parse)))) + ((vectorp spec) + (let ((parse (elmo-parse-token string separators))) + (if (elmo-token-valid-p (car parse) (aref spec 1)) + (cons (list (cons (aref spec 0) (car parse))) (cdr parse)) + (cons nil string)))) + ((characterp spec) + (if (and (> (length string) 0) + (eq (aref string 0) spec)) + (cons t (substring string 1)) + (cons nil string))) + ((listp spec) + (catch 'unmatch + (let ((rest string) + result tokens) + (while spec + (setq result (elmo-parse-separated-tokens-internal + rest + (car spec) + (concat (elmo-collect-separators (cdr spec)) + separators))) + (cond ((null (car result)) + (throw 'unmatch (cons t string))) + ((eq t (car result))) + (t + (setq tokens (nconc (car result) tokens)))) + (setq rest (cdr result) + spec (cdr spec))) + (cons (or tokens t) rest)))))) + +(defun elmo-quote-syntactical-element (value element syntax) + (let ((separators (elmo-collect-trail-separators element syntax))) + (if (and separators + (string-match (concat "[" separators "]") value)) + (elmo-quoted-token value) + value))) + +;;; 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)) + +(defun elmo-number-set-delete-list (number-set list) + "Delete LIST of numbers from the NUMBER-SET. +NUMBER-SET is altered." + (let ((deleted number-set)) + (dolist (number list) + (setq deleted (elmo-number-set-delete deleted number))) + deleted)) + +(defun elmo-number-set-delete (number-set number) + "Delete NUMBER from the NUMBER-SET. +NUMBER-SET is altered." + (let* ((curr number-set) + (top (cons 'dummy number-set)) + (prev top) + elem found) + (while (and curr (not found)) + (setq elem (car curr)) + (if (consp elem) + (cond + ((eq (car elem) number) + (if (eq (cdr elem) (1+ number)) + (setcar curr (cdr elem)) + (setcar elem (1+ number))) + (setq found t)) + ((eq (cdr elem) number) + (if (eq (car elem) (1- number)) + (setcar curr (car elem)) + (setcdr elem (1- number))) + (setq found t)) + ((and (> number (car elem)) + (< number (cdr elem))) + (setcdr + prev + (nconc + (list + ;; (beg . (1- number)) + (let ((new (cons (car elem) (1- number)))) + (if (eq (car new) (cdr new)) + (car new) + new)) + ;; ((1+ number) . end) + (let ((new (cons (1+ number) (cdr elem)))) + (if (eq (car new) (cdr new)) + (car new) + new))) + (cdr curr))))) + (when (eq elem number) + (setcdr prev (cdr curr)) + (setq found t))) + (setq prev curr + curr (cdr curr))) + (cdr top))) + +(defun elmo-make-number-list (beg end) + (let (number-list i) + (setq i end) + (while (>= i beg) + (setq number-list (cons i number-list)) + (setq i (1- i))) + number-list)) + +(defun elmo-number-set-to-number-list (number-set) + "Return a number list which corresponds to NUMBER-SET." + (let ((number-list (list 'dummy)) + elem) + (while number-set + (setq elem (car number-set)) + (cond + ((consp elem) + (nconc number-list (elmo-make-number-list (car elem) (cdr elem)))) + ((integerp elem) + (nconc number-list (list elem)))) + (setq number-set (cdr number-set))) + (cdr number-list))) + +(defcustom elmo-list-subdirectories-ignore-regexp "^\\(\\.\\.?\\|[0-9]+\\)$" + "*Regexp to filter subfolders." + :type 'regexp + :group 'elmo) + +(defun elmo-list-subdirectories-1 (basedir curdir one-level) + (let ((root (zerop (length curdir))) + (w32-get-true-file-link-count t) ; for Meadow + attr dirs dir) + (catch 'done + (dolist (file (directory-files (setq dir (expand-file-name curdir basedir)))) + (when (and (not (string-match + elmo-list-subdirectories-ignore-regexp + file)) + (car (setq attr (file-attributes + (expand-file-name file dir))))) + (when (eq one-level 'check) (throw 'done t)) + (let ((relpath + (concat curdir (and (not root) elmo-path-sep) file)) + subdirs) + (setq dirs (nconc dirs + (if (if elmo-have-link-count (< 2 (nth 1 attr)) + (setq subdirs + (elmo-list-subdirectories-1 + basedir + relpath + (if one-level 'check)))) + (if one-level + (list (list relpath)) + (cons relpath + (or subdirs + (elmo-list-subdirectories-1 + basedir + relpath + nil)))) + (list relpath))))))) + dirs))) + +(defun elmo-list-subdirectories (directory file one-level) + (let ((subdirs (elmo-list-subdirectories-1 directory file one-level))) + (if (zerop (length file)) + subdirs + (cons file subdirs)))) + +(defun elmo-mapcar-list-of-list (func list-of-list) + (mapcar + (lambda (x) + (cond ((listp x) (elmo-mapcar-list-of-list func x)) + (t (funcall func x)))) + list-of-list)) + +(defun elmo-map-recursive (function object) + (if (consp object) + (let* ((prev (list 'dummy)) + (result prev)) + (while (consp object) + (setq prev (setcdr prev (list (elmo-map-recursive function + (car object)))) + object (cdr object))) + (when object + (setcdr prev (funcall function object))) + (cdr result)) + (funcall function object))) + +(defun elmo-map-until-success (function sequence) + (let (result) + (while (and (null result) + sequence) + (setq result (funcall function (car sequence)) + sequence (cdr sequence))) + result)) + +(defun elmo-string-match-substring (regexp string &optional matchn) + (when (string-match regexp string) + (match-string (or matchn 1) string))) + +(defun elmo-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))) + +(defun elmo-find-list-match-value (specs getter) + (lexical-let ((getter getter)) + (elmo-map-until-success + (lambda (spec) + (cond + ((symbolp spec) + (funcall getter spec)) + ((consp spec) + (lexical-let ((value (funcall getter (car spec)))) + (when value + (elmo-map-until-success + (lambda (rule) + (cond + ((stringp rule) + (elmo-string-match-substring rule value)) + ((consp rule) + (elmo-string-match-substring (car rule) value (cdr rule))))) + (cdr spec))))))) + specs))) + +;;; File cache. +(defmacro elmo-make-file-cache (path status) + "PATH is the cache file name. +STATUS is one of 'section, 'entire or nil. + nil means no cache exists. +'section means partial section cache exists. +'entire means entire cache exists. +If the cache is partial file-cache, TYPE is 'partial." + (` (cons (, path) (, status)))) + +(defmacro elmo-file-cache-path (file-cache) + "Returns the file path of the FILE-CACHE." + (` (car (, file-cache)))) + +(defmacro elmo-file-cache-status (file-cache) + "Returns the status of the FILE-CACHE." + (` (cdr (, file-cache)))) + +(defsubst elmo-cache-to-msgid (filename) + (concat "<" (elmo-recover-string-from-filename filename) ">")) + +(defsubst elmo-cache-get-path-subr (msgid) + (let ((chars '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?A ?B ?C ?D ?E ?F)) + (clist (string-to-char-list msgid)) + (sum 0)) + (while clist + (setq sum (+ sum (car clist))) + (setq clist (cdr clist))) + (format "%c%c" + (nth (% (/ sum 16) 2) chars) + (nth (% sum 16) chars)))) + +;;; +(defun elmo-file-cache-get-path (msgid &optional section) + "Get cache path for MSGID. +If optional argument SECTION is specified, partial cache path is returned." + (if (setq msgid (elmo-msgid-to-cache msgid)) + (expand-file-name + (if section + (format "%s/%s/%s/%s" + elmo-cache-directory + (elmo-cache-get-path-subr msgid) + msgid + section) + (format "%s/%s/%s" + elmo-cache-directory + (elmo-cache-get-path-subr msgid) + msgid))))) + +(defmacro elmo-file-cache-expand-path (path section) + "Return file name for the file-cache corresponds to the section. +PATH is the file-cache path. +SECTION is the section string." + (` (expand-file-name (or (, section) "") (, path)))) + +(defun elmo-file-cache-delete (path) + "Delete a cache on PATH." + (when (file-exists-p path) + (if (file-directory-p path) + (progn + (dolist (file (directory-files path t "^[^\\.]")) + (delete-file file)) + (delete-directory path)) + (delete-file path)) + t)) + +(defun elmo-file-cache-exists-p (msgid) + "Returns 'section or 'entire if a cache which corresponds to MSGID exists." + (elmo-file-cache-status (elmo-file-cache-get msgid))) + +(defun elmo-file-cache-save (cache-path section) + "Save current buffer as cache on PATH. +Return t if cache is saved successfully." + (condition-case nil + (let ((path (if section (expand-file-name section cache-path) + cache-path)) + files dir) + (if (and (null section) + (file-directory-p path)) + (progn + (setq files (directory-files path t "^[^\\.]")) + (while files + (delete-file (car files)) + (setq files (cdr files))) + (delete-directory path)) + (if (and section + (not (file-directory-p cache-path))) + (delete-file cache-path))) + (when path + (setq dir (directory-file-name (file-name-directory path))) + (if (not (file-exists-p dir)) + (elmo-make-directory dir)) + (write-region-as-binary (point-min) (point-max) + path nil 'no-msg) + t)) + ;; ignore error + (error))) + +(defun elmo-file-cache-load (cache-path section) + "Load cache on PATH into the current buffer. +Return t if cache is loaded successfully." + (condition-case nil + (let (cache-file) + (when (and cache-path + (if (elmo-cache-path-section-p cache-path) + section + (null section)) + (setq cache-file (elmo-file-cache-expand-path + cache-path + section)) + (file-exists-p cache-file)) + (insert-file-contents-as-binary cache-file) + t)) + ;; igore error + (error))) + +(defun elmo-cache-path-section-p (path) + "Return non-nil when PATH is `section' cache path." + (file-directory-p path)) + +(defun elmo-file-cache-get (msgid &optional section) + "Returns the current file-cache object associated with MSGID. +MSGID is the message-id of the message. +If optional argument SECTION is specified, get partial file-cache object +associated with SECTION." + (if msgid + (let ((path (elmo-cache-get-path msgid))) + (if (and path (file-exists-p path)) + (if (elmo-cache-path-section-p path) + (if section + (if (file-exists-p (setq path (expand-file-name + section path))) + (cons path 'section)) + ;; section is not specified but sectional. + (cons path 'section)) + ;; not directory. + (unless section + (cons path 'entire))) + ;; no cache. + (cons path nil))))) + +;;; +;; Expire cache. + +(defun elmo-cache-expire () + (interactive) + (let* ((completion-ignore-case t) + (method (completing-read (format "Expire by (%s): " + elmo-cache-expire-default-method) + '(("size" . "size") + ("age" . "age")) + nil t))) + (when (string= method "") + (setq method elmo-cache-expire-default-method)) + (funcall (intern (concat "elmo-cache-expire-by-" method))))) + +(defun elmo-read-float-value-from-minibuffer (prompt &optional initial) + (let ((str (read-from-minibuffer prompt initial))) + (cond + ((string-match "[0-9]*\\.[0-9]+" str) + (string-to-number str)) + ((string-match "[0-9]+" str) + (string-to-number (concat str ".0"))) + (t (error "%s is not number" str))))) + +(defun elmo-cache-expire-by-size (&optional kbytes) + "Expire cache file by size. +If KBYTES is kilo bytes (This value must be float)." + (interactive) + (let ((size (or kbytes + (and (interactive-p) + (elmo-read-float-value-from-minibuffer + "Enter cache disk size (Kbytes): " + (number-to-string + (if (integerp elmo-cache-expire-default-size) + (float elmo-cache-expire-default-size) + elmo-cache-expire-default-size)))) + (if (integerp elmo-cache-expire-default-size) + (float elmo-cache-expire-default-size)))) + (count 0) + (Kbytes 1024) + total beginning) + (message "Checking disk usage...") + (setq total (/ (elmo-disk-usage + elmo-cache-directory) Kbytes)) + (setq beginning total) + (message "Checking disk usage...done") + (let ((cfl (elmo-cache-get-sorted-cache-file-list)) + (deleted 0) + oldest + cur-size cur-file) + (while (and (<= size total) + (setq oldest (elmo-cache-get-oldest-cache-file-entity cfl))) + (setq cur-file (expand-file-name (car (cdr oldest)) (car oldest))) + (setq cur-size (/ (elmo-disk-usage cur-file) Kbytes)) + (when (elmo-file-cache-delete cur-file) + (setq count (+ count 1)) + (message "%d cache(s) are expired." count)) + (setq deleted (+ deleted cur-size)) + (setq total (- total cur-size))) + (message "%d cache(s) are expired from disk (%d Kbytes/%d Kbytes)." + count deleted beginning)))) + +(defun elmo-cache-make-file-entity (filename path) + (cons filename (elmo-get-last-accessed-time filename path))) + +(defun elmo-cache-get-oldest-cache-file-entity (cache-file-list) + (let ((cfl cache-file-list) + flist firsts oldest-entity wonlist) + (while cfl + (setq flist (cdr (car cfl))) + (setq firsts (append firsts (list + (cons (car (car cfl)) + (car flist))))) + (setq cfl (cdr cfl))) +;;; (prin1 firsts) + (while firsts + (if (and (not oldest-entity) + (cdr (cdr (car firsts)))) + (setq oldest-entity (car firsts))) + (if (and (cdr (cdr (car firsts))) + (cdr (cdr oldest-entity)) + (> (cdr (cdr oldest-entity)) (cdr (cdr (car firsts))))) + (setq oldest-entity (car firsts))) + (setq firsts (cdr firsts))) + (setq wonlist (assoc (car oldest-entity) cache-file-list)) + (and wonlist + (setcdr wonlist (delete (car (cdr wonlist)) (cdr wonlist)))) + oldest-entity)) + +(defun elmo-cache-get-sorted-cache-file-list () + (let ((dirs (directory-files + elmo-cache-directory + t "^[^\\.]")) + (i 0) num + elist + ret-val) + (setq num (length dirs)) + (message "Collecting cache info...") + (while dirs + (setq elist (mapcar (lambda (x) + (elmo-cache-make-file-entity x (car dirs))) + (directory-files (car dirs) nil "^[^\\.]"))) + (setq ret-val (append ret-val + (list (cons + (car dirs) + (sort + elist + (lambda (x y) + (< (cdr x) + (cdr y)))))))) + (when (> num elmo-display-progress-threshold) + (setq i (+ i 1)) + (elmo-display-progress + 'elmo-cache-get-sorted-cache-file-list "Collecting cache info..." + (/ (* i 100) num))) + (setq dirs (cdr dirs))) + (message "Collecting cache info...done") + ret-val)) + +(defun elmo-cache-expire-by-age (&optional days) + (let ((age (or (and days (int-to-string days)) + (and (interactive-p) + (read-from-minibuffer + (format "Enter days (%s): " + elmo-cache-expire-default-age))) + (int-to-string elmo-cache-expire-default-age))) + (dirs (directory-files + elmo-cache-directory + t "^[^\\.]")) + (count 0) + curtime) + (if (string= age "") + (setq age elmo-cache-expire-default-age) + (setq age (string-to-int age))) + (setq curtime (current-time)) + (setq curtime (+ (* (nth 0 curtime) + (float 65536)) (nth 1 curtime))) + (while dirs + (let ((files (directory-files (car dirs) t "^[^\\.]")) + (limit-age (* age 86400))) + (while files + (when (> (- curtime (elmo-get-last-accessed-time (car files))) + limit-age) + (when (elmo-file-cache-delete (car files)) + (setq count (+ 1 count)) + (message "%d cache file(s) are expired." count))) + (setq files (cdr files)))) + (setq dirs (cdr dirs))))) + +;;; +;; msgid to path. +(defun elmo-msgid-to-cache (msgid) + (save-match-data + (when (and msgid + (string-match "<\\(.+\\)>$" msgid)) + (elmo-replace-string-as-filename (elmo-match-string 1 msgid))))) + +(defun elmo-cache-get-path (msgid &optional folder number) + "Get path for cache file associated with MSGID, FOLDER, and NUMBER." + (if (setq msgid (elmo-msgid-to-cache msgid)) + (expand-file-name + (expand-file-name + (if folder + (format "%s/%s/%s@%s" + (elmo-cache-get-path-subr msgid) + msgid + (or number "") + (elmo-safe-filename folder)) + (format "%s/%s" + (elmo-cache-get-path-subr msgid) + msgid)) + elmo-cache-directory)))) + +;;; +;; Warnings. + +(static-if (fboundp 'display-warning) + (defmacro elmo-warning (&rest args) + "Display a warning with `elmo' group." + `(display-warning 'elmo (format ,@args))) + (defconst elmo-warning-buffer-name "*elmo warning*") + (defun elmo-warning (&rest args) + "Display a warning. ARGS are passed to `format'." + (with-current-buffer (get-buffer-create elmo-warning-buffer-name) + (goto-char (point-max)) + (funcall 'insert (apply 'format (append args '("\n")))) + (ignore-errors (recenter 1)) + (display-buffer elmo-warning-buffer-name)))) + +(defvar elmo-obsolete-variable-alist nil) + +(defcustom elmo-obsolete-variable-show-warnings t + "Show warning window if obsolete variable is treated." + :type 'boolean + :group 'elmo) + +(defun elmo-define-obsolete-variable (obsolete var) + "Define obsolete variable. +OBSOLETE is a symbol for obsolete variable. +VAR is a symbol for new variable. +Definition is stored in `elmo-obsolete-variable-alist'." + (let ((pair (assq var elmo-obsolete-variable-alist))) + (if pair + (setcdr pair obsolete) + (setq elmo-obsolete-variable-alist + (cons (cons var obsolete) + elmo-obsolete-variable-alist))))) + +(defun elmo-resque-obsolete-variable (obsolete var) + "Resque obsolete variable OBSOLETE as VAR. +If `elmo-obsolete-variable-show-warnings' is non-nil, show warning message." + (when (boundp obsolete) + (static-if (and (fboundp 'defvaralias) + (subrp (symbol-function 'defvaralias))) + (defvaralias var obsolete) + (set var (symbol-value obsolete))) + (if elmo-obsolete-variable-show-warnings + (elmo-warning "%s is obsolete. Use %s instead." + (symbol-name obsolete) + (symbol-name var))))) + +(defun elmo-resque-obsolete-variables (&optional alist) + "Resque obsolete variables in ALIST. +ALIST is a list of cons cell of +\(OBSOLETE-VARIABLE-SYMBOL . NEW-VARIABLE-SYMBOL\). +If ALIST is nil, `elmo-obsolete-variable-alist' is used." + (dolist (pair elmo-obsolete-variable-alist) + (elmo-resque-obsolete-variable (cdr pair) + (car pair)))) + +(defsubst elmo-msgdb-get-last-message-id (string) + (if string + (save-match-data + (let (beg) + (elmo-set-work-buf + (insert string) + (goto-char (point-max)) + (when (search-backward "<" nil t) + (setq beg (point)) + (if (search-forward ">" nil t) + (elmo-replace-in-string + (buffer-substring beg (point)) "\n[ \t]*" "")))))))) + +(defun elmo-msgdb-get-message-id-from-buffer () + (let ((msgid (elmo-field-body "message-id"))) + (if msgid + (if (string-match "<\\(.+\\)>$" msgid) + msgid + (concat "<" msgid ">")) ; Invaild message-id. + ;; no message-id, so put dummy msgid. + (concat "<" + (if (elmo-unfold-field-body "date") + (timezone-make-date-sortable (elmo-unfold-field-body "date")) + (md5 (string-as-unibyte (buffer-string)))) + (nth 1 (eword-extract-address-components + (or (elmo-field-body "from") "nobody"))) ">")))) + +(defun elmo-msgdb-get-references-from-buffer () + (if elmo-msgdb-prefer-in-reply-to-for-parent + (or (elmo-msgdb-get-last-message-id (elmo-field-body "in-reply-to")) + (elmo-msgdb-get-last-message-id (elmo-field-body "references"))) + (or (elmo-msgdb-get-last-message-id (elmo-field-body "references")) + (elmo-msgdb-get-last-message-id (elmo-field-body "in-reply-to"))))) + +(defsubst elmo-msgdb-insert-file-header (file) + "Insert the header of the article." + (let ((beg 0) + insert-file-contents-pre-hook ; To avoid autoconv-xmas... + insert-file-contents-post-hook + format-alist) + (when (file-exists-p file) + ;; Read until header separator is found. + (while (and (eq elmo-msgdb-file-header-chop-length + (nth 1 + (insert-file-contents-as-binary + file nil beg + (incf beg elmo-msgdb-file-header-chop-length)))) + (prog1 (not (search-forward "\n\n" nil t)) + (goto-char (point-max)))))))) + +;; +;; overview handling +;; +(defun elmo-multiple-field-body (name &optional boundary) + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let ((case-fold-search t) + (field-body nil)) + (while (re-search-forward (concat "^" name ":[ \t]*") nil t) + (setq field-body + (nconc field-body + (list (buffer-substring-no-properties + (match-end 0) (std11-field-end)))))) + field-body)))) + +(defun elmo-parse-addresses (string) + (if (null string) + () + (elmo-set-work-buf + (let (list start s char) + (insert string) + (goto-char (point-min)) + (skip-chars-forward "\t\f\n\r ") + (setq start (point)) + (while (not (eobp)) + (skip-chars-forward "^\"\\,(") + (setq char (following-char)) + (cond ((= char ?\\) + (forward-char 1) + (if (not (eobp)) + (forward-char 1))) + ((= char ?,) + (setq s (buffer-substring start (point))) + (if (or (null (string-match "^[\t\f\n\r ]+$" s)) + (not (string= s ""))) + (setq list (cons s list))) + (skip-chars-forward ",\t\f\n\r ") + (setq start (point))) + ((= char ?\") + (re-search-forward "[^\\]\"" nil 0)) + ((= char ?\() + (let ((parens 1)) + (forward-char 1) + (while (and (not (eobp)) (not (zerop parens))) + (re-search-forward "[()]" nil 0) + (cond ((or (eobp) + (= (char-after (- (point) 2)) ?\\))) + ((= (preceding-char) ?\() + (setq parens (1+ parens))) + (t + (setq parens (1- parens))))))))) + (setq s (buffer-substring start (point))) + (if (and (null (string-match "^[\t\f\n\r ]+$" s)) + (not (string= s ""))) + (setq list (cons s list))) + (nreverse list))))) + +;;; Queue. +(defvar elmo-dop-queue-filename "queue" + "*Disconnected operation queue is saved in this file.") + +(defun elmo-dop-queue-load () + (setq elmo-dop-queue + (elmo-object-load + (expand-file-name elmo-dop-queue-filename + elmo-msgdb-directory)))) + +(defun elmo-dop-queue-save () + (elmo-object-save + (expand-file-name elmo-dop-queue-filename + elmo-msgdb-directory) + elmo-dop-queue)) + +(if (and (fboundp 'regexp-opt) + (not (featurep 'xemacs))) + (defalias 'elmo-regexp-opt 'regexp-opt) + (defun elmo-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)))) + +(require 'product) +(product-provide (provide 'elmo-util) (require 'elmo-version)) ;;; elmo-util.el ends here