wl/wl-util.el

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