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