wl/wl-util.el

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