wl/wl-util.el

   1 ;;; wl-util.el -- Utility modules for Wanderlust.
   2
   3 ;; Copyright 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 Wanderlust (Yet Another Message Interface on Emacsen).
   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 (require 'product)
  33 (product-provide (provide 'wl-util) (require 'wl-version))
  34 (eval-when-compile
  35   (require 'elmo-util))
  36
  37 (condition-case nil (require 'tm-edit) (error nil))
  38 (condition-case nil (require 'pp) (error nil))
  39
  40 (eval-when-compile
  41   (require 'time-stamp)
  42   (defalias-maybe 'read-event 'ignore)
  43   (defalias-maybe 'next-command-event 'ignore)
  44   (defalias-maybe 'event-to-character 'ignore)
  45   (defalias-maybe 'key-press-event-p 'ignore)
  46   (defalias-maybe 'button-press-event-p 'ignore)
  47   (defalias-maybe 'set-process-kanji-code 'ignore)
  48   (defalias-maybe 'set-process-coding-system 'ignore)
  49   (defalias-maybe 'dispatch-event 'ignore))
  50
  51 (defalias 'wl-set-work-buf 'elmo-set-work-buf)
  52 (make-obsolete 'wl-set-work-buf 'elmo-set-work-buf)
  53
  54 (defmacro wl-append (val func)
  55   (list 'if val
  56       (list 'nconc val func)
  57     (list 'setq val func)))
  58
  59 (defun wl-parse (string regexp &optional matchn)
  60   (or matchn (setq matchn 1))
  61   (let (list)
  62     (store-match-data nil)
  63     (while (string-match regexp string (match-end 0))
  64       (setq list (cons (substring string (match-beginning matchn)
  65                                   (match-end matchn)) list)))
  66     (nreverse list)))
  67
  68 (defun wl-delete-duplicates (list &optional all hack-addresses)
  69   "Delete duplicate equivalent strings from the list.
  70 If ALL is t, then if there is more than one occurrence of a string in the list,
  71  then all occurrences of it are removed instead of just the subsequent ones.
  72 If HACK-ADDRESSES is t, then the strings are considered to be mail addresses,
  73  and only the address part is compared (so that \"Name <foo>\" and \"foo\"
  74  would be considered to be equivalent.)"
  75   (let ((hashtable (make-vector 29 0))
  76         (new-list nil)
  77         sym-string sym)
  78     (fillarray hashtable 0)
  79     (while list
  80       (setq sym-string
  81             (if hack-addresses
  82                 (wl-address-header-extract-address (car list))
  83               (car list))
  84             sym-string (or sym-string "-unparseable-garbage-")
  85             sym (intern sym-string hashtable))
  86       (if (boundp sym)
  87           (and all (setcar (symbol-value sym) nil))
  88         (setq new-list (cons (car list) new-list))
  89         (set sym new-list))
  90       (setq list (cdr list)))
  91     (delq nil (nreverse new-list))))
  92
  93 ;; string utils.
  94 (defalias 'wl-string-member 'elmo-string-member)
  95 (defalias 'wl-string-match-member 'elmo-string-match-member)
  96 (defalias 'wl-string-delete-match 'elmo-string-delete-match)
  97 (defalias 'wl-string-match-assoc 'elmo-string-match-assoc)
  98 (defalias 'wl-string-assoc 'elmo-string-assoc)
  99 (defalias 'wl-string-rassoc 'elmo-string-rassoc)
 100
 101 (defun wl-parse-addresses (string)
 102   (if (null string)
 103       ()
 104     (elmo-set-work-buf
 105      ;;(unwind-protect
 106      (let (list start s char)
 107        (insert string)
 108        (goto-char (point-min))
 109        (skip-chars-forward "\t\f\n\r ")
 110        (setq start (point))
 111        (while (not (eobp))
 112          (skip-chars-forward "^\"\\,(")
 113          (setq char (following-char))
 114          (cond ((= char ?\\)
 115                 (forward-char 1)
 116                 (if (not (eobp))
 117                     (forward-char 1)))
 118                ((= char ?,)
 119                 (setq s (buffer-substring start (point)))
 120                 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
 121                         (not (string= s "")))
 122                     (setq list (cons s list)))
 123                 (skip-chars-forward ",\t\f\n\r ")
 124                 (setq start (point)))
 125                ((= char ?\")
 126                 (re-search-forward "[^\\]\"" nil 0))
 127                ((= char ?\()
 128                 (let ((parens 1))
 129                   (forward-char 1)
 130                   (while (and (not (eobp)) (not (zerop parens)))
 131                     (re-search-forward "[()]" nil 0)
 132                     (cond ((or (eobp)
 133                                (= (char-after (- (point) 2)) ?\\)))
 134                           ((= (preceding-char) ?\()
 135                            (setq parens (1+ parens)))
 136                           (t
 137                            (setq parens (1- parens)))))))))
 138        (setq s (buffer-substring start (point)))
 139        (if (and (null (string-match "^[\t\f\n\r ]+$" s))
 140                 (not (string= s "")))
 141            (setq list (cons s list)))
 142        (nreverse list)) ; jwz: fixed order
 143      )))
 144
 145 (defun wl-append-element (list element)
 146   (if element
 147       (append list (list element))
 148     list))
 149
 150 (defun wl-read-event-char ()
 151   "Get the next event."
 152   (let ((event (read-event)))
 153     ;; should be gnus-characterp, but this can't be called in XEmacs anyway
 154     (cons (and (numberp event) event) event)))
 155
 156 (defun wl-xmas-read-event-char ()
 157   "Get the next event."
 158   (let ((event (next-command-event)))
 159     (sit-for 0)
 160     ;; We junk all non-key events.  Is this naughty?
 161     (while (not (or (key-press-event-p event)
 162                     (button-press-event-p event)))
 163       (dispatch-event event)
 164       (setq event (next-command-event)))
 165     (cons (and (key-press-event-p event)
 166                (event-to-character event))
 167           event)))
 168
 169 (if wl-on-xemacs
 170     (fset 'wl-read-event-char 'wl-xmas-read-event-char))
 171
 172 (defmacro wl-push (v l)
 173   (list 'setq l (list 'cons v l)))
 174
 175 (defmacro wl-pop (l)
 176   (list 'car (list 'prog1 l (list 'setq l (list 'cdr l)))))
 177
 178 (defun wl-ask-folder (func mes-string)
 179   (let* (key keve
 180              (cmd (if (featurep 'xemacs)
 181                       (event-to-character last-command-event)
 182                     (string-to-char (format "%s" (this-command-keys))))))
 183     (message mes-string)
 184     (setq key (car (setq keve (wl-read-event-char))))
 185     (if (or (equal key ?\ )
 186             (and cmd
 187                  (equal key cmd)))
 188         (progn
 189           (message "")
 190           (funcall func))
 191       (wl-push (cdr keve) unread-command-events))))
 192
 193 ;(defalias 'wl-make-hash 'elmo-make-hash)
 194 ;(make-obsolete 'wl-make-hash 'elmo-make-hash)
 195
 196 ;(defalias 'wl-get-hash-val 'elmo-get-hash-val)
 197 ;(make-obsolete 'wl-get-hash-val 'elmo-get-hash-val)
 198
 199 ;(defalias 'wl-set-hash-val 'elmo-set-hash-val)
 200 ;(make-obsolete 'wl-set-hash-val 'elmo-set-hash-val)
 201
 202 (defsubst wl-set-string-width (width string)
 203   (elmo-set-work-buf
 204    (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 205    (insert string)
 206    (if (> (current-column) width)
 207        (if (> (move-to-column width) width)
 208            (progn
 209              (condition-case nil ; ignore error
 210                  (backward-char 1)
 211                (error))
 212              (concat (buffer-substring (point-min) (point)) " "))
 213          (buffer-substring (point-min) (point)))
 214      (if (= (current-column) width)
 215          string
 216        (concat string
 217                (format (format "%%%ds"
 218                                (- width (current-column)))
 219                        " "))))))
 220
 221 (defun wl-display-bytes (num)
 222   (let (result remain)
 223     (cond
 224      ((> (setq result (/ num 1000000)) 0)
 225       (setq remain (% num 1000000))
 226       (if (> remain 400000)
 227           (setq result (+ 1 result)))
 228       (format "%dM" result))
 229      ((> (setq result (/ num 1000)) 0)
 230       (setq remain (% num 1000))
 231       (if (> remain 400)
 232           (setq result (+ 1 result)))
 233       (format "%dK" result))
 234      (t (format "%dB" result)))))
 235
 236 (defun wl-mode-line-buffer-identification (&optional id)
 237   (let ((priorities '(biff plug title)))
 238     (let ((items (reverse wl-mode-line-display-priority-list))
 239           item)
 240       (while items
 241         (setq item (car items)
 242               items (cdr items))
 243         (unless (memq item '(biff plug))
 244           (setq item 'title))
 245         (setq priorities (cons item (delq item priorities)))))
 246     (let (priority result)
 247       (while priorities
 248         (setq priority (car priorities)
 249               priorities (cdr priorities))
 250         (cond
 251          ((eq 'biff priority)
 252           (when wl-biff-check-folder-list
 253             (setq result (append result '((wl-modeline-biff-status
 254                                            wl-modeline-biff-state-on
 255                                            wl-modeline-biff-state-off))))))
 256          ((eq 'plug priority)
 257           (when wl-show-plug-status-on-modeline
 258             (setq result (append result '((wl-modeline-plug-status
 259                                            wl-modeline-plug-state-on
 260                                            wl-modeline-plug-state-off))))))
 261          (t
 262           (setq result (append result (or id '("Wanderlust: %12b")))))))
 263       (prog1
 264           (setq mode-line-buffer-identification (if (stringp (car result))
 265                                                     result
 266                                                   (cons "" result)))
 267         (force-mode-line-update t)))))
 268
 269 (defalias 'wl-display-error 'elmo-display-error)
 270 (make-obsolete 'wl-display-error 'elmo-display-error)
 271
 272 (defun wl-get-assoc-list-value (assoc-list folder &optional match)
 273   (catch 'found
 274     (let ((alist assoc-list)
 275           value pair)
 276       (while alist
 277         (setq pair (car alist))
 278         (if (string-match (car pair) folder)
 279             (cond ((eq match 'all)
 280                    (setq value (append value (list (cdr pair)))))
 281                   ((eq match 'all-list)
 282                    (setq value (append value (cdr pair))))
 283                   ((not match)
 284                    (throw 'found (cdr pair)))))
 285         (setq alist (cdr alist)))
 286       value)))
 287
 288 (defmacro wl-match-string (pos string)
 289   "Substring POSth matched string."
 290   (` (substring (, string) (match-beginning (, pos)) (match-end (, pos)))))
 291
 292 (defmacro wl-match-buffer (pos)
 293   "Substring POSth matched from the current buffer."
 294   (` (buffer-substring-no-properties
 295       (match-beginning (, pos)) (match-end (, pos)))))
 296
 297 (put 'wl-as-coding-system 'lisp-indent-function 1)
 298 (put 'wl-as-mime-charset 'lisp-indent-function 1)
 299
 300 (eval-and-compile
 301   (if wl-on-mule3
 302       (defmacro wl-as-coding-system (coding-system &rest body)
 303         (` (let ((coding-system-for-read (, coding-system))
 304                  (coding-system-for-write (, coding-system)))
 305              (,@ body))))
 306     (if wl-on-mule
 307         (defmacro wl-as-coding-system (coding-system &rest body)
 308           (` (let ((file-coding-system-for-read (, coding-system))
 309                    (file-coding-system (, coding-system)))
 310                (,@ body))))
 311       (if wl-on-nemacs
 312           (defmacro wl-as-coding-system (coding-system &rest body)
 313             (` (let ((default-kanji-fileio-code (, coding-system))
 314                      (kanji-fileio-code (, coding-system))
 315                      kanji-expected-code)
 316                  (,@ body))))))))
 317
 318 (defmacro wl-as-mime-charset (mime-charset &rest body)
 319   (` (wl-as-coding-system (mime-charset-to-coding-system (, mime-charset))
 320        (,@ body))))
 321
 322 (defalias 'wl-string 'elmo-string)
 323 (make-obsolete 'wl-string 'elmo-string)
 324
 325 (defun wl-parse-newsgroups (string &optional subscribe-only)
 326   (let* ((nglist (wl-parse string "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)"))
 327          ret-val)
 328     (if (not subscribe-only)
 329         nglist
 330       (while nglist
 331         (if (intern-soft (car nglist) wl-folder-newsgroups-hashtb)
 332             (wl-append ret-val (list (car nglist))))
 333         (setq nglist (cdr nglist)))
 334       ret-val)))
 335
 336 ;; Check if active region exists or not.
 337 (if (boundp 'mark-active)
 338     (defmacro wl-region-exists-p ()
 339       'mark-active)
 340   (if (fboundp 'region-exists-p)
 341       (defmacro wl-region-exists-p ()
 342         (list 'region-exists-p))))
 343
 344 (if (not (fboundp 'overlays-in))
 345     (defun overlays-in (beg end)
 346       "Return a list of the overlays that overlap the region BEG ... END.
 347 Overlap means that at least one character is contained within the overlay
 348 and also contained within the specified region.
 349 Empty overlays are included in the result if they are located at BEG
 350 or between BEG and END."
 351       (let ((ovls (overlay-lists))
 352             tmp retval)
 353         (if (< end beg)
 354             (setq tmp end
 355                   end beg
 356                   beg tmp))
 357         (setq ovls (nconc (car ovls) (cdr ovls)))
 358         (while ovls
 359           (setq tmp (car ovls)
 360                 ovls (cdr ovls))
 361           (if (or (and (<= (overlay-start tmp) end)
 362                        (>= (overlay-start tmp) beg))
 363                   (and (<= (overlay-end tmp) end)
 364                        (>= (overlay-end tmp) beg)))
 365               (setq retval (cons tmp retval))))
 366         retval)))
 367
 368 (defsubst wl-repeat-string (str times)
 369   (let ((loop times)
 370         ret-val)
 371     (while (> loop 0)
 372       (setq ret-val (concat ret-val str))
 373       (setq loop (- loop 1)))
 374     ret-val))
 375
 376 (defun wl-list-diff (list1 list2)
 377   "Return a list of elements of LIST1 that do not appear in LIST2."
 378   (let ((list1 (copy-sequence list1)))
 379     (while list2
 380       (setq list1 (delq (car list2) list1))
 381       (setq list2 (cdr list2)))
 382     list1))
 383
 384 (defun wl-append-assoc-list (item value alist)
 385   "make assoc list '((item1 value1-1 value1-2 ...)) (item2 value2-1 ...)))"
 386   (let ((entry (assoc item alist)))
 387     (if entry
 388         (progn
 389           (when (not (member value (cdr entry)))
 390             (nconc entry (list value)))
 391           alist)
 392       (append alist
 393               (list (list item value))))))
 394
 395 (defun wl-delete-alist (key alist)
 396   "Delete by side effect any entries specified with KEY from ALIST.
 397 Return the modified ALIST.  Key comparison is done with `assq'.
 398 Write `(setq foo (wl-delete-alist key foo))' to be sure of changing
 399 the value of `foo'."
 400   (let (entry)
 401     (while (setq entry (assq key alist))
 402       (setq alist (delq entry alist)))
 403     alist))
 404
 405 (defun wl-delete-associations (keys alist)
 406   "Delete by side effect any entries specified with KEYS from ALIST.
 407 Return the modified ALIST.  KEYS must be a list of keys for ALIST.
 408 Deletion is done with `wl-delete-alist'.
 409 Write `(setq foo (wl-delete-associations keys foo))' to be sure of
 410 changing the value of `foo'."
 411   (while keys
 412     (setq alist (wl-delete-alist (car keys) alist))
 413     (setq keys (cdr keys)))
 414   alist)
 415
 416 (defun wl-inverse-alist (keys alist)
 417   "Inverse ALIST, copying.  Return an association list represents
 418 the inverse mapping of ALIST, from objects to KEYS.
 419 The objects mapped (cdrs of elements of the ALIST) are shared."
 420   (let (x y tmp result)
 421     (while keys
 422       (setq x (car keys))
 423       (setq y (cdr (assq x alist)))
 424       (if y
 425           (if (setq tmp (assoc y result))
 426               (setq result (cons (append tmp (list x))
 427                                  (delete tmp result)))
 428             (setq result (cons (list y x) result))))
 429       (setq keys (cdr keys)))
 430     result))
 431
 432 (eval-when-compile
 433   (require 'static))
 434 (static-unless (fboundp 'pp)
 435   (defvar pp-escape-newlines t)
 436   (defun pp (object &optional stream)
 437     "Output the pretty-printed representation of OBJECT, any Lisp object.
 438 Quoting characters are printed when needed to make output that `read'
 439 can handle, whenever this is possible.
 440 Output stream is STREAM, or value of `standard-output' (which see)."
 441     (princ (pp-to-string object) (or stream standard-output)))
 442
 443   (defun pp-to-string (object)
 444     "Return a string containing the pretty-printed representation of OBJECT,
 445 any Lisp object.  Quoting characters are used when needed to make output
 446 that `read' can handle, whenever this is possible."
 447     (save-excursion
 448       (set-buffer (generate-new-buffer " pp-to-string"))
 449       (unwind-protect
 450           (progn
 451             (lisp-mode-variables t)
 452             (let ((print-escape-newlines pp-escape-newlines))
 453               (prin1 object (current-buffer)))
 454             (goto-char (point-min))
 455             (while (not (eobp))
 456               (cond
 457                ((looking-at "\\s(\\|#\\s(")
 458                 (while (looking-at "\\s(\\|#\\s(")
 459                   (forward-char 1)))
 460                ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)")
 461                      (> (match-beginning 1) 1)
 462                      (= ?\( (char-after (1- (match-beginning 1))))
 463                      ;; Make sure this is a two-element list.
 464                      (save-excursion
 465                        (goto-char (match-beginning 2))
 466                        (forward-sexp)
 467                        ;; Avoid mucking with match-data; does this test work?
 468                        (char-equal ?\) (char-after (point)))))
 469                 ;; -1 gets the paren preceding the quote as well.
 470                 (delete-region (1- (match-beginning 1)) (match-end 1))
 471                 (insert "'")
 472                 (forward-sexp 1)
 473                 (if (looking-at "[ \t]*\)")
 474                     (delete-region (match-beginning 0) (match-end 0))
 475                   (error "Malformed quote"))
 476                 (backward-sexp 1))
 477                ((condition-case err-var
 478                     (prog1 t (down-list 1))
 479                   (error nil))
 480                 (backward-char 1)
 481                 (skip-chars-backward " \t")
 482                 (delete-region
 483                  (point)
 484                  (progn (skip-chars-forward " \t") (point)))
 485                 (if (not (char-equal ?' (char-after (1- (point)))))
 486                     (insert ?\n)))
 487                ((condition-case err-var
 488                     (prog1 t (up-list 1))
 489                   (error nil))
 490                 (while (looking-at "\\s)")
 491                   (forward-char 1))
 492                 (skip-chars-backward " \t")
 493                 (delete-region
 494                  (point)
 495                  (progn (skip-chars-forward " \t") (point)))
 496                 (if (not (char-equal ?' (char-after (1- (point)))))
 497                     (insert ?\n)))
 498                (t (goto-char (point-max)))))
 499             (goto-char (point-min))
 500             (indent-sexp)
 501             (buffer-string))
 502         (kill-buffer (current-buffer))))))
 503
 504 (defsubst wl-get-date-iso8601 (date)
 505   (or (get-text-property 0 'wl-date date)
 506       (let* ((d1 (timezone-fix-time date nil nil))
 507              (time (format "%04d%02d%02dT%02d%02d%02d"
 508                            (aref d1 0) (aref d1 1) (aref d1 2)
 509                            (aref d1 3) (aref d1 4) (aref d1 5))))
 510         (put-text-property 0 1 'wl-date time date)
 511         time)))
 512
 513 (defun wl-make-date-string ()
 514   (let ((s (current-time-string)))
 515     (string-match "\\`\\([A-Z][a-z][a-z]\\) +[A-Z][a-z][a-z] +[0-9][0-9]? *[0-9][0-9]?:[0-9][0-9]:[0-9][0-9] *[0-9]?[0-9]?[0-9][0-9]"
 516                   s)
 517     (concat (wl-match-string 1 s) ", "
 518             (timezone-make-date-arpa-standard s (current-time-zone)))))
 519
 520 (defun wl-date-iso8601 (date)
 521   "Convert the DATE to YYMMDDTHHMMSS."
 522   (condition-case ()
 523       (wl-get-date-iso8601 date)
 524     (error "")))
 525
 526 (defun wl-day-number (date)
 527   (let ((dat (mapcar '(lambda (s) (and s (string-to-int s)) )
 528                      (timezone-parse-date date))))
 529     (timezone-absolute-from-gregorian
 530      (nth 1 dat) (nth 2 dat) (car dat))))
 531
 532 (defun wl-url-news (url &rest args)
 533   (interactive "sURL: ")
 534   (if (string-match "^news:\\(.*\\)$" url)
 535       (wl-summary-goto-folder-subr
 536        (concat "-" (elmo-match-string 1 url)) nil nil nil t)
 537     (message "Not a news: url.")))
 538
 539 (defun wl-url-nntp (url &rest args)
 540   (interactive "sURL: ")
 541   (let (folder fld-name server port msg)
 542     (if (string-match
 543          "^nntp://\\([^:/]*\\):?\\([0-9]*\\)/\\([^/]*\\)/\\([0-9]*\\).*$" url)
 544         (progn
 545           (if (eq (length (setq fld-name
 546                                 (elmo-match-string 3 url))) 0)
 547               (setq fld-name nil))
 548           (if (eq (length (setq port
 549                                 (elmo-match-string 2 url))) 0)
 550               (setq port (int-to-string elmo-default-nntp-port)))
 551           (if (eq (length (setq server
 552                                 (elmo-match-string 1 url))) 0)
 553               (setq server elmo-default-nntp-server))
 554           (setq folder (concat "-" fld-name "@" server ":" port))
 555           (if (eq (length (setq msg
 556                                 (elmo-match-string 4 url))) 0)
 557               (wl-summary-goto-folder-subr
 558                folder nil nil nil t)
 559             (wl-summary-goto-folder-subr
 560              folder 'update nil nil t)
 561             (goto-char (point-min))
 562             (re-search-forward (concat "^ *" msg) nil t)
 563             (wl-summary-redisplay)))
 564       (message "Not a nntp: url."))))
 565
 566 (defmacro wl-concat-list (list separator)
 567   (` (mapconcat 'identity (delete "" (delq nil (, list))) (, separator))))
 568
 569 (defmacro wl-current-message-buffer ()
 570   (` (save-excursion
 571        (if (buffer-live-p wl-current-summary-buffer)
 572            (set-buffer wl-current-summary-buffer))
 573        wl-message-buf-name)))
 574
 575 (defmacro wl-kill-buffers (regexp)
 576   (` (mapcar (function
 577               (lambda (x)
 578                 (if (and (buffer-name x)
 579                          (string-match (, regexp) (buffer-name x)))
 580                     (and (get-buffer x)
 581                          (kill-buffer x)))))
 582              (buffer-list))))
 583
 584 (defun wl-sendlog-time ()
 585   (static-if (fboundp 'format-time-string)
 586       (format-time-string "%Y/%m/%d %T")
 587     (let ((date (current-time-string)))
 588       (format "%s/%02d/%02d %s"
 589               (substring date -4)
 590               (cdr (assoc (upcase (substring date 4 7))
 591                           timezone-months-assoc))
 592               (string-to-int (substring date 8 10))
 593               (substring date 11 19)))))
 594
 595 (defun wl-collect-summary ()
 596   (let (result)
 597     (mapcar
 598      (function (lambda (x)
 599                  (if (and (string-match "^Summary"
 600                                         (buffer-name x))
 601                           (save-excursion
 602                             (set-buffer x)
 603                             (equal major-mode 'wl-summary-mode)))
 604                      (setq result (nconc result (list x))))))
 605      (buffer-list))
 606     result))
 607
 608 (static-if (fboundp 'read-directory-name)
 609     (defalias 'wl-read-directory-name 'read-directory-name)
 610   (defun wl-read-directory-name (prompt dir)
 611     (let ((dir (read-file-name prompt dir)))
 612       (unless (file-directory-p dir)
 613         (error "%s is not directory" dir))
 614       dir)))
 615
 616 ;; local variable check.
 617 (static-if (fboundp 'local-variable-p)
 618     (defalias 'wl-local-variable-p 'local-variable-p)
 619   (defmacro wl-local-variable-p (symbol &optional buffer)
 620     (` (if (assq (, symbol) (buffer-local-variables (, buffer)))
 621            t))))
 622
 623 (defun wl-number-base36 (num len)
 624   (if (if (< len 0)
 625           (<= num 0)
 626         (= len 0))
 627       ""
 628     (concat (wl-number-base36 (/ num 36) (1- len))
 629             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
 630                                   (% num 36))))))
 631
 632 (defvar wl-unique-id-char nil)
 633
 634 (defun wl-unique-id ()
 635   ;; Don't use microseconds from (current-time), they may be unsupported.
 636   ;; Instead we use this randomly inited counter.
 637   (setq wl-unique-id-char
 638         (% (1+ (or wl-unique-id-char (logand (random t) (1- (lsh 1 20)))))
 639            ;; (current-time) returns 16-bit ints,
 640            ;; and 2^16*25 just fits into 4 digits i base 36.
 641            (* 25 25)))
 642   (let ((tm (static-if (fboundp 'current-time)
 643                 (current-time)
 644               (let* ((cts (split-string (current-time-string) "[ :]"))
 645                      (m (cdr (assoc (nth 1 cts)
 646                                     '(("Jan" . "01") ("Feb" . "02")
 647                                       ("Mar" . "03") ("Apr" . "04")
 648                                       ("May" . "05") ("Jun" . "06")
 649                                       ("Jul" . "07") ("Aug" . "08")
 650                                       ("Sep" . "09") ("Oct" . "10")
 651                                       ("Nov" . "11") ("Dec" . "12"))))))
 652                 (list (string-to-int (concat (nth 6 cts) m
 653                                              (substring (nth 2 cts) 0 1)))
 654                       (string-to-int (concat (substring (nth 2 cts) 1)
 655                                              (nth 4 cts) (nth 5 cts)
 656                                              (nth 6 cts))))))))
 657     (concat
 658      (if (memq system-type '(ms-dos emx vax-vms))
 659          (let ((user (downcase (user-login-name))))
 660            (while (string-match "[^a-z0-9_]" user)
 661              (aset user (match-beginning 0) ?_))
 662            user)
 663        (wl-number-base36 (user-uid) -1))
 664      (wl-number-base36 (+ (car   tm)
 665                           (lsh (% wl-unique-id-char 25) 16)) 4)
 666      (wl-number-base36 (+ (nth 1 tm)
 667                           (lsh (/ wl-unique-id-char 25) 16)) 4)
 668      ;; Append the name of the message interface, because while the
 669      ;; generated ID is unique to this newsreader, other newsreaders
 670      ;; might otherwise generate the same ID via another algorithm.
 671      ".wl")))
 672
 673 (defun wl-draft-make-message-id-string ()
 674   (concat "<" (wl-unique-id) "@"
 675           (or wl-message-id-domain
 676               (if wl-local-domain
 677                   (concat (system-name) "." wl-local-domain)
 678                 (system-name)))
 679           ">"))
 680
 681 ;;; Profile loading.
 682 (defvar wl-load-profile-func 'wl-local-load-profile)
 683 (defun wl-local-load-profile ()
 684   (message "Initializing ...")
 685   (load wl-init-file 'noerror 'nomessage))
 686
 687 (defun wl-load-profile ()
 688   (funcall wl-load-profile-func))
 689
 690 ;;;
 691
 692 (defmacro wl-count-lines ()
 693   (` (save-excursion
 694        (beginning-of-line)
 695        (count-lines 1 (point)))))
 696
 697 (defun wl-horizontal-recenter ()
 698   "Recenter the current buffer horizontally."
 699   (beginning-of-line)
 700   (re-search-forward "[[<]" (point-at-eol) t)
 701   (if (< (current-column) (/ (window-width) 2))
 702       (set-window-hscroll (get-buffer-window (current-buffer) t) 0)
 703     (let* ((orig (point))
 704            (end (window-end (get-buffer-window (current-buffer) t)))
 705            (max 0))
 706       (when end
 707         ;; Find the longest line currently displayed in the window.
 708         (goto-char (window-start))
 709         (while (and (not (eobp))
 710                     (< (point) end))
 711           (end-of-line)
 712           (setq max (max max (current-column)))
 713           (forward-line 1))
 714         (goto-char orig)
 715         ;; Scroll horizontally to center (sort of) the point.
 716         (if (> max (window-width))
 717             (set-window-hscroll
 718              (get-buffer-window (current-buffer) t)
 719              (min (- (current-column) (/ (window-width) 3))
 720                   (+ 2 (- max (window-width)))))
 721           (set-window-hscroll (get-buffer-window (current-buffer) t) 0))
 722         max))))
 723
 724 ;; Biff
 725 (static-cond
 726  (wl-on-xemacs
 727   (defvar wl-biff-timer-name "wl-biff")
 728
 729   (defun wl-biff-stop ()
 730     (when (get-itimer wl-biff-timer-name)
 731       (delete-itimer wl-biff-timer-name)))
 732
 733   (defun wl-biff-start ()
 734     (wl-biff-stop)
 735     (when wl-biff-check-folder-list
 736       (wl-biff-check-folders)
 737       (start-itimer wl-biff-timer-name 'wl-biff-check-folders
 738                     wl-biff-check-interval wl-biff-check-interval))))
 739
 740  ((condition-case nil (require 'timer) (error nil));; FSFmacs 19+
 741
 742   (defun wl-biff-stop ()
 743     (put 'wl-biff 'timer nil))
 744
 745   (defun wl-biff-start ()
 746     (require 'timer)
 747     (when wl-biff-check-folder-list
 748       (wl-biff-check-folders)
 749       (put 'wl-biff 'timer (run-at-time
 750                             (timer-next-integral-multiple-of-time
 751                              (current-time) wl-biff-check-interval)
 752                             wl-biff-check-interval
 753                             'wl-biff-event-handler))))
 754
 755   (defun-maybe timer-next-integral-multiple-of-time (time secs)
 756     "Yield the next value after TIME that is an integral multiple of SECS.
 757 More precisely, the next value, after TIME, that is an integral multiple
 758 of SECS seconds since the epoch.  SECS may be a fraction.
 759 This function is imported from Emacs 20.7."
 760     (let ((time-base (ash 1 16)))
 761       (if (fboundp 'atan)
 762           ;; Use floating point, taking care to not lose precision.
 763           (let* ((float-time-base (float time-base))
 764                  (million 1000000.0)
 765                  (time-usec (+ (* million
 766                                   (+ (* float-time-base (nth 0 time))
 767                                      (nth 1 time)))
 768                                (nth 2 time)))
 769                  (secs-usec (* million secs))
 770                  (mod-usec (mod time-usec secs-usec))
 771                  (next-usec (+ (- time-usec mod-usec) secs-usec))
 772                  (time-base-million (* float-time-base million)))
 773             (list (floor next-usec time-base-million)
 774                   (floor (mod next-usec time-base-million) million)
 775                   (floor (mod next-usec million))))
 776         ;; Floating point is not supported.
 777         ;; Use integer arithmetic, avoiding overflow if possible.
 778         (let* ((mod-sec (mod (+ (* (mod time-base secs)
 779                                    (mod (nth 0 time) secs))
 780                                 (nth 1 time))
 781                              secs))
 782                (next-1-sec (+ (- (nth 1 time) mod-sec) secs)))
 783           (list (+ (nth 0 time) (floor next-1-sec time-base))
 784                 (mod next-1-sec time-base)
 785                 0)))))
 786
 787   (defun wl-biff-event-handler ()
 788     ;; PAKURing from FSF:time.el
 789     (wl-biff-check-folders)
 790     ;; Do redisplay right now, if no input pending.
 791     (sit-for 0)
 792     (let* ((current (current-time))
 793            (timer (get 'wl-biff 'timer))
 794            ;; Compute the time when this timer will run again, next.
 795            (next-time (timer-relative-time
 796                        (list (aref timer 1) (aref timer 2) (aref timer 3))
 797                        (* 5 (aref timer 4)) 0)))
 798       ;; If the activation time is far in the past,
 799       ;; skip executions until we reach a time in the future.
 800       ;; This avoids a long pause if Emacs has been suspended for hours.
 801       (or (> (nth 0 next-time) (nth 0 current))
 802           (and (= (nth 0 next-time) (nth 0 current))
 803                (> (nth 1 next-time) (nth 1 current)))
 804           (and (= (nth 0 next-time) (nth 0 current))
 805                (= (nth 1 next-time) (nth 1 current))
 806                (> (nth 2 next-time) (nth 2 current)))
 807           (progn
 808             (timer-set-time timer (timer-next-integral-multiple-of-time
 809                                    current wl-biff-check-interval)
 810                             wl-biff-check-interval)
 811             (timer-activate timer))))))
 812  (t
 813   (fset 'wl-biff-stop 'ignore)
 814   (fset 'wl-biff-start 'ignore)))
 815
 816 (defsubst wl-biff-notify (new-mails notify-minibuf)
 817   (setq wl-modeline-biff-status (> new-mails 0))
 818   (force-mode-line-update t)
 819   (when notify-minibuf
 820     (cond ((zerop new-mails) (message "No mail."))
 821           ((eq 1 new-mails) (message "You have a new mail."))
 822           (t (message "You have %d new mails." new-mails)))))
 823
 824 ;; Internal variable.
 825 (defvar wl-biff-check-folders-running nil)
 826
 827 (defun wl-biff-check-folders ()
 828   (interactive)
 829   (if wl-biff-check-folders-running
 830       (when (interactive-p)
 831         (message "Biff process is running."))
 832     (setq wl-biff-check-folders-running t)
 833     (when (interactive-p)
 834       (message "Checking new mails..."))
 835     (let ((new-mails 0)
 836           (flist (or wl-biff-check-folder-list (list wl-default-folder)))
 837           (elmo-network-session-name-prefix "BIFF-")
 838           folder)
 839       (if (eq (length flist) 1)
 840           (wl-biff-check-folder-async (car flist) (interactive-p))
 841         (unwind-protect
 842             (while flist
 843               (setq folder (car flist)
 844                     flist (cdr flist))
 845               (when (elmo-folder-plugged-p folder)
 846                 (setq new-mails
 847                       (+ new-mails
 848                          (nth 0 (wl-folder-check-one-entity folder))))))
 849           (setq wl-biff-check-folders-running nil)
 850           (wl-biff-notify new-mails (interactive-p)))))))
 851
 852 (defun wl-biff-check-folder-async-callback (diff data)
 853   (if (nth 1 data)
 854       (with-current-buffer (nth 1 data)
 855         (wl-folder-entity-hashtb-set wl-folder-entity-hashtb (nth 0 data)
 856                                      (list (car diff) 0 (cdr diff))
 857                                      (current-buffer))))
 858   (setq wl-folder-info-alist-modified t)
 859   (setq wl-biff-check-folders-running nil)
 860   (sit-for 0)
 861   (wl-biff-notify (car diff) (nth 2 data)))
 862
 863 (defun wl-biff-check-folder-async (folder notify-minibuf)
 864   (when (elmo-folder-plugged-p folder)
 865     (if (and (eq (elmo-folder-get-type folder) 'imap4)
 866              (wl-folder-use-server-diff-p folder))
 867         ;; Check asynchronously only when IMAP4 and use server diff.
 868         (progn
 869           (setq elmo-folder-diff-async-callback
 870                 'wl-biff-check-folder-async-callback)
 871           (setq elmo-folder-diff-async-callback-data
 872                 (list folder (get-buffer wl-folder-buffer-name)
 873                       notify-minibuf))
 874           (elmo-folder-diff-async folder))
 875       (wl-biff-notify (car (wl-folder-check-one-entity folder))
 876                       notify-minibuf)
 877       (setq wl-biff-check-folders-running nil))))
 878
 879 ;;; wl-util.el ends here