-;;; elmo-util.el -- Utilities for Elmo.
+;;; elmo-util.el --- Utilities for ELMO.
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: mail, net news
;;
;;; Commentary:
-;;
+;;
;;; Code:
-;;
+;;
+(eval-when-compile
+ (require 'cl)
+ (require 'static))
(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)
-(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*")
(fset 'elmo-base64-decode-string
(mel-find-function 'mime-decode-string "base64"))
-;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
-;; Check make-symbolic-link() instead. -- 981002 by Fuji
-(if (fboundp 'make-symbolic-link) ;; xxx
- (defalias 'elmo-add-name-to-file 'add-name-to-file)
- (defun elmo-add-name-to-file
- (filename newname &optional ok-if-already-exists)
- (copy-file filename newname ok-if-already-exists t)))
-
-(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)))
-
-;; Nemacs's `read' is different.
-(static-if (fboundp 'nemacs-version)
- (defun elmo-read (obj)
- (prog1 (read obj)
- (if (bufferp obj)
- (or (bobp) (forward-char -1)))))
- (defalias 'elmo-read 'read))
+(eval-and-compile
+ (if elmo-use-hardlink
+ (defalias 'elmo-add-name-to-file 'add-name-to-file)
+ (defun elmo-add-name-to-file
+ (filename newname &optional ok-if-already-exists)
+ (copy-file filename newname ok-if-already-exists t))))
(defmacro elmo-set-work-buf (&rest body)
- "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)
- (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)))))
+ "Execute BODY on work buffer. Work buffer remains."
+ `(with-current-buffer (get-buffer-create elmo-work-buf-name)
+ (set-buffer-multibyte default-enable-multibyte-characters)
+ (erase-buffer)
+ ,@body))
+
+(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)))))
+ `(let ((default-directory (file-name-as-directory ,dir)))
+ ,@body))
+
+(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)
+
+(static-if (condition-case nil
+ (plist-get '(one) 'other)
+ (error t))
+ (defmacro elmo-safe-plist-get (plist prop)
+ `(ignore-errors
+ (plist-get ,plist ,prop)))
+ (defalias 'elmo-safe-plist-get 'plist-get))
+
+(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.
(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-get-network-stream-type (stream-type stream-type-alist)
- (catch 'found
- (while stream-type-alist
- (if (eq (nth 1 (car stream-type-alist)) stream-type)
- (throw 'found (car stream-type-alist)))
- (setq stream-type-alist (cdr stream-type-alist)))))
-
-(defun elmo-network-get-spec (folder server port stream-type stream-type-alist)
- (setq stream-type (elmo-get-network-stream-type
- stream-type stream-type-alist))
- (when (string-match "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!.*\\)?$" folder)
- (if (match-beginning 1)
- (setq server (elmo-match-substring 1 folder 1)))
- (if (match-beginning 2)
- (setq port (string-to-int (elmo-match-substring 2 folder 1))))
- (if (match-beginning 3)
- (setq stream-type (assoc (elmo-match-string 3 folder)
- stream-type-alist)))
- (setq folder (substring folder 0 (match-beginning 0))))
- (cons folder (list server port stream-type)))
-
-(defun elmo-imap4-get-spec (folder)
- (let ((default-user elmo-default-imap4-user)
- (default-server elmo-default-imap4-server)
- (default-port elmo-default-imap4-port)
- (default-stream-type elmo-default-imap4-stream-type)
- (stream-type-alist elmo-network-stream-type-alist)
- spec mailbox user auth)
- (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
- ;; case: default-imap4-server is specified like
- ;; "hoge%imap.server@gateway".
- (setq default-user (elmo-match-string 1 default-server))
- (setq default-server (elmo-match-string 2 default-server)))
- (if elmo-imap4-stream-type-alist
- (setq stream-type-alist
- (append elmo-imap4-stream-type-alist stream-type-alist)))
- (setq spec (elmo-network-get-spec
- folder default-server default-port default-stream-type
- stream-type-alist))
- (setq folder (car spec))
- (when (string-match
- "^\\(%\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
- folder)
- (progn
- (setq mailbox (if (match-beginning 2)
- (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)
- (intern (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-stream-type (spec)
- (nth 6 spec))
-
-(defalias 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox)
-(make-obsolete 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox)
-
-(defsubst elmo-imap4-connection-get-process (conn)
- (nth 1 conn))
-
-(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 ((stream-type-alist elmo-network-stream-type-alist)
- spec group user)
- (if elmo-nntp-stream-type-alist
- (setq stream-type-alist
- (append elmo-nntp-stream-type-alist stream-type-alist)))
- (setq spec (elmo-network-get-spec folder
- elmo-default-nntp-server
- elmo-default-nntp-port
- elmo-default-nntp-stream-type
- stream-type-alist))
- (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-stream-type (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 <fuji0924@mbox.kyoto-inet.or.jp>
-(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 ((stream-type-alist elmo-network-stream-type-alist)
- spec user auth)
- (if elmo-pop3-stream-type-alist
- (setq stream-type-alist
- (append elmo-pop3-stream-type-alist stream-type-alist)))
- (setq spec (elmo-network-get-spec folder
- elmo-default-pop3-server
- elmo-default-pop3-port
- elmo-default-pop3-stream-type
- stream-type-alist))
- (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)
- (intern (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-stream-type (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)
- (when (string-match "^\\(/\\)\\(.*\\)$" folder)
- (let ((folder (elmo-match-string 2 folder))
- pair)
- (setq pair (elmo-parse-search-condition folder))
- (if (string-match "^ */\\(.*\\)$" (cdr pair))
- (list 'filter (car pair) (elmo-match-string 1 (cdr pair)))
- (error "Folder syntax error `%s'" folder)))))
-
-(defun elmo-pipe-get-spec (folder)
- (when (string-match "^\\(|\\)\\([^|]*\\)|\\(.*\\)$" folder)
- (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
- (save-match-data
- (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 "[^/ \")|&]*")
-(defun elmo-read-search-condition (default)
- "Read search condition string interactively"
- (elmo-read-search-condition-internal "Search by" default))
-
-(defun elmo-read-search-condition-internal (prompt default)
- (let* ((completion-ignore-case t)
- (field (completing-read
- (format "%s (%s): " prompt default)
- (mapcar 'list
- (append '("AND" "OR"
- "Last" "First"
- "From" "Subject" "To" "Cc" "Body"
- "Since" "Before" "ToCc"
- "!From" "!Subject" "!To" "!Cc" "!Body"
- "!Since" "!Before" "!ToCc")
- elmo-msgdb-extra-fields))))
- value)
- (setq field (if (string= field "")
- (setq field default)
- field))
- (cond
- ((or (string= field "AND") (string= field "OR"))
- (concat "("
- (elmo-read-search-condition-internal
- (concat field "(1) Search by") default)
- (if (string= field "AND") "&" "|")
- (elmo-read-search-condition-internal
- (concat field "(2) Search by") default)
- ")"))
- ((string-match "Since\\|Before" field)
- (concat (downcase field) ":"
- (completing-read (format "Value for '%s': " field)
- (mapcar (function
- (lambda (x)
- (list (format "%s" (car x)))))
- elmo-date-descriptions))))
- (t
- (setq value (read-from-minibuffer (format "Value for '%s': " field)))
- (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
- value)
- (setq value (prin1-to-string value)))
- (concat (downcase field) ":" value)))))
-
(defsubst elmo-condition-parse-error ()
(error "Syntax error in '%s'" (buffer-string)))
(elmo-condition-parse-error)))
;; or-expr ::= and-expr /
-;; and-expr "|" or-expr
+;; and-expr "|" or-expr
(defun elmo-condition-parse-or-expr ()
(let ((left (elmo-condition-parse-and-expr)))
(if (looking-at "| *")
;; primitive ::= "(" expr ")" /
;; ["!"] search-key SPACE* ":" SPACE* search-value
(defun elmo-condition-parse-primitive ()
- (cond
+ (cond
((looking-at "( *")
(goto-char (match-end 0))
(prog1 (elmo-condition-parse)
(goto-char (match-end 0))))
;; search-key ::= [A-Za-z-]+
;; ;; "since" / "before" / "last" / "first" /
-;; ;; "body" / field-name
+;; ;; "body" / "flag" / field-name
((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
(goto-char (match-end 0))
(let ((search-key (vector
(if (match-beginning 1) 'unmatch 'match)
- (elmo-match-buffer 2)
+ (downcase (elmo-match-buffer 2))
(elmo-condition-parse-search-value))))
;; syntax sugar.
(if (string= (aref search-key 1) "tocc")
;; 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"
(defun elmo-condition-parse-search-value ()
(cond
((looking-at "\"")
- (elmo-read (current-buffer)))
- ((or (looking-at "yesterday") (looking-at "lastweek")
+ (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]+")
- (looking-at elmo-condition-atom-regexp))
+ (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)))))
-;;;
-(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-condition-p (filter)
+ `(or (vectorp ,filter) (consp ,filter)))
+
+(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)
(defsubst elmo-delete-char (char string &optional unibyte)
(save-match-data
(elmo-set-work-buf
- (let ((coding-system-for-read 'no-conversion)
- (coding-system-for-write 'no-conversion))
- (if unibyte (elmo-set-buffer-multibyte nil))
- (insert string)
- (goto-char (point-min))
- (while (search-forward (char-to-string char) nil t)
- (replace-match ""))
- (buffer-string)))))
+ (let ((coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion))
+ (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
(defun elmo-delete-cr (string)
(save-match-data
(elmo-set-work-buf
- (insert string)
- (goto-char (point-min))
- (while (search-forward "\r\n" nil t)
- (replace-match "\n"))
- (buffer-string))))
+ (insert string)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
+ (buffer-string))))
+
+(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)
+(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-union (l1 l2)
+ "Make a union of two lists"
+ (elmo-uniq-sorted-list (sort (append l1 l2) #'<)))
+
+(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
- (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
- insert-file-contents-post-hook)
- (when (file-exists-p filename)
- (if filename
- (as-binary-input-file (insert-file-contents filename)))
- (when (and remove-final-newline
- (> (buffer-size) 0)
- (= (char-after (1- (point-max))) ?\n))
- (goto-char (point-max))
- (delete-backward-char 1))
- (buffer-string)))))
+ (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
+ insert-file-contents-post-hook)
+ (when (file-exists-p filename)
+ (if filename
+ (as-binary-input-file (insert-file-contents filename)))
+ (when (and remove-final-newline
+ (> (buffer-size) 0)
+ (= (char-after (1- (point-max))) ?\n))
+ (goto-char (point-max))
+ (delete-char -1))
+ (buffer-string)))))
(defun elmo-save-string (string filename)
(if string
(elmo-set-work-buf
- (as-binary-output-file
- (insert string)
- (write-region (point-min) (point-max)
- filename nil 'no-msg))
- )))
+ (as-binary-output-file
+ (insert string)
+ (write-region (point-min) (point-max)
+ filename nil 'no-msg))
+ )))
(defun elmo-max-of-list (nlist)
(let ((l nlist)
(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
- (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)
- (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)))
+ (let ((filename (expand-file-name elmo-passwd-alist-file-name
+ elmo-msgdb-directory)))
+ (if (not (file-readable-p filename))
+ ()
+ (with-temp-buffer
+ (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
+ insert-file-contents-post-hook)
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (ignore-errors
+ (read (current-buffer))))))))
(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))))
+ (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."
(elmo-base64-encode-string pass)))))
(if elmo-passwd-life-time
(run-with-timer elmo-passwd-life-time nil
- (` (lambda () (elmo-remove-passwd (, key))))))
+ `(lambda () (elmo-remove-passwd ,key))))
pass)))
(defun elmo-remove-passwd (key)
"Remove password from password pool (for failure)."
(let (pass-cons)
- (if (setq pass-cons (assoc key elmo-passwd-alist))
- (progn
- (unwind-protect
- (fillarray (cdr pass-cons) 0))
- (setq elmo-passwd-alist
- (delete pass-cons elmo-passwd-alist))))))
+ (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."
(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)
- (goto-char (point-min))
- (insert "(")
- (goto-char (point-max))
- (insert ")")
- (goto-char (point-min))
- (read (current-buffer))))
+ (insert string)
+ (goto-char (point-min))
+ (insert "(")
+ (goto-char (point-max))
+ (insert ")")
+ (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)))
(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
(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)
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)
(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)))
(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)
(directory-files path t "^[^\\.]")
(error nil)))
(result 0.0))
- ;; (result (nth 7 file-attr))) ... directory size
+;;; (result (nth 7 file-attr))) ; ... directory size
(while files
(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)
"Return the last accessed time of PATH."
(setq last-modified (+ (* (nth 0 last-modified)
(float 65536)) (nth 1 last-modified)))))
-(defun elmo-make-directory (path)
+(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."
+ (if (stringp path) ; nil is not permitted.
(let ((dirent (directory-files path))
relpath abspath hierarchy)
(while dirent
(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)))
(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
(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"
- (if (null list2)
- (cons list1 nil)
- (let* ((l1 list1)
- (l2 list2)
- (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
- diff1 num i percent
- )
- (setq i 0)
- (setq num (+ (length l1)))
- (while l1
- (if (memq (car l1) l2)
- (if (eq (car l1) (car l2))
- (setq l2 (cdr l2))
- (delq (car l1) l2))
- (if (> (car l1) max-of-l2)
- (setq diff1 (nconc diff1 (list (car l1))))))
- (if mes
- (progn
- (setq i (+ i 1))
- (setq percent (/ (* i 100) num))
- (if (eq (% percent 5) 0)
- (elmo-display-progress
- 'elmo-list-bigger-diff "%s%d%%" percent mes))))
- (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 ;; No use.
- ; (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-primitive-condition-match (condition
- number
- number-list)
- (let (result)
- (goto-char (point-min))
- (cond
- ((string= (elmo-filter-key condition) "last")
- (setq result (<= (length (memq number number-list))
- (string-to-int (elmo-filter-value condition)))))
- ((string= (elmo-filter-key condition) "first")
- (setq result (< (- (length number-list)
- (length (memq number number-list)))
- (string-to-int (elmo-filter-value condition)))))
- ((string= (elmo-filter-key condition) "since")
- (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
- (setq result
- (string<
- (timezone-make-sortable-date (aref date 0)
- (aref date 1)
- (aref date 2)
- (timezone-make-time-string
- (aref date 3)
- (aref date 4)
- (aref date 5)))
- (timezone-make-date-sortable (std11-field-body "date"))))))
- ((string= (elmo-filter-key condition) "before")
- (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
- (setq result
- (string<
- (timezone-make-date-sortable (std11-field-body "date"))
- (timezone-make-sortable-date (aref date 0)
- (aref date 1)
- (aref date 2)
- (timezone-make-time-string
- (aref date 3)
- (aref date 4)
- (aref date 5)))))))
- ((string= (elmo-filter-key condition) "body")
- (and (re-search-forward "^$" nil t) ; goto body
- (setq result (search-forward (elmo-filter-value condition)
- nil t))))
- (t
- (let ((fval (std11-field-body (elmo-filter-key condition))))
- (if (eq (length fval) 0) (setq fval nil))
- (if fval (setq fval (eword-decode-string fval)))
- (setq result (and fval (string-match
- (elmo-filter-value condition) fval))))))
- (if (eq (elmo-filter-type condition) 'unmatch)
- (setq result (not result)))
- result))
-
-(defun elmo-condition-find-key-internal (condition key)
- (cond
- ((vectorp condition)
- (if (string= (elmo-filter-key condition) key)
- (throw 'found t)))
- ((or (eq (car condition) 'and)
- (eq (car condition) 'or))
- (elmo-condition-find-key-internal (nth 1 condition) key)
- (elmo-condition-find-key-internal (nth 2 condition) key))))
-
-(defun elmo-condition-find-key (condition key)
- (catch 'found
- (elmo-condition-find-key-internal condition key)))
-
-(defun elmo-buffer-field-condition-match (condition number number-list)
- (cond
- ((vectorp condition)
- (elmo-buffer-field-primitive-condition-match
- condition number number-list))
- ((eq (car condition) 'and)
- (and (elmo-buffer-field-condition-match
- (nth 1 condition) number number-list)
- (elmo-buffer-field-condition-match
- (nth 2 condition) number number-list)))
- ((eq (car condition) 'or)
- (or (elmo-buffer-field-condition-match
- (nth 1 condition) number number-list)
- (elmo-buffer-field-condition-match
- (nth 2 condition) number number-list)))))
-
-(defsubst elmo-file-field-condition-match (file condition number number-list)
- (elmo-set-work-buf
- (as-binary-input-file (insert-file-contents file))
- (elmo-set-buffer-multibyte default-enable-multibyte-characters)
- ;; Should consider charset?
- (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
- (elmo-buffer-field-condition-match condition number number-list)))
-
(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 'makunbound (list 'intern string hashtable))))
(defmacro elmo-unintern (string)
- ;; Emacs 19.28 or earlier does not have unintern.
+ "`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 a new hash table which have HASHSIZE size."
(make-vector
- (if hashsize (max (min (elmo-create-hash-size hashsize)
- elmo-hash-maximum-size) 1024) 1024) 0))
+ (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
(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
(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))
(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 (copy-file src dst t)
- (error "copy file failed"))))
+ (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)
(kill-buffer buffer)))
(defun elmo-delete-if (pred lst)
- "Return 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))
+ (nreverse result)))
-(defun elmo-list-delete (list1 list2)
+(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'."
+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, return t."
+ "If any element of LIST1 is member of LIST2, return t."
(catch 'done
(while list1
(if (member (car list1) list2)
(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)
(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))
(list 'error-message doc
'error-conditions (cons error conds))))))
-(cond ((fboundp 'lprogress-display)
- (defalias 'elmo-display-progress 'lprogress-display))
- ((fboundp 'progress-feedback-with-label)
- (defalias 'elmo-display-progress 'progress-feedback-with-label))
- (t
- (defun elmo-display-progress (label format &optional value &rest args)
- "Print a progress message."
- (if (and (null format) (null args))
- (message nil)
- (apply (function message) (concat format " %d%%")
- (nconc args (list value)))))))
+(defvar elmo-progress-counter nil)
+
+(defalias 'elmo-progress-counter-label 'car-safe)
+
+(defmacro elmo-progress-counter-value (counter)
+ `(aref (cdr ,counter) 0))
+
+(defmacro elmo-progress-counter-set-value (counter value)
+ `(aset (cdr ,counter) 0 ,value))
+
+(defmacro elmo-progress-counter-total (counter)
+ `(aref (cdr ,counter) 1))
+
+(defmacro elmo-progress-counter-set-total (counter value)
+ `(aset (cdr ,counter) 1 ,value))
+
+(defmacro elmo-progress-counter-action (counter)
+ `(aref (cdr ,counter) 2))
+
+(defmacro elmo-progress-counter-set-action (counter action)
+ `(aset (cdr ,counter) 2, action))
+
+(defvar elmo-progress-callback-function nil)
+
+(defun elmo-progress-call-callback (counter &optional value)
+ (when elmo-progress-callback-function
+ (funcall elmo-progress-callback-function
+ (elmo-progress-counter-label counter)
+ (elmo-progress-counter-action counter)
+ (or value
+ (elmo-progress-counter-value counter))
+ (elmo-progress-counter-total counter))))
+
+(defun elmo-progress-start (label total action)
+ (when (and (null elmo-progress-counter)
+ (or (null total)
+ (> total 0)))
+ (let ((counter (cons label (vector 0 total action))))
+ (elmo-progress-call-callback counter 'start)
+ (setq elmo-progress-counter
+ (cond ((null total)
+ counter)
+ ((elmo-progress-call-callback counter 'query)
+ (elmo-progress-call-callback counter)
+ counter)
+ (t
+ t)))
+ counter)))
+
+(defun elmo-progress-clear (counter)
+ (when counter
+ (when (and (elmo-progress-counter-label elmo-progress-counter)
+ (elmo-progress-counter-total elmo-progress-counter))
+ (elmo-progress-call-callback elmo-progress-counter 100))
+ (setq elmo-progress-counter nil)))
+
+(defun elmo-progress-done (counter)
+ (when (elmo-progress-counter-label counter)
+ (elmo-progress-call-callback counter 'done)))
+
+(defun elmo-progress-notify (label &rest params)
+ (when (eq label (elmo-progress-counter-label elmo-progress-counter))
+ (let ((counter elmo-progress-counter))
+ (if (or (elmo-progress-counter-total counter)
+ (and (elmo-progress-counter-set-total
+ counter
+ (elmo-safe-plist-get params :total))
+ (elmo-progress-call-callback counter 'query)))
+ (progn
+ (elmo-progress-counter-set-value
+ counter
+ (or (elmo-safe-plist-get params :set)
+ (+ (elmo-progress-counter-value counter)
+ (or (elmo-safe-plist-get params :inc)
+ (car params)
+ 1))))
+ (elmo-progress-call-callback counter))
+ (setq elmo-progress-counter t)))))
+
+(defmacro elmo-with-progress-display (spec message &rest body)
+ "Evaluate BODY with progress message and return its value.
+SPEC is a list as followed (LABEL TOTAL [VAR]).
+LABEL is an identifier what is specidied by `elmo-progress-notify'.
+If TOTAL is nil, the first `elmo-progress-notify' call must be
+with a `:total' parameter.
+If optional parameter VAR is specified, bind it with a progress counter object.
+MESSAGE is a doing part of progress message."
+ (let ((label (nth 0 spec))
+ (total (nth 1 spec))
+ (var (or (nth 2 spec) (make-symbol "--elmo-progress-temp--"))))
+ `(let ((,var (elmo-progress-start (quote ,label) ,total ,message)))
+ (prog1
+ (unwind-protect
+ (progn
+ ,@body)
+ (elmo-progress-clear ,var))
+ (elmo-progress-done ,var)))))
+
+(put 'elmo-with-progress-display 'lisp-indent-function '2)
+(def-edebug-spec elmo-with-progress-display
+ ((symbolp form &optional symbolp) form &rest form))
(defun elmo-time-expire (before-time diff-time)
(let* ((current (current-time))
(and (eq (car diff) 0)
(< diff-time (nth 1 diff)))))
-(if (fboundp 'std11-fetch-field)
- (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
- (defalias 'elmo-field-body 'std11-field-body))
+(eval-and-compile
+ (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"
- (` (let ((obj (copy-sequence (, string))))
- (set-text-properties 0 (length obj) nil obj)
- obj)))
+ "STRING without text property."
+ `(let ((obj (copy-sequence ,string)))
+ (and obj (set-text-properties 0 (length obj) nil obj))
+ obj))
+
+(defun elmo-flatten (list-of-list)
+ "Flatten LIST-OF-LIST."
+ (and list-of-list
+ (apply #'append
+ (mapcar (lambda (element)
+ (if (listp element) element (list element)))
+ list-of-list))))
(defun elmo-y-or-n-p (prompt &optional auto default)
"Same as `y-or-n-p'.
(y-or-n-p prompt)))
(defun elmo-string-member (string slist)
- "Return 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))
(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
(throw 'loop a))
(setq alist (cdr alist))))))
+(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 <okazaki@be.to>
-;;
+;;
;; number ::= [0-9]+
;; beg ::= number
;; end ::= number
(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 "^[^\\.]"))
+ elist ret-val)
+ (elmo-with-progress-display (elmo-collecting-cache (length dirs))
+ "Collecting cache info"
+ (dolist (dir dirs)
+ (setq elist (mapcar (lambda (x)
+ (elmo-cache-make-file-entity x dir))
+ (directory-files dir nil "^[^\\.]")))
+ (setq ret-val (append ret-val
+ (list (cons
+ dir
+ (sort
+ elist
+ (lambda (x y)
+ (< (cdr x)
+ (cdr y))))))))))
+ ret-val))
+
+(defun elmo-cache-expire-by-age (&optional days)
+ "Expire cache file by age.
+Optional argument DAYS specifies the days to expire caches."
+ (interactive)
+ (let ((age (or (and days (number-to-string days))
+ (and (interactive-p)
+ (read-from-minibuffer
+ (format "Enter days (%s): "
+ elmo-cache-expire-default-age)))
+ (number-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-number 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)))))
+ (elmo-delete-cr-buffer))))
+
+;;
+;; 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))
projects / elisp / wanderlust.git / blobdiff