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