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