elmo/elmo-util.el

   1 ;;; elmo-util.el -- Utilities for Elmo.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (eval-when-compile (require 'cl))
  33 (require 'elmo-vars)
  34 (require 'elmo-date)
  35 (require 'std11)
  36 (require 'eword-decode)
  37 (require 'utf7)
  38
  39 (defmacro elmo-set-buffer-multibyte (flag)
  40   "Set the multibyte flag of the current buffer to FLAG."
  41   (cond ((boundp 'MULE)
  42          (list 'setq 'mc-flag flag))
  43         ((featurep 'xemacs)
  44          flag)
  45         ((and (boundp 'emacs-major-version) (>= emacs-major-version 20))
  46          (list 'set-buffer-multibyte flag))
  47         (t
  48          flag)))
  49
  50 (defvar elmo-work-buf-name " *elmo work*")
  51 (defvar elmo-temp-buf-name " *elmo temp*")
  52
  53 (or (boundp 'default-enable-multibyte-characters)
  54     (defvar default-enable-multibyte-characters (featurep 'mule)
  55       "The mock variable except for Emacs 20."))
  56
  57 (defun elmo-base64-encode-string (string &optional no-line-break))
  58 (defun elmo-base64-decode-string (string))
  59
  60 ;; base64 encoding/decoding
  61 (require 'mel)
  62 (fset 'elmo-base64-encode-string
  63       (mel-find-function 'mime-encode-string "base64"))
  64 (fset 'elmo-base64-decode-string
  65       (mel-find-function 'mime-decode-string "base64"))
  66
  67 ;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
  68 ;; Check make-symbolic-link() instead.  -- 981002 by Fuji
  69 (if (fboundp 'make-symbolic-link)  ;; xxx
  70     (defalias 'elmo-add-name-to-file 'add-name-to-file)
  71   (defun elmo-add-name-to-file
  72     (filename newname &optional ok-if-already-exists)
  73     (copy-file filename newname ok-if-already-exists t)))
  74
  75 ;; Nemacs's `read' is different.
  76 (static-if (fboundp 'nemacs-version)
  77     (defun elmo-read (obj)
  78       (prog1 (read obj)
  79         (if (bufferp obj)
  80             (or (bobp) (forward-char -1)))))
  81   (defalias 'elmo-read 'read))
  82
  83 (defmacro elmo-set-work-buf (&rest body)
  84   "Execute BODY on work buffer.  Work buffer remains."
  85   (` (save-excursion
  86        (set-buffer (get-buffer-create elmo-work-buf-name))
  87        (elmo-set-buffer-multibyte default-enable-multibyte-characters)
  88        (erase-buffer)
  89        (,@ body))))
  90
  91 (defmacro elmo-bind-directory (dir &rest body)
  92   "Set current directory DIR and execute BODY."
  93   (` (let ((default-directory (file-name-as-directory (, dir))))
  94        (,@ body))))
  95
  96 (defun elmo-object-load (filename &optional mime-charset no-err)
  97   "Load OBJECT from the file specified by FILENAME.
  98 File content is decoded with MIME-CHARSET."
  99     (if (not (file-readable-p filename))
 100         nil
 101       (elmo-set-work-buf
 102        (as-binary-input-file
 103         (insert-file-contents filename))
 104        (when mime-charset
 105          (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 106          (decode-mime-charset-region (point-min) (point-max) mime-charset))
 107        (condition-case nil
 108            (read (current-buffer))
 109          (error (unless no-err
 110                   (message "Warning: Loading object from %s failed."
 111                            filename)
 112                   (elmo-object-save filename nil))
 113                 nil)))))
 114
 115 (defsubst elmo-save-buffer (filename &optional mime-charset)
 116   "Save current buffer to the file specified by FILENAME.
 117 Directory of the file is created if it doesn't exist.
 118 File content is encoded with MIME-CHARSET."
 119   (let ((dir (directory-file-name (file-name-directory filename))))
 120     (if (file-directory-p dir)
 121         () ; ok.
 122       (unless (file-exists-p dir)
 123         (elmo-make-directory dir)))
 124     (if (file-writable-p filename)
 125         (progn
 126           (when mime-charset
 127 ;;;         (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 128             (encode-mime-charset-region (point-min) (point-max) mime-charset))
 129           (as-binary-output-file
 130            (write-region (point-min) (point-max) filename nil 'no-msg)))
 131       (message (format "%s is not writable." filename)))))
 132
 133 (defun elmo-object-save (filename object &optional mime-charset)
 134   "Save OBJECT to the file specified by FILENAME.
 135 Directory of the file is created if it doesn't exist.
 136 File content is encoded with MIME-CHARSET."
 137   (elmo-set-work-buf
 138    (prin1 object (current-buffer))
 139 ;;;(princ "\n" (current-buffer))
 140    (elmo-save-buffer filename mime-charset)))
 141
 142 (defun elmo-get-network-stream-type (stream-type stream-type-alist)
 143   (catch 'found
 144     (while stream-type-alist
 145       (if (eq (nth 1 (car stream-type-alist)) stream-type)
 146           (throw 'found (car stream-type-alist)))
 147       (setq stream-type-alist (cdr stream-type-alist)))))
 148
 149 ;;; Search Condition
 150
 151 (defconst elmo-condition-atom-regexp "[^/ \")|&]*")
 152
 153 (defun elmo-read-search-condition (default)
 154   "Read search condition string interactively."
 155   (elmo-read-search-condition-internal "Search by" default))
 156
 157 (defun elmo-read-search-condition-internal (prompt default)
 158   (let* ((completion-ignore-case t)
 159          (field (completing-read
 160                  (format "%s (%s): " prompt default)
 161                  (mapcar 'list
 162                          (append '("AND" "OR"
 163                                    "Last" "First"
 164                                    "From" "Subject" "To" "Cc" "Body"
 165                                    "Since" "Before" "ToCc"
 166                                    "!From" "!Subject" "!To" "!Cc" "!Body"
 167                                    "!Since" "!Before" "!ToCc")
 168                                  elmo-msgdb-extra-fields)) nil t))
 169          value)
 170     (setq field (if (string= field "")
 171                     (setq field default)
 172                   field))
 173     (cond
 174      ((or (string= field "AND") (string= field "OR"))
 175       (concat "("
 176               (elmo-read-search-condition-internal
 177                (concat field "(1) Search by") default)
 178               (if (string= field "AND") "&" "|")
 179               (elmo-read-search-condition-internal
 180                (concat field "(2) Search by") default)
 181               ")"))
 182      ((string-match "Since\\|Before" field)
 183       (concat (downcase field) ":"
 184               (completing-read (format "Value for '%s': " field)
 185                                (mapcar (function
 186                                         (lambda (x)
 187                                           (list (format "%s" (car x)))))
 188                                        elmo-date-descriptions))))
 189      (t
 190       (setq value (read-from-minibuffer (format "Value for '%s': " field)))
 191       (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
 192                             value)
 193         (setq value (prin1-to-string value)))
 194       (concat (downcase field) ":" value)))))
 195
 196 (defsubst elmo-condition-parse-error ()
 197   (error "Syntax error in '%s'" (buffer-string)))
 198
 199 (defun elmo-parse-search-condition (condition)
 200   "Parse CONDITION.
 201 Return value is a cons cell of (STRUCTURE . REST)"
 202   (with-temp-buffer
 203     (insert condition)
 204     (goto-char (point-min))
 205     (cons (elmo-condition-parse) (buffer-substring (point) (point-max)))))
 206
 207 ;; condition    ::= or-expr
 208 (defun elmo-condition-parse ()
 209   (or (elmo-condition-parse-or-expr)
 210       (elmo-condition-parse-error)))
 211
 212 ;; or-expr      ::= and-expr /
 213 ;;                  and-expr "|" or-expr
 214 (defun elmo-condition-parse-or-expr ()
 215   (let ((left (elmo-condition-parse-and-expr)))
 216     (if (looking-at "| *")
 217         (progn
 218           (goto-char (match-end 0))
 219           (list 'or left (elmo-condition-parse-or-expr)))
 220       left)))
 221
 222 ;; and-expr     ::= primitive /
 223 ;;                  primitive "&" and-expr
 224 (defun elmo-condition-parse-and-expr ()
 225   (let ((left (elmo-condition-parse-primitive)))
 226     (if (looking-at "& *")
 227         (progn
 228           (goto-char (match-end 0))
 229           (list 'and left (elmo-condition-parse-and-expr)))
 230       left)))
 231
 232 ;; primitive    ::= "(" expr ")" /
 233 ;;                  ["!"] search-key SPACE* ":" SPACE* search-value
 234 (defun elmo-condition-parse-primitive ()
 235   (cond
 236    ((looking-at "( *")
 237     (goto-char (match-end 0))
 238     (prog1 (elmo-condition-parse)
 239       (unless (looking-at ") *")
 240         (elmo-condition-parse-error))
 241       (goto-char (match-end 0))))
 242 ;; search-key   ::= [A-Za-z-]+
 243 ;;                 ;; "since" / "before" / "last" / "first" /
 244 ;;                 ;; "body" / field-name
 245    ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
 246     (goto-char (match-end 0))
 247     (let ((search-key (vector
 248                        (if (match-beginning 1) 'unmatch 'match)
 249                        (elmo-match-buffer 2)
 250                        (elmo-condition-parse-search-value))))
 251       ;; syntax sugar.
 252       (if (string= (aref search-key 1) "tocc")
 253           (if (eq (aref search-key 0) 'match)
 254               (list 'or
 255                     (vector 'match "to" (aref search-key 2))
 256                     (vector 'match "cc" (aref search-key 2)))
 257             (list 'and
 258                   (vector 'unmatch "to" (aref search-key 2))
 259                   (vector 'unmatch "cc" (aref search-key 2))))
 260         search-key)))))
 261
 262 ;; search-value ::= quoted / time / number / atom
 263 ;; quoted       ::= <elisp string expression>
 264 ;; time         ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" /
 265 ;;                   number SPACE* "daysago" /
 266 ;;                   number "-" month "-" number  ; ex. 10-May-2000
 267 ;; number       ::= [0-9]+
 268 ;; month        ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" /
 269 ;;                  "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec"
 270 ;; atom         ::= ATOM_CHARS*
 271 ;; SPACE        ::= <ascii space character, 0x20>
 272 ;; ATOM_CHARS   ::= <any character except specials>
 273 ;; specials     ::= SPACE / <"> / </> / <)> / <|> / <&>
 274 ;;                  ;; These characters should be quoted.
 275 (defun elmo-condition-parse-search-value ()
 276   (cond
 277    ((looking-at "\"")
 278     (elmo-read (current-buffer)))
 279    ((or (looking-at "yesterday") (looking-at "lastweek")
 280         (looking-at "lastmonth") (looking-at "lastyear")
 281         (looking-at "[0-9]+ *daysago")
 282         (looking-at "[0-9]+-[A-Za-z]+-[0-9]+")
 283         (looking-at "[0-9]+")
 284         (looking-at elmo-condition-atom-regexp))
 285     (prog1 (elmo-match-buffer 0)
 286       (goto-char (match-end 0))))
 287    (t (error "Syntax error '%s'" (buffer-string)))))
 288
 289 ;;;
 290 (defsubst elmo-buffer-replace (regexp &optional newtext)
 291   (goto-char (point-min))
 292   (while (re-search-forward regexp nil t)
 293     (replace-match (or newtext ""))))
 294
 295 (defsubst elmo-delete-char (char string &optional unibyte)
 296   (save-match-data
 297     (elmo-set-work-buf
 298      (let ((coding-system-for-read 'no-conversion)
 299            (coding-system-for-write 'no-conversion))
 300        (if unibyte (elmo-set-buffer-multibyte nil))
 301        (insert string)
 302        (goto-char (point-min))
 303        (while (search-forward (char-to-string char) nil t)
 304          (replace-match ""))
 305        (buffer-string)))))
 306
 307 (defsubst elmo-delete-cr-buffer ()
 308   "Delete CR from buffer."
 309   (save-excursion
 310     (goto-char (point-min))
 311     (while (search-forward "\r\n" nil t)
 312       (replace-match "\n")) ))
 313
 314 (defsubst elmo-delete-cr-get-content-type ()
 315   (save-excursion
 316     (goto-char (point-min))
 317     (while (search-forward "\r\n" nil t)
 318       (replace-match "\n"))
 319     (goto-char (point-min))
 320     (or (std11-field-body "content-type")
 321         t)))
 322
 323 (defun elmo-delete-cr (string)
 324   (save-match-data
 325     (elmo-set-work-buf
 326      (insert string)
 327      (goto-char (point-min))
 328      (while (search-forward "\r\n" nil t)
 329        (replace-match "\n"))
 330      (buffer-string))))
 331
 332 (defun elmo-uniq-list (lst)
 333   "Distractively uniqfy elements of LST."
 334   (let ((tmp lst))
 335     (while tmp (setq tmp
 336                      (setcdr tmp
 337                              (and (cdr tmp)
 338                                   (delete (car tmp)
 339                                           (cdr tmp)))))))
 340   lst)
 341
 342 (defun elmo-string-partial-p (string)
 343   (and (stringp string) (string-match "message/partial" string)))
 344
 345 (defun elmo-get-file-string (filename &optional remove-final-newline)
 346   (elmo-set-work-buf
 347    (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 348          insert-file-contents-post-hook)
 349      (when (file-exists-p filename)
 350        (if filename
 351            (as-binary-input-file (insert-file-contents filename)))
 352        (when (and remove-final-newline
 353                   (> (buffer-size) 0)
 354                   (= (char-after (1- (point-max))) ?\n))
 355          (goto-char (point-max))
 356          (delete-backward-char 1))
 357        (buffer-string)))))
 358
 359 (defun elmo-save-string (string filename)
 360   (if string
 361       (elmo-set-work-buf
 362        (as-binary-output-file
 363         (insert string)
 364         (write-region (point-min) (point-max)
 365                       filename nil 'no-msg))
 366        )))
 367
 368 (defun elmo-max-of-list (nlist)
 369   (let ((l nlist)
 370         (max-num 0))
 371     (while l
 372       (if (< max-num (car l))
 373           (setq max-num (car l)))
 374       (setq l (cdr l)))
 375     max-num))
 376
 377 (defun elmo-concat-path (path filename)
 378   (if (not (string= path ""))
 379       (if (string= elmo-path-sep (substring path (- (length path) 1)))
 380           (concat path filename)
 381         (concat path elmo-path-sep filename))
 382     filename))
 383
 384 (defvar elmo-passwd-alist nil)
 385
 386 (defun elmo-passwd-alist-load ()
 387   (save-excursion
 388     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 389                                       elmo-msgdb-dir))
 390           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
 391           insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 392           insert-file-contents-post-hook
 393           ret-val)
 394       (if (not (file-readable-p filename))
 395           ()
 396         (set-buffer tmp-buffer)
 397         (insert-file-contents filename)
 398         (setq ret-val
 399               (condition-case nil
 400                   (read (current-buffer))
 401                 (error nil nil))))
 402       (kill-buffer tmp-buffer)
 403       ret-val)))
 404
 405 (defun elmo-passwd-alist-clear ()
 406   "Clear password cache."
 407   (interactive)
 408   (setq elmo-passwd-alist nil))
 409
 410 (defun elmo-passwd-alist-save ()
 411   "Save password into file."
 412   (interactive)
 413   (save-excursion
 414     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 415                                       elmo-msgdb-dir))
 416           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")))
 417       (set-buffer tmp-buffer)
 418       (erase-buffer)
 419       (prin1 elmo-passwd-alist tmp-buffer)
 420       (princ "\n" tmp-buffer)
 421 ;;;   (if (and (file-exists-p filename)
 422 ;;;            (not (equal 384 (file-modes filename))))
 423 ;;;       (error "%s is not safe.chmod 600 %s!" filename filename))
 424       (if (file-writable-p filename)
 425          (progn
 426            (write-region (point-min) (point-max)
 427                          filename nil 'no-msg)
 428            (set-file-modes filename 384))
 429         (message (format "%s is not writable." filename)))
 430       (kill-buffer tmp-buffer))))
 431
 432 (defun elmo-get-passwd (key)
 433   "Get password from password pool."
 434   (let (pair pass)
 435     (if (not elmo-passwd-alist)
 436         (setq elmo-passwd-alist (elmo-passwd-alist-load)))
 437     (setq pair (assoc key elmo-passwd-alist))
 438     (if pair
 439         (elmo-base64-decode-string (cdr pair))
 440       (setq pass (elmo-read-passwd (format "Password for %s: "
 441                                            key) t))
 442       (setq elmo-passwd-alist
 443             (append elmo-passwd-alist
 444                     (list (cons key
 445                                 (elmo-base64-encode-string pass)))))
 446       (if elmo-passwd-life-time
 447           (run-with-timer elmo-passwd-life-time nil
 448                           (` (lambda () (elmo-remove-passwd (, key))))))
 449       pass)))
 450
 451 (defun elmo-remove-passwd (key)
 452   "Remove password from password pool (for failure)."
 453   (let (pass-cons)
 454     (if (setq pass-cons (assoc key elmo-passwd-alist))
 455         (progn
 456           (unwind-protect
 457               (fillarray (cdr pass-cons) 0))
 458           (setq elmo-passwd-alist
 459                 (delete pass-cons elmo-passwd-alist))))))
 460
 461 (defmacro elmo-read-char-exclusive ()
 462   (cond ((featurep 'xemacs)
 463          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
 464                                (left . ?\C-h))))
 465                 event key)
 466             (while (not
 467                     (and
 468                      (key-press-event-p (setq event (next-command-event)))
 469                      (setq key (or (event-to-character event)
 470                                    (cdr (assq (event-key event) table)))))))
 471             key))
 472         ((fboundp 'read-char-exclusive)
 473          '(read-char-exclusive))
 474         (t
 475          '(read-char))))
 476
 477 (defun elmo-read-passwd (prompt &optional stars)
 478   "Read a single line of text from user without echoing, and return it."
 479   (let ((ans "")
 480         (c 0)
 481         (echo-keystrokes 0)
 482         (cursor-in-echo-area t)
 483         (log-message-max-size 0)
 484         message-log-max done msg truncate)
 485     (while (not done)
 486       (if (or (not stars) (string= "" ans))
 487           (setq msg prompt)
 488         (setq msg (concat prompt (make-string (length ans) ?.)))
 489         (setq truncate
 490               (1+ (- (length msg) (window-width (minibuffer-window)))))
 491         (and (> truncate 0)
 492              (setq msg (concat "$" (substring msg (1+ truncate))))))
 493       (message "%s" msg)
 494       (setq c (elmo-read-char-exclusive))
 495       (cond ((= c ?\C-g)
 496              (setq quit-flag t
 497                    done t))
 498             ((or (= c ?\r) (= c ?\n) (= c ?\e))
 499              (setq done t))
 500             ((= c ?\C-u)
 501              (setq ans ""))
 502             ((and (/= c ?\b) (/= c ?\177))
 503              (setq ans (concat ans (char-to-string c))))
 504             ((> (length ans) 0)
 505              (setq ans (substring ans 0 -1)))))
 506     (if quit-flag
 507         (prog1
 508             (setq quit-flag nil)
 509           (message "Quit")
 510           (beep t))
 511       (message "")
 512       ans)))
 513
 514 (defun elmo-string-to-list (string)
 515   (elmo-set-work-buf
 516    (insert string)
 517    (goto-char (point-min))
 518    (insert "(")
 519    (goto-char (point-max))
 520    (insert ")")
 521    (goto-char (point-min))
 522    (read (current-buffer))))
 523
 524 (defun elmo-list-to-string (list)
 525   (let ((tlist list)
 526         str)
 527     (if (listp tlist)
 528         (progn
 529           (setq str "(")
 530           (while (car tlist)
 531             (setq str
 532                   (concat str
 533                           (if (symbolp (car tlist))
 534                               (symbol-name (car tlist))
 535                             (car tlist))))
 536             (if (cdr tlist)
 537                 (setq str
 538                       (concat str " ")))
 539             (setq tlist (cdr tlist)))
 540           (setq str
 541                 (concat str ")")))
 542       (setq str
 543             (if (symbolp tlist)
 544                 (symbol-name tlist)
 545               tlist)))
 546     str))
 547
 548
 549 (defun elmo-plug-on-by-servers (alist &optional servers)
 550   (let ((server-list (or servers elmo-plug-on-servers)))
 551     (catch 'plugged
 552       (while server-list
 553         (if (elmo-plugged-p (car server-list))
 554             (throw 'plugged t))
 555         (setq server-list (cdr server-list))))))
 556
 557 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
 558   (let ((server-list (or servers elmo-plug-on-exclude-servers))
 559         server other-servers)
 560     (while alist
 561       (when (and (not (member (setq server (caaar alist)) server-list))
 562                  (not (member server other-servers)))
 563         (push server other-servers))
 564       (setq alist (cdr alist)))
 565     (elmo-plug-on-by-servers alist other-servers)))
 566
 567 (defun elmo-plugged-p (&optional server port stream-type alist label-exp)
 568   (let ((alist (or alist elmo-plugged-alist))
 569         plugged-info)
 570     (cond ((and (not port) (not server))
 571            (cond ((eq elmo-plugged-condition 'one)
 572                   (if alist
 573                       (catch 'plugged
 574                         (while alist
 575                           (if (nth 2 (car alist))
 576                               (throw 'plugged t))
 577                           (setq alist (cdr alist))))
 578                     elmo-plugged))
 579                  ((eq elmo-plugged-condition 'all)
 580                   (if alist
 581                       (catch 'plugged
 582                         (while alist
 583                           (if (not (nth 2 (car alist)))
 584                               (throw 'plugged nil))
 585                           (setq alist (cdr alist)))
 586                         t)
 587                     elmo-plugged))
 588                  ((functionp elmo-plugged-condition)
 589                   (funcall elmo-plugged-condition alist))
 590                  (t ;; independent
 591                   elmo-plugged)))
 592           ((not port) ;; server
 593            (catch 'plugged
 594              (while alist
 595                (when (string= server (caaar alist))
 596                  (if (nth 2 (car alist))
 597                      (throw 'plugged t)))
 598                (setq alist (cdr alist)))))
 599           (t
 600            (setq plugged-info (assoc (list server port stream-type) alist))
 601            (if (not plugged-info)
 602                ;; add elmo-plugged-alist automatically
 603                (progn
 604                  (elmo-set-plugged elmo-plugged server port stream-type
 605                                    nil nil nil label-exp)
 606                  elmo-plugged)
 607              (if (and elmo-auto-change-plugged
 608                       (> elmo-auto-change-plugged 0)
 609                       (nth 3 plugged-info)  ;; time
 610                       (elmo-time-expire (nth 3 plugged-info)
 611                                         elmo-auto-change-plugged))
 612                  t
 613                (nth 2 plugged-info)))))))
 614
 615 (defun elmo-set-plugged (plugged &optional server port stream-type time
 616                                  alist label-exp add)
 617   (let ((alist (or alist elmo-plugged-alist))
 618         label plugged-info)
 619     (cond ((and (not port) (not server))
 620            (setq elmo-plugged plugged)
 621            ;; set plugged all element of elmo-plugged-alist.
 622            (while alist
 623              (setcdr (cdar alist) (list plugged time))
 624              (setq alist (cdr alist))))
 625           ((not port)
 626            ;; set plugged all port of server
 627            (while alist
 628              (when (string= server (caaar alist))
 629                (setcdr (cdar alist) (list plugged time)))
 630              (setq alist (cdr alist))))
 631           (t
 632            ;; set plugged one port of server
 633            (setq plugged-info (assoc (list server port stream-type) alist))
 634            (setq label (if label-exp
 635                            (eval label-exp)
 636                          (nth 1 plugged-info)))
 637            (if plugged-info
 638                ;; if add is non-nil, don't reset plug state.
 639                (unless add
 640                  (setcdr plugged-info (list label plugged time)))
 641              (setq alist
 642                    (setq elmo-plugged-alist
 643                          (nconc
 644                           elmo-plugged-alist
 645                           (list
 646                            (list (list server port stream-type)
 647                                  label plugged time))))))))
 648     alist))
 649
 650 (defun elmo-delete-plugged (&optional server port alist)
 651   (let* ((alist (or alist elmo-plugged-alist))
 652          (alist2 alist))
 653     (cond ((and (not port) (not server))
 654            (setq alist nil))
 655           ((not port)
 656            ;; delete plugged all port of server
 657            (while alist2
 658              (when (string= server (caaar alist2))
 659                (setq alist (delete (car alist2) alist)))
 660              (setq alist2 (cdr alist2))))
 661           (t
 662            ;; delete plugged one port of server
 663            (setq alist
 664                  (delete (assoc (cons server port) alist) alist))))
 665     alist))
 666
 667 (defun elmo-disk-usage (path)
 668   "Get disk usage (bytes) in PATH."
 669   (let ((file-attr
 670          (condition-case () (file-attributes path) (error nil))))
 671     (if file-attr
 672         (if (nth 0 file-attr) ; directory
 673             (let ((files (condition-case ()
 674                              (directory-files path t "^[^\\.]")
 675                            (error nil)))
 676                   (result 0.0))
 677               ;; (result (nth 7 file-attr))) ... directory size
 678               (while files
 679                 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
 680                 (setq files (cdr files)))
 681               result)
 682           (float (nth 7 file-attr))))))
 683
 684 (defun elmo-get-last-accessed-time (path &optional dir)
 685   "Return the last accessed time of PATH."
 686   (let ((last-accessed (nth 4 (file-attributes (or (and dir
 687                                                         (expand-file-name
 688                                                          path dir))
 689                                                    path)))))
 690     (if last-accessed
 691         (setq last-accessed (+ (* (nth 0 last-accessed)
 692                                   (float 65536)) (nth 1 last-accessed)))
 693       0)))
 694
 695 (defun elmo-get-last-modification-time (path &optional dir)
 696   "Return the last accessed time of PATH."
 697   (let ((last-modified (nth 5 (file-attributes (or (and dir
 698                                                         (expand-file-name
 699                                                          path dir))
 700                                                    path)))))
 701     (setq last-modified (+ (* (nth 0 last-modified)
 702                               (float 65536)) (nth 1 last-modified)))))
 703
 704 (defun elmo-make-directory (path)
 705   "Create directory recursively."
 706   (let ((parent (directory-file-name (file-name-directory path))))
 707     (if (null (file-directory-p parent))
 708         (elmo-make-directory parent))
 709     (make-directory path)
 710     (if (string= path (expand-file-name elmo-msgdb-dir))
 711         (set-file-modes path (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
 712
 713 (defun elmo-delete-directory (path &optional no-hierarchy)
 714   "Delete directory recursively."
 715   (if (stringp path) ; nil is not permitted.
 716   (let ((dirent (directory-files path))
 717         relpath abspath hierarchy)
 718     (while dirent
 719       (setq relpath (car dirent)
 720             dirent (cdr dirent)
 721             abspath (expand-file-name relpath path))
 722       (when (not (string-match "^\\.\\.?$" relpath))
 723         (if (eq (nth 0 (file-attributes abspath)) t)
 724             (if no-hierarchy
 725                 (setq hierarchy t)
 726               (elmo-delete-directory abspath no-hierarchy))
 727           (delete-file abspath))))
 728     (unless hierarchy
 729       (delete-directory path)))))
 730
 731 (defun elmo-list-filter (l1 l2)
 732   "L1 is filter."
 733   (if (eq l1 t)
 734       ;; t means filter all.
 735       nil
 736     (if l1
 737         (elmo-delete-if (lambda (x) (not (memq x l1))) l2)
 738       ;; filter is nil
 739       l2)))
 740
 741 (defsubst elmo-list-delete-if-smaller (list number)
 742   (let ((ret-val (copy-sequence list)))
 743     (while list
 744       (if (< (car list) number)
 745           (setq ret-val (delq (car list) ret-val)))
 746       (setq list (cdr list)))
 747     ret-val))
 748
 749 (defun elmo-list-diff (list1 list2 &optional mes)
 750   (if mes
 751       (message mes))
 752   (let ((clist1 (copy-sequence list1))
 753         (clist2 (copy-sequence list2)))
 754     (while list2
 755       (setq clist1 (delq (car list2) clist1))
 756       (setq list2 (cdr list2)))
 757     (while list1
 758       (setq clist2 (delq (car list1) clist2))
 759       (setq list1 (cdr list1)))
 760     (if mes
 761         (message (concat mes "done.")))
 762     (list clist1 clist2)))
 763
 764 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
 765   "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
 766   (if (null list2)
 767       (cons list1  nil)
 768     (let* ((l1 list1)
 769            (l2 list2)
 770            (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
 771            diff1 num i percent
 772            )
 773       (setq i 0)
 774       (setq num (+ (length l1)))
 775       (while l1
 776         (if (memq (car l1) l2)
 777             (if (eq (car l1) (car l2))
 778                 (setq l2 (cdr l2))
 779               (delq (car l1) l2))
 780           (if (> (car l1) max-of-l2)
 781               (setq diff1 (nconc diff1 (list (car l1))))))
 782         (if mes
 783             (progn
 784               (setq i (+ i 1))
 785               (setq percent (/ (* i 100) num))
 786               (if (eq (% percent 5) 0)
 787                   (elmo-display-progress
 788                    'elmo-list-bigger-diff "%s%d%%" percent mes))))
 789         (setq l1 (cdr l1)))
 790       (cons diff1 (list l2)))))
 791
 792 (defmacro elmo-filter-type (filter)
 793   (` (aref (, filter) 0)))
 794
 795 (defmacro elmo-filter-key (filter)
 796   (` (aref (, filter) 1)))
 797
 798 (defmacro elmo-filter-value (filter)
 799   (` (aref (, filter) 2)))
 800
 801 (defsubst elmo-buffer-field-primitive-condition-match (condition
 802                                                        number
 803                                                        number-list)
 804   (let (result)
 805     (goto-char (point-min))
 806     (cond
 807      ((string= (elmo-filter-key condition) "last")
 808       (setq result (<= (length (memq number number-list))
 809                        (string-to-int (elmo-filter-value condition)))))
 810      ((string= (elmo-filter-key condition) "first")
 811       (setq result (< (- (length number-list)
 812                          (length (memq number number-list)))
 813                       (string-to-int (elmo-filter-value condition)))))
 814      ((string= (elmo-filter-key condition) "since")
 815       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
 816         (setq result
 817               (string<
 818                (timezone-make-sortable-date (aref date 0)
 819                                             (aref date 1)
 820                                             (aref date 2)
 821                                             (timezone-make-time-string
 822                                              (aref date 3)
 823                                              (aref date 4)
 824                                              (aref date 5)))
 825                (timezone-make-date-sortable (std11-field-body "date"))))))
 826      ((string= (elmo-filter-key condition) "before")
 827       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
 828         (setq result
 829               (string<
 830                (timezone-make-date-sortable (std11-field-body "date"))
 831                (timezone-make-sortable-date (aref date 0)
 832                                             (aref date 1)
 833                                             (aref date 2)
 834                                             (timezone-make-time-string
 835                                              (aref date 3)
 836                                              (aref date 4)
 837                                              (aref date 5)))))))
 838      ((string= (elmo-filter-key condition) "body")
 839       (and (re-search-forward "^$" nil t)          ; goto body
 840            (setq result (search-forward (elmo-filter-value condition)
 841                                         nil t))))
 842      (t
 843       (let ((fval (std11-field-body (elmo-filter-key condition))))
 844         (if (eq (length fval) 0) (setq fval nil))
 845         (if fval (setq fval (eword-decode-string fval)))
 846         (setq result (and fval (string-match
 847                                 (elmo-filter-value condition) fval))))))
 848     (if (eq (elmo-filter-type condition) 'unmatch)
 849         (setq result (not result)))
 850     result))
 851
 852 (defun elmo-condition-find-key-internal (condition key)
 853   (cond
 854    ((vectorp condition)
 855     (if (string= (elmo-filter-key condition) key)
 856         (throw 'found t)))
 857    ((or (eq (car condition) 'and)
 858         (eq (car condition) 'or))
 859     (elmo-condition-find-key-internal (nth 1 condition) key)
 860     (elmo-condition-find-key-internal (nth 2 condition) key))))
 861
 862 (defun elmo-condition-find-key (condition key)
 863   (catch 'found
 864     (elmo-condition-find-key-internal condition key)))
 865
 866 (defun elmo-buffer-field-condition-match (condition number number-list)
 867   (cond
 868    ((vectorp condition)
 869     (elmo-buffer-field-primitive-condition-match
 870      condition number number-list))
 871    ((eq (car condition) 'and)
 872     (and (elmo-buffer-field-condition-match
 873           (nth 1 condition) number number-list)
 874          (elmo-buffer-field-condition-match
 875           (nth 2 condition) number number-list)))
 876    ((eq (car condition) 'or)
 877     (or (elmo-buffer-field-condition-match
 878          (nth 1 condition) number number-list)
 879         (elmo-buffer-field-condition-match
 880          (nth 2 condition) number number-list)))))
 881
 882 (defsubst elmo-file-field-condition-match (file condition number number-list)
 883   (elmo-set-work-buf
 884    (as-binary-input-file (insert-file-contents file))
 885    (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 886    ;; Should consider charset?
 887    (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
 888    (elmo-buffer-field-condition-match condition number number-list)))
 889
 890 (defmacro elmo-get-hash-val (string hashtable)
 891   (let ((sym (list 'intern-soft string hashtable)))
 892     (list 'if (list 'boundp sym)
 893        (list 'symbol-value sym))))
 894
 895 (defmacro elmo-set-hash-val (string value hashtable)
 896   (list 'set (list 'intern string hashtable) value))
 897
 898 (defmacro elmo-clear-hash-val (string hashtable)
 899   (static-if (fboundp 'unintern)
 900       (list 'unintern string hashtable)
 901     (list 'makunbound (list 'intern string hashtable))))
 902
 903 (defmacro elmo-unintern (string)
 904   "`unintern' symbol named STRING,  When can use `unintern'.
 905 Emacs 19.28 or earlier does not have `unintern'."
 906   (static-if (fboundp 'unintern)
 907       (list 'unintern string)))
 908
 909 (defun elmo-make-hash (&optional hashsize)
 910   "Make a new hash table which have HASHSIZE size."
 911   (make-vector
 912    (if hashsize
 913        (max
 914         ;; Prime numbers as lengths tend to result in good
 915         ;; hashing; lengths one less than a power of two are
 916         ;; also good.
 917         (min
 918          (let ((i 1))
 919            (while (< (- i 1) hashsize)
 920              (setq i (* 2 i)))
 921            (- i 1))
 922          elmo-hash-maximum-size)
 923         elmo-hash-minimum-size)
 924      elmo-hash-minimum-size)
 925    0))
 926
 927 (defsubst elmo-mime-string (string)
 928   "Normalize MIME encoded STRING."
 929     (and string
 930          (let (str)
 931            (elmo-set-work-buf
 932             (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 933             (setq str (eword-decode-string
 934                        (decode-mime-charset-string string elmo-mime-charset)))
 935             (setq str (encode-mime-charset-string str elmo-mime-charset))
 936             (elmo-set-buffer-multibyte nil)
 937             str))))
 938
 939 (defsubst elmo-collect-field (beg end downcase-field-name)
 940   (save-excursion
 941     (save-restriction
 942       (narrow-to-region beg end)
 943       (goto-char (point-min))
 944       (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
 945             dest name body)
 946         (while (re-search-forward regexp nil t)
 947           (setq name (buffer-substring-no-properties
 948                       (match-beginning 1)(1- (match-end 1))))
 949           (if downcase-field-name
 950               (setq name (downcase name)))
 951           (setq body (buffer-substring-no-properties
 952                       (match-end 0) (std11-field-end)))
 953           (or (assoc name dest)
 954               (setq dest (cons (cons name body) dest))))
 955         dest))))
 956
 957 (defsubst elmo-collect-field-from-string (string downcase-field-name)
 958   (with-temp-buffer
 959     (insert string)
 960     (goto-char (point-min))
 961     (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
 962           dest name body)
 963       (while (re-search-forward regexp nil t)
 964         (setq name (buffer-substring-no-properties
 965                     (match-beginning 1)(1- (match-end 1))))
 966         (if downcase-field-name
 967             (setq name (downcase name)))
 968         (setq body (buffer-substring-no-properties
 969                     (match-end 0) (std11-field-end)))
 970         (or (assoc name dest)
 971             (setq dest (cons (cons name body) dest))))
 972       dest)))
 973
 974 (defun elmo-safe-filename (folder)
 975   (elmo-replace-in-string
 976    (elmo-replace-in-string
 977     (elmo-replace-in-string folder "/" " ")
 978     ":" "__")
 979    "|" "_or_"))
 980
 981 (defvar elmo-filename-replace-chars nil)
 982
 983 (defsubst elmo-replace-string-as-filename (msgid)
 984   "Replace string as filename."
 985   (setq msgid (elmo-replace-in-string msgid " " "  "))
 986   (if (null elmo-filename-replace-chars)
 987       (setq elmo-filename-replace-chars
 988             (regexp-quote (mapconcat
 989                            'car elmo-filename-replace-string-alist ""))))
 990   (while (string-match (concat "[" elmo-filename-replace-chars "]")
 991                        msgid)
 992     (setq msgid (concat
 993                  (substring msgid 0 (match-beginning 0))
 994                  (cdr (assoc
 995                        (substring msgid
 996                                   (match-beginning 0) (match-end 0))
 997                        elmo-filename-replace-string-alist))
 998                  (substring msgid (match-end 0)))))
 999   msgid)
1000
1001 (defsubst elmo-recover-string-from-filename (filename)
1002   "Recover string from FILENAME."
1003   (let (tmp result)
1004     (while (string-match " " filename)
1005       (setq tmp (substring filename
1006                            (match-beginning 0)
1007                            (+ (match-end 0) 1)))
1008       (if (string= tmp "  ")
1009           (setq tmp " ")
1010         (setq tmp (car (rassoc tmp
1011                                elmo-filename-replace-string-alist))))
1012       (setq result
1013             (concat result
1014                     (substring filename 0 (match-beginning 0))
1015                     tmp))
1016       (setq filename (substring filename (+ (match-end 0) 1))))
1017     (concat result filename)))
1018
1019 (defsubst elmo-copy-file (src dst)
1020   (condition-case err
1021       (elmo-add-name-to-file src dst t)
1022     (error (copy-file src dst t))))
1023
1024 (defsubst elmo-buffer-exists-p (buffer)
1025   (if (bufferp buffer)
1026       (buffer-live-p buffer)
1027     (get-buffer buffer)))
1028
1029 (defsubst elmo-kill-buffer (buffer)
1030   (when (elmo-buffer-exists-p buffer)
1031     (kill-buffer buffer)))
1032
1033 (defun elmo-delete-if (pred lst)
1034   "Return new list contain items which don't satisfy PRED in LST."
1035   (let (result)
1036     (while lst
1037       (unless (funcall pred (car lst))
1038         (setq result (nconc result (list (car lst)))))
1039       (setq lst (cdr lst)))
1040     result))
1041
1042 (defun elmo-list-delete (list1 list2)
1043   "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1044 Return the modified LIST2.  Deletion is done with `delete'.
1045 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1046 the value of `foo'."
1047   (while list1
1048     (setq list2 (delete (car list1) list2))
1049     (setq list1 (cdr list1)))
1050   list2)
1051
1052 (defun elmo-list-member (list1 list2)
1053   "If any element of LIST1 is member of LIST2, return t."
1054   (catch 'done
1055     (while list1
1056       (if (member (car list1) list2)
1057           (throw 'done t))
1058       (setq list1 (cdr list1)))))
1059
1060 (defun elmo-count-matches (regexp beg end)
1061   (let ((count 0))
1062     (save-excursion
1063       (goto-char beg)
1064       (while (re-search-forward regexp end t)
1065         (setq count (1+ count)))
1066       count)))
1067
1068 (if (fboundp 'display-error)
1069     (defalias 'elmo-display-error 'display-error)
1070   (defun elmo-display-error (error-object stream)
1071     "A tiny function to display ERROR-OBJECT to the STREAM."
1072     (let ((first t)
1073           (errobj error-object)
1074           err-mes)
1075       (while errobj
1076         (setq err-mes (concat err-mes (format
1077                                        (if (stringp (car errobj))
1078                                            "%s"
1079                                          (if (boundp 'nemacs-version)
1080                                              "%s"
1081                                            "%S")) (car errobj))))
1082         (setq errobj (cdr errobj))
1083         (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1084         (setq first nil))
1085       (princ err-mes stream))))
1086
1087 (if (fboundp 'define-error)
1088     (defalias 'elmo-define-error 'define-error)
1089   (defun elmo-define-error (error doc &optional parents)
1090     (or parents
1091         (setq parents 'error))
1092     (let ((conds (get parents 'error-conditions)))
1093       (or conds
1094           (error "Not an error symbol: %s" error))
1095       (setplist error
1096                 (list 'error-message doc
1097                       'error-conditions (cons error conds))))))
1098
1099 (cond ((fboundp 'lprogress-display)
1100        (defalias 'elmo-display-progress 'lprogress-display))
1101       ((fboundp 'progress-feedback-with-label)
1102        (defalias 'elmo-display-progress 'progress-feedback-with-label))
1103       (t
1104        (defun elmo-display-progress (label format &optional value &rest args)
1105          "Print a progress message."
1106          (if (and (null format) (null args))
1107              (message nil)
1108            (apply (function message) (concat format " %d%%")
1109                   (nconc args (list value)))))))
1110
1111 (defun elmo-time-expire (before-time diff-time)
1112   (let* ((current (current-time))
1113          (rest (when (< (nth 1 current) (nth 1 before-time))
1114                  (expt 2 16)))
1115          diff)
1116     (setq diff
1117           (list (- (+ (car current) (if rest -1 0)) (car before-time))
1118                 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1119     (and (eq (car diff) 0)
1120          (< diff-time (nth 1 diff)))))
1121
1122 (if (fboundp 'std11-fetch-field)
1123     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1124   (defalias 'elmo-field-body 'std11-field-body))
1125
1126 (defmacro elmo-string (string)
1127   "STRING without text property."
1128   (` (let ((obj (copy-sequence (, string))))
1129        (set-text-properties 0 (length obj) nil obj)
1130        obj)))
1131
1132 (defun elmo-flatten (list-of-list)
1133   "Flatten LIST-OF-LIST."
1134   (unless (null list-of-list)
1135     (append (if (and (car list-of-list)
1136                      (listp (car list-of-list)))
1137                 (car list-of-list)
1138               (list (car list-of-list)))
1139             (elmo-flatten (cdr list-of-list)))))
1140
1141 (defun elmo-y-or-n-p (prompt &optional auto default)
1142   "Same as `y-or-n-p'.
1143 But if optional argument AUTO is non-nil, DEFAULT is returned."
1144   (if auto
1145       default
1146     (y-or-n-p prompt)))
1147
1148 (defun elmo-string-member (string slist)
1149   "Return t if STRING is a member of the SLIST."
1150   (catch 'found
1151     (while slist
1152       (if (and (stringp (car slist))
1153                (string= string (car slist)))
1154           (throw 'found t))
1155       (setq slist (cdr slist)))))
1156
1157 (defun elmo-string-match-member (str list &optional case-ignore)
1158   (let ((case-fold-search case-ignore))
1159     (catch 'member
1160       (while list
1161         (if (string-match (car list) str)
1162             (throw 'member (car list)))
1163         (setq list (cdr list))))))
1164
1165 (defun elmo-string-matched-member (str list &optional case-ignore)
1166   (let ((case-fold-search case-ignore))
1167     (catch 'member
1168       (while list
1169         (if (string-match str (car list))
1170             (throw 'member (car list)))
1171         (setq list (cdr list))))))
1172
1173 (defsubst elmo-string-delete-match (string pos)
1174   (concat (substring string
1175                      0 (match-beginning pos))
1176           (substring string
1177                      (match-end pos)
1178                      (length string))))
1179
1180 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1181   (let ((case-fold-search case-ignore)
1182         a)
1183     (catch 'loop
1184       (while alist
1185         (setq a (car alist))
1186         (if (and (consp a)
1187                  (stringp (car a))
1188                  (string-match key (car a)))
1189             (throw 'loop a))
1190         (setq alist (cdr alist))))))
1191
1192 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1193   (let ((case-fold-search case-ignore)
1194         a)
1195     (catch 'loop
1196       (while alist
1197         (setq a (car alist))
1198         (if (and (consp a)
1199                  (stringp (car a))
1200                  (string-match (car a) key))
1201             (throw 'loop a))
1202         (setq alist (cdr alist))))))
1203
1204 (defun elmo-string-assoc (key alist)
1205   (let (a)
1206     (catch 'loop
1207       (while alist
1208         (setq a (car alist))
1209         (if (and (consp a)
1210                  (stringp (car a))
1211                  (string= key (car a)))
1212             (throw 'loop a))
1213         (setq alist (cdr alist))))))
1214
1215 (defun elmo-string-rassoc (key alist)
1216   (let (a)
1217     (catch 'loop
1218       (while alist
1219         (setq a (car alist))
1220         (if (and (consp a)
1221                  (stringp (cdr a))
1222                  (string= key (cdr a)))
1223             (throw 'loop a))
1224         (setq alist (cdr alist))))))
1225
1226 (defun elmo-string-rassoc-all (key alist)
1227   (let (matches)
1228     (while alist
1229       (if (string= key (cdr (car alist)))
1230           (setq matches
1231                 (cons (car alist)
1232                       matches)))
1233       (setq alist (cdr alist)))
1234     matches))
1235
1236 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1237 ;;
1238 ;; number          ::= [0-9]+
1239 ;; beg             ::= number
1240 ;; end             ::= number
1241 ;; number-range    ::= "(" beg " . " end ")"      ;; cons cell
1242 ;; number-set-elem ::= number / number-range
1243 ;; number-set      ::= "(" *number-set-elem ")"   ;; list
1244
1245 (defun elmo-number-set-member (number number-set)
1246   "Return non-nil if NUMBER is an element of NUMBER-SET.
1247 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1248   (or (memq number number-set)
1249       (let (found)
1250         (while (and number-set (not found))
1251           (if (and (consp (car number-set))
1252                    (and (<= (car (car number-set)) number)
1253                         (<= number (cdr (car number-set)))))
1254               (setq found t)
1255             (setq number-set (cdr number-set))))
1256         number-set)))
1257
1258 (defun elmo-number-set-append-list (number-set list)
1259   "Append LIST of numbers to the NUMBER-SET.
1260 NUMBER-SET is altered."
1261   (let ((appended number-set))
1262     (while list
1263       (setq appended (elmo-number-set-append appended (car list)))
1264       (setq list (cdr list)))
1265     appended))
1266
1267 (defun elmo-number-set-append (number-set number)
1268   "Append NUMBER to the NUMBER-SET.
1269 NUMBER-SET is altered."
1270   (let ((number-set-1 number-set)
1271         found elem)
1272     (while (and number-set (not found))
1273       (setq elem (car number-set))
1274       (cond
1275        ((and (consp elem)
1276              (eq (+ 1 (cdr elem)) number))
1277         (setcdr elem number)
1278         (setq found t))
1279        ((and (integerp elem)
1280              (eq (+ 1 elem) number))
1281         (setcar number-set (cons elem number))
1282         (setq found t))
1283        ((or (and (integerp elem) (eq elem number))
1284             (and (consp elem)
1285                  (<= (car elem) number)
1286                  (<= number (cdr elem))))
1287         (setq found t)))
1288       (setq number-set (cdr number-set)))
1289     (if (not found)
1290         (setq number-set-1 (nconc number-set-1 (list number))))
1291     number-set-1))
1292
1293 (defun elmo-number-set-to-number-list (number-set)
1294   "Return a number list which corresponds to NUMBER-SET."
1295   (let (number-list elem i)
1296     (while number-set
1297       (setq elem (car number-set))
1298       (cond
1299        ((consp elem)
1300         (setq i (car elem))
1301         (while (<= i (cdr elem))
1302           (setq number-list (cons i number-list))
1303           (incf i)))
1304        ((integerp elem)
1305         (setq number-list (cons elem number-list))))
1306       (setq number-set (cdr number-set)))
1307     (nreverse number-list)))
1308
1309 (defcustom elmo-list-subdirectories-ignore-regexp "^\\(\\.\\.?\\|[0-9]+\\)$"
1310   "*Regexp to filter subfolders."
1311   :type 'regexp
1312   :group 'elmo)
1313
1314 (defun elmo-list-subdirectories (directory file one-level)
1315   (let ((root (zerop (length file)))
1316         (w32-get-true-file-link-count t) ; for Meadow
1317         files attr dirs dir)
1318     (setq files (directory-files (setq dir (expand-file-name file directory))))
1319     (while files
1320       (if (and (not (string-match elmo-list-subdirectories-ignore-regexp
1321                                   (car files)))
1322                (car (setq attr (file-attributes (expand-file-name
1323                                                  (car files) dir)))))
1324           (if (and (not one-level)
1325                    (and elmo-have-link-count (< 2 (nth 1 attr))))
1326               (setq dirs
1327                     (nconc dirs
1328                            (elmo-list-subdirectories
1329                             directory
1330                             (concat file
1331                                     (and (not root) elmo-path-sep)
1332                                     (car files))
1333                             one-level)))
1334             (setq dirs (nconc dirs
1335                               (list
1336                                (concat file
1337                                        (and (not root) elmo-path-sep)
1338                                        (car files)))))))
1339       (setq files (cdr files)))
1340     (nconc (and (not root) (list file)) dirs)))
1341
1342 (defun elmo-parse (string regexp &optional matchn)
1343   (or matchn (setq matchn 1))
1344   (let (list)
1345     (store-match-data nil)
1346     (while (string-match regexp string (match-end 0))
1347       (setq list (cons (substring string (match-beginning matchn)
1348                                   (match-end matchn)) list)))
1349     (nreverse list)))
1350
1351 (require 'product)
1352 (product-provide (provide 'elmo-util) (require 'elmo-version))
1353
1354 ;;; elmo-util.el ends here