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