cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-misc.el

   1 ;;; vm-misc.el --- Miscellaneous functions for VM
   2 ;;
   3 ;; Copyright (C) 1989-2001 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;; Taken from XEmacs as GNU Emacs is missing `replace-in-string' and defining
  23 ;; it may cause clashes with other packages defining it differently, in fact
  24 ;; we could also call the function `replace-regexp-in-string' as Roland
  25 ;; Winkler pointed out.
  26 (defun vm-replace-in-string (str regexp newtext &optional literal)
  27   "Replace all matches in STR for REGEXP with NEWTEXT string,
  28  and returns the new string.
  29 Optional LITERAL non-nil means do a literal replacement.
  30 Otherwise treat `\\' in NEWTEXT as special:
  31   `\\&' in NEWTEXT means substitute original matched text.
  32   `\\N' means substitute what matched the Nth `\\(...\\)'.
  33        If Nth parens didn't match, substitute nothing.
  34   `\\\\' means insert one `\\'.
  35   `\\u' means upcase the next character.
  36   `\\l' means downcase the next character.
  37   `\\U' means begin upcasing all following characters.
  38   `\\L' means begin downcasing all following characters.
  39   `\\E' means terminate the effect of any `\\U' or `\\L'."
  40   (if (> (length str) 50)
  41       (let ((cfs case-fold-search))
  42         (with-temp-buffer
  43           (setq case-fold-search cfs)
  44           (insert str)
  45           (goto-char 1)
  46           (while (re-search-forward regexp nil t)
  47             (replace-match newtext t literal))
  48           (buffer-string)))
  49     (let ((start 0) newstr)
  50       (while (string-match regexp str start)
  51         (setq newstr (replace-match newtext t literal str)
  52               start (+ (match-end 0) (- (length newstr) (length str)))
  53               str newstr))
  54       str)))
  55
  56 (defun vm-delete-non-matching-strings (regexp list &optional destructively)
  57   "Delete strings matching REGEXP from LIST.
  58 Optional third arg non-nil means to destructively alter LIST, instead of
  59 working on a copy.
  60
  61 The new version of the list, minus the deleted strings, is returned."
  62   (or destructively (setq list (copy-sequence list)))
  63   (let ((curr list) (prev nil))
  64     (while curr
  65       (if (string-match regexp (car curr))
  66           (setq prev curr
  67                 curr (cdr curr))
  68         (if (null prev)
  69             (setq list (cdr list)
  70                   curr list)
  71           (setcdr prev (cdr curr))
  72           (setq curr (cdr curr)))))
  73     list ))
  74
  75 (defun vm-parse (string regexp &optional matchn matches)
  76   "Returns list of string by splitting STRING with REGEXP matches.
  77 REGEXP must match one item and MATCHN can be used to select a match
  78 group (default is 1).  MATCHES is the number of time the match is
  79 applied (default until it does not match anymore).
  80
  81 This function is similar to a spring-split, but a bit more complex
  82 and flexible."
  83   (or matchn (setq matchn 1))
  84   (let (list tem)
  85     (store-match-data nil)
  86     (while (and (not (eq matches 0))
  87                 (string-match regexp string (match-end 0)))
  88       (and (integerp matches) (setq matches (1- matches)))
  89       (if (not (consp matchn))
  90           (setq list (cons (substring string (match-beginning matchn)
  91                                       (match-end matchn)) list))
  92         (setq tem matchn)
  93         (while tem
  94           (if (match-beginning (car tem))
  95               (setq list (cons (substring string
  96                                           (match-beginning (car tem))
  97                                           (match-end (car tem))) list)
  98                     tem nil)
  99             (setq tem (cdr tem))))))
 100    (if (and (integerp matches) (match-end 0)
 101             (not (eq (match-end 0) (length string))))
 102        (setq list (cons (substring string (match-end 0) (length string))
 103                          list)))
 104    (nreverse list)))
 105
 106 (defun vm-parse-addresses (string)
 107   (if (null string)
 108       ()
 109     (let (work-buffer)
 110       (save-excursion
 111        (unwind-protect
 112            (let (list start s char)
 113              (setq work-buffer (vm-make-work-buffer))
 114              (set-buffer work-buffer)
 115              (insert string)
 116              (goto-char (point-min))
 117              (skip-chars-forward "\t\f\n\r ")
 118              (setq start (point))
 119              (while (not (eobp))
 120                (skip-chars-forward "^\"\\\\,(")
 121                (setq char (following-char))
 122                (cond ((= char ?\\)
 123                       (forward-char 1)
 124                       (if (not (eobp))
 125                           (forward-char 1)))
 126                      ((= char ?,)
 127                       (setq s (buffer-substring start (point)))
 128                       (if (or (null (string-match "^[\t\f\n\r ]+$" s))
 129                               (not (string= s "")))
 130                           (setq list (cons s list)))
 131                       (skip-chars-forward ",\t\f\n\r ")
 132                       (setq start (point)))
 133                      ((= char ?\")
 134                       (re-search-forward "[^\\\\]\"" nil 0))
 135                      ((= char ?\()
 136                       (let ((parens 1))
 137                         (forward-char 1)
 138                         (while (and (not (eobp)) (not (zerop parens)))
 139                           (re-search-forward "[()]" nil 0)
 140                           (cond ((or (eobp)
 141                                      (= (char-after (- (point) 2)) ?\\)))
 142                                 ((= (preceding-char) ?\()
 143                                  (setq parens (1+ parens)))
 144                                 (t
 145                                  (setq parens (1- parens)))))))))
 146              (setq s (buffer-substring start (point)))
 147              (if (and (null (string-match "^[\t\f\n\r ]+$" s))
 148                       (not (string= s "")))
 149                  (setq list (cons s list)))
 150              (mapcar 'vmrf-fix-quoted-address (reverse list)))
 151         (and work-buffer (kill-buffer work-buffer)))))))
 152
 153 (defun vmrf-fix-quoted-address (a)
 154   "RF: evetually there are qp-encoded addresses not quoted by \" and thus we
 155   need to add quotes or leave them undecoded."
 156   (let ((da (vm-decode-mime-encoded-words-in-string a)))
 157     (if (string= da a)
 158         a
 159       (if (or (string-match "^\\s-*\\([^\"']*,[^\"']*\\)\\b\\s-*\\(<.*\\)" da)
 160               (string-match "^\\s-*\"'\\([^\"']+\\)'\"\\(.*\\)" da))
 161           (concat "\"" (match-string 1 da) "\" " (match-string 2 da))
 162         da))))
 163
 164 (defun vm-parse-structured-header (string &optional sepchar keep-quotes)
 165   (if (null string)
 166       ()
 167     (let ((work-buffer nil))
 168       (save-excursion
 169        (unwind-protect
 170            (let ((list nil)
 171                  (nonspecials "^\"\\\\( \t\n\r\f")
 172                  start s char sp+sepchar)
 173              (if sepchar
 174                  (setq nonspecials (concat nonspecials (list sepchar))
 175                        sp+sepchar (concat "\t\f\n\r " (list sepchar))))
 176              (setq work-buffer (vm-make-work-buffer))
 177              (buffer-disable-undo work-buffer)
 178              (set-buffer work-buffer)
 179              (insert string)
 180              (goto-char (point-min))
 181              (skip-chars-forward "\t\f\n\r ")
 182              (setq start (point))
 183              (while (not (eobp))
 184                (skip-chars-forward nonspecials)
 185                (setq char (following-char))
 186                (cond ((looking-at "[ \t\n\r\f]")
 187                       (delete-char 1))
 188                      ((= char ?\\)
 189                       (forward-char 1)
 190                       (if (not (eobp))
 191                           (forward-char 1)))
 192                      ((and sepchar (= char sepchar))
 193                       (setq s (buffer-substring start (point)))
 194                       (if (or (null (string-match "^[\t\f\n\r ]+$" s))
 195                               (not (string= s "")))
 196                           (setq list (cons s list)))
 197                       (skip-chars-forward sp+sepchar)
 198                       (setq start (point)))
 199                      ((looking-at " \t\n\r\f")
 200                       (skip-chars-forward " \t\n\r\f"))
 201                      ((= char ?\")
 202                       (let ((done nil))
 203                         (if keep-quotes
 204                             (forward-char 1)
 205                           (delete-char 1))
 206                         (while (not done)
 207                           (if (null (re-search-forward "[\\\\\"]" nil t))
 208                               (setq done t)
 209                             (setq char (char-after (1- (point))))
 210                             (cond ((char-equal char ?\\)
 211                                    (delete-char -1)
 212                                    (if (eobp)
 213                                        (setq done t)
 214                                      (forward-char 1)))
 215                                   (t (if (not keep-quotes)
 216                                          (delete-char -1))
 217                                      (setq done t)))))))
 218                      ((= char ?\()
 219                       (let ((done nil)
 220                             (pos (point))
 221                             (parens 1))
 222                         (forward-char 1)
 223                         (while (not done)
 224                           (if (null (re-search-forward "[\\\\()]" nil t))
 225                               (setq done t)
 226                             (setq char (char-after (1- (point))))
 227                             (cond ((char-equal char ?\\)
 228                                    (if (eobp)
 229                                        (setq done t)
 230                                      (forward-char 1)))
 231                                   ((char-equal char ?\()
 232                                    (setq parens (1+ parens)))
 233                                   (t
 234                                    (setq parens (1- parens)
 235                                          done (zerop parens))))))
 236                         (delete-region pos (point))))))
 237              (setq s (buffer-substring start (point)))
 238              (if (and (null (string-match "^[\t\f\n\r ]+$" s))
 239                       (not (string= s "")))
 240                  (setq list (cons s list)))
 241              (nreverse list))
 242         (and work-buffer (kill-buffer work-buffer)))))))
 243
 244 (defvar buffer-file-type)
 245
 246 (defun vm-write-string (where string)
 247   (if (bufferp where)
 248       (vm-save-buffer-excursion
 249         (set-buffer where)
 250         (goto-char (point-max))
 251         (let ((buffer-read-only nil))
 252           (insert string)))
 253     (let ((temp-buffer nil))
 254       (unwind-protect
 255           (save-excursion
 256             (setq temp-buffer (generate-new-buffer "*vm-work*"))
 257             (set-buffer temp-buffer)
 258             (setq selective-display nil)
 259             (insert string)
 260             ;; correct for VM's uses of this function---
 261             ;; writing out message separators
 262             (setq buffer-file-type nil)
 263             (write-region (point-min) (point-max) where t 'quiet))
 264         (and temp-buffer (kill-buffer temp-buffer))))))
 265
 266 (defun vm-check-for-killed-summary ()
 267   (and (bufferp vm-summary-buffer) (null (buffer-name vm-summary-buffer))
 268        (let ((mp vm-message-list))
 269          (setq vm-summary-buffer nil)
 270          (while mp
 271            (vm-set-su-start-of (car mp) nil)
 272            (vm-set-su-end-of (car mp) nil)
 273            (setq mp (cdr mp)))))
 274   (and (bufferp vm-folders-summary-buffer)
 275        (null (buffer-name vm-folders-summary-buffer))
 276        (setq vm-folders-summary-buffer nil)))
 277
 278 (defun vm-check-for-killed-presentation ()
 279   (and (bufferp vm-presentation-buffer-handle)
 280        (null (buffer-name vm-presentation-buffer-handle))
 281        (progn
 282          (setq vm-presentation-buffer-handle nil
 283                vm-presentation-buffer nil))))
 284
 285 (defun vm-check-for-killed-folder ()
 286   (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer))
 287        (setq vm-mail-buffer nil)))
 288
 289 (put 'folder-read-only 'error-conditions '(folder-read-only error))
 290 (put 'folder-read-only 'error-message "Folder is read-only")
 291
 292 (defun vm-abs (n) (if (< n 0) (- n) n))
 293
 294 (defun vm-last (list) (while (cdr-safe list) (setq list (cdr list))) list)
 295
 296 (defun vm-vector-to-list (vector)
 297   (let ((i (1- (length vector)))
 298         list)
 299     (while (>= i 0)
 300       (setq list (cons (aref vector i) list))
 301       (vm-decrement i))
 302     list ))
 303
 304 (defun vm-extend-vector (vector length &optional fill)
 305   (let ((vlength (length vector)))
 306     (if (< vlength length)
 307         (apply 'vector (nconc (vm-vector-to-list vector)
 308                               (make-list (- length vlength) fill)))
 309       vector )))
 310
 311 (defun vm-obarray-to-string-list (blobarray)
 312   (let ((list nil))
 313     (mapatoms (function (lambda (s) (setq list (cons (symbol-name s) list))))
 314               blobarray)
 315     list ))
 316
 317 (defun vm-mapcar (function &rest lists)
 318   (let (arglist result)
 319     (while (car lists)
 320       (setq arglist (mapcar 'car lists))
 321       (setq result (cons (apply function arglist) result))
 322       (setq lists (mapcar 'cdr lists)))
 323     (nreverse result)))
 324
 325 (defun vm-mapc (function &rest lists)
 326   (let (arglist)
 327     (while (car lists)
 328       (setq arglist (mapcar 'car lists))
 329       (apply function arglist)
 330       (setq lists (mapcar 'cdr lists)))))
 331
 332 (defun vm-delete (predicate list &optional reverse)
 333   (let ((p list) (reverse (if reverse 'not 'identity)) prev)
 334     (while p
 335       (if (funcall reverse (funcall predicate (car p)))
 336           (if (null prev)
 337               (setq list (cdr list) p list)
 338             (setcdr prev (cdr p))
 339             (setq p (cdr p)))
 340         (setq prev p p (cdr p))))
 341     list ))
 342
 343 (defun vm-delete-directory-file-names (list)
 344   (vm-delete 'file-directory-p list))
 345
 346 (defun vm-delete-backup-file-names (list)
 347   (vm-delete 'backup-file-name-p list))
 348
 349 (defun vm-delete-auto-save-file-names (list)
 350   (vm-delete 'auto-save-file-name-p list))
 351
 352 (defun vm-delete-index-file-names (list)
 353   (vm-delete 'vm-index-file-name-p list))
 354
 355 (defun vm-delete-directory-names (list)
 356   (vm-delete 'file-directory-p list))
 357
 358 (defun vm-index-file-name-p (file)
 359   (and (file-regular-p file)
 360        (stringp vm-index-file-suffix)
 361        (let ((str (concat (regexp-quote vm-index-file-suffix) "$")))
 362          (string-match str file))
 363        t ))
 364
 365 (defun vm-delete-duplicates (list &optional all hack-addresses)
 366   "Delete duplicate equivalent strings from the list.
 367 If ALL is t, then if there is more than one occurrence of a string in the list,
 368  then all occurrences of it are removed instead of just the subsequent ones.
 369 If HACK-ADDRESSES is t, then the strings are considered to be mail addresses,
 370  and only the address part is compared (so that \"Name <foo>\" and \"foo\"
 371  would be considered to be equivalent.)"
 372   (let ((hashtable vm-delete-duplicates-obarray)
 373         (new-list nil)
 374         sym-string sym)
 375     (fillarray hashtable 0)
 376     (while list
 377       (setq sym-string
 378             (if hack-addresses
 379                 (nth 1 (funcall vm-chop-full-name-function (car list)))
 380               (car list))
 381             sym-string (or sym-string "-unparseable-garbage-")
 382             sym (intern (if hack-addresses (downcase sym-string) sym-string)
 383                         hashtable))
 384       (if (boundp sym)
 385           (and all (setcar (symbol-value sym) nil))
 386         (setq new-list (cons (car list) new-list))
 387         (set sym new-list))
 388       (setq list (cdr list)))
 389     (delq nil (nreverse new-list))))
 390
 391 (defun vm-member-0 (thing list)
 392   (catch 'done
 393     (while list
 394       (and (equal (car list) thing)
 395            (throw 'done list))
 396       (setq list (cdr list)))
 397     nil ))
 398
 399 (fset 'vm-member (symbol-function (if (fboundp 'member) 'member 'vm-member-0)))
 400
 401 (defun vm-delqual (ob list)
 402   (let ((prev nil)
 403         (curr list))
 404     (while curr
 405       (if (not (equal ob (car curr)))
 406           (setq prev curr
 407                 curr (cdr curr))
 408         (if (null prev)
 409             (setq list (cdr list)
 410                   curr list)
 411           (setq curr (cdr curr))
 412           (setcdr prev curr))))
 413     list ))
 414
 415 (defun vm-copy-local-variables (buffer &rest variables)
 416   (let ((values (mapcar 'symbol-value variables)))
 417     (save-excursion
 418       (set-buffer buffer)
 419       (vm-mapc 'set variables values))))
 420
 421 (put 'folder-empty 'error-conditions '(folder-empty error))
 422 (put 'folder-empty 'error-message "Folder is empty")
 423 (put 'unrecognized-folder-type 'error-conditions
 424      '(unrecognized-folder-type error))
 425 (put 'unrecognized-folder-type 'error-message "Unrecognized folder type")
 426
 427 (defun vm-error-if-folder-empty ()
 428   (while (null vm-message-list)
 429     (if vm-folder-type
 430         (signal 'unrecognized-folder-type nil)
 431       (signal 'folder-empty nil))))
 432
 433 (defun vm-copy (object)
 434   (cond ((consp object)
 435          (let (return-value cons)
 436            (setq return-value (cons (vm-copy (car object)) nil)
 437                  cons return-value
 438                  object (cdr object))
 439            (while (consp object)
 440              (setcdr cons (cons (vm-copy (car object)) nil))
 441              (setq cons (cdr cons)
 442                    object (cdr object)))
 443            (setcdr cons object)
 444            return-value ))
 445         ((vectorp object) (apply 'vector (mapcar 'vm-copy object)))
 446         ((stringp object) (copy-sequence object))
 447         ((markerp object) (copy-marker object))
 448         (t object)))
 449
 450 (defun vm-run-message-hook (message &optional hook-variable)
 451   (save-excursion
 452     (set-buffer (vm-buffer-of message))
 453     (vm-save-restriction
 454       (widen)
 455       (save-excursion
 456         (narrow-to-region (vm-headers-of message) (vm-text-end-of message))
 457         (run-hooks hook-variable)))))
 458
 459 (defun vm-error-free-call (function &rest args)
 460   (condition-case nil
 461       (apply function args)
 462     (error nil)))
 463
 464 (put 'beginning-of-folder 'error-conditions '(beginning-of-folder error))
 465 (put 'beginning-of-folder 'error-message "Beginning of folder")
 466 (put 'end-of-folder 'error-conditions '(end-of-folder error))
 467 (put 'end-of-folder 'error-message "End of folder")
 468
 469 (defun vm-trace (&rest args)
 470   (save-excursion
 471     (set-buffer (get-buffer-create "*vm-trace*"))
 472     (apply 'insert args)))
 473
 474 (defun vm-timezone-make-date-sortable (string)
 475   (or (cdr (assq string vm-sortable-date-alist))
 476       (let ((vect (vm-parse-date string))
 477             (date (vm-parse (current-time-string) " *\\([^ ]+\\)")))
 478         ;; if specified date is incomplete fill in the holes
 479         ;; with useful information, defaulting to the current
 480         ;; date and timezone for everything except hh:mm:ss which
 481         ;; defaults to midnight.
 482         (if (equal (aref vect 1) "")
 483             (aset vect 1 (nth 2 date)))
 484         (if (equal (aref vect 2) "")
 485             (aset vect 2 (nth 1 date)))
 486         (if (equal (aref vect 3) "")
 487             (aset vect 3 (nth 4 date)))
 488         (if (equal (aref vect 4) "")
 489             (aset vect 4 "00:00:00"))
 490         (if (equal (aref vect 5) "")
 491             (aset vect 5 (vm-current-time-zone)))
 492         ;; save this work so we won't have to do it again
 493         (setq vm-sortable-date-alist
 494               (cons (cons string
 495                           (condition-case nil
 496                               (timezone-make-date-sortable
 497                                (format "%s %s %s %s %s"
 498                                        (aref vect 1)
 499                                        (aref vect 2)
 500                                        (aref vect 3)
 501                                        (aref vect 4)
 502                                        (aref vect 5)))
 503                             (error "1970010100:00:00")))
 504                     vm-sortable-date-alist))
 505         ;; return result
 506         (cdr (car vm-sortable-date-alist)))))
 507
 508 (defun vm-current-time-zone ()
 509   (or (condition-case nil
 510           (let* ((zone (car (current-time-zone)))
 511                  (absmin (/ (vm-abs zone) 60)))
 512             (format "%c%02d%02d" (if (< zone 0) ?- ?+)
 513                     (/ absmin 60) (% absmin 60)))
 514         (error nil))
 515       (let ((temp-buffer nil))
 516         (condition-case nil
 517             (unwind-protect
 518                 (save-excursion
 519                   (setq temp-buffer (vm-make-work-buffer))
 520                   (set-buffer temp-buffer)
 521                   (call-process "date" nil temp-buffer nil)
 522                   (nth 4 (vm-parse (vm-buffer-string-no-properties)
 523                                    " *\\([^ ]+\\)")))
 524               (and temp-buffer (kill-buffer temp-buffer)))
 525           (error nil)))
 526       ""))
 527
 528 (defun vm-should-generate-summary ()
 529   (cond ((eq vm-startup-with-summary t) t)
 530         ((integerp vm-startup-with-summary)
 531          (let ((n vm-startup-with-summary))
 532            (cond ((< n 0) (null (nth (vm-abs n) vm-message-list)))
 533                  ((= n 0) nil)
 534                  (t (nth (1- n) vm-message-list)))))
 535         (vm-startup-with-summary t)
 536         (t nil)))
 537
 538 (defun vm-find-composition-buffer (&optional not-picky)
 539   (let ((b-list (buffer-list)) choice alternate)
 540     (save-excursion
 541      (while b-list
 542        (set-buffer (car b-list))
 543        (if (eq major-mode 'mail-mode)
 544            (if (buffer-modified-p)
 545                (setq choice (current-buffer)
 546                      b-list nil)
 547              (and not-picky (null alternate)
 548                   (setq alternate (current-buffer)))
 549              (setq b-list (cdr b-list)))
 550          (setq b-list (cdr b-list))))
 551     (or choice alternate))))
 552
 553 (defun vm-get-file-buffer (file)
 554   "Like get-file-buffer, but also checks buffers against FILE's truename"
 555   (or (get-file-buffer file)
 556       (and (fboundp 'file-truename)
 557            (get-file-buffer (file-truename file)))
 558       (and (fboundp 'find-buffer-visiting)
 559            (find-buffer-visiting file))))
 560
 561 (defun vm-set-region-face (start end face)
 562   (let ((e (vm-make-extent start end)))
 563     (vm-set-extent-property e 'face face)))
 564
 565 (defun vm-default-buffer-substring-no-properties (beg end &optional buffer)
 566   (let ((s (if buffer
 567                (save-excursion
 568                  (set-buffer buffer)
 569                  (buffer-substring beg end))
 570              (buffer-substring beg end))))
 571     (set-text-properties 0 (length s) nil s)
 572     (copy-sequence s)))
 573
 574 (fset 'vm-buffer-substring-no-properties
 575   (cond ((fboundp 'buffer-substring-no-properties)
 576          (function buffer-substring-no-properties))
 577         (vm-xemacs-p
 578          (function buffer-substring))
 579         (t (function vm-default-buffer-substring-no-properties))))
 580
 581 (defun vm-buffer-string-no-properties ()
 582   (vm-buffer-substring-no-properties (point-min) (point-max)))
 583
 584 (defun vm-insert-region-from-buffer (buffer &optional start end)
 585   (let ((target-buffer (current-buffer)))
 586     (set-buffer buffer)
 587     (save-restriction
 588       (widen)
 589       (or start (setq start (point-min)))
 590       (or end (setq end (point-max)))
 591       (set-buffer target-buffer)
 592       (insert-buffer-substring buffer start end)
 593       (set-buffer buffer))
 594     (set-buffer target-buffer)))
 595
 596 (if (not (fboundp 'vm-extent-property))
 597     (if vm-fsfemacs-p
 598         (fset 'vm-extent-property 'overlay-get)
 599       (fset 'vm-extent-property 'extent-property)))
 600
 601 (if (not (fboundp 'vm-extent-object))
 602     (if vm-fsfemacs-p
 603         (fset 'vm-extent-object 'overlay-buffer)
 604       (fset 'vm-extent-object 'extent-object)))
 605
 606 (if (not (fboundp 'vm-set-extent-property))
 607     (if vm-fsfemacs-p
 608         (fset 'vm-set-extent-property 'overlay-put)
 609       (fset 'vm-set-extent-property 'set-extent-property)))
 610
 611 (if (not (fboundp 'vm-set-extent-endpoints))
 612     (if vm-fsfemacs-p
 613         (fset 'vm-set-extent-endpoints 'move-overlay)
 614       (fset 'vm-set-extent-endpoints 'set-extent-endpoints)))
 615
 616 (if (not (fboundp 'vm-make-extent))
 617     (if vm-fsfemacs-p
 618         (fset 'vm-make-extent 'make-overlay)
 619       (fset 'vm-make-extent 'make-extent)))
 620
 621 (if (not (fboundp 'vm-extent-end-position))
 622     (if vm-fsfemacs-p
 623         (fset 'vm-extent-end-position 'overlay-end)
 624       (fset 'vm-extent-end-position 'extent-end-position)))
 625
 626 (if (not (fboundp 'vm-extent-start-position))
 627     (if vm-fsfemacs-p
 628         (fset 'vm-extent-start-position 'overlay-start)
 629       (fset 'vm-extent-start-position 'extent-start-position)))
 630
 631 (if (not (fboundp 'vm-detach-extent))
 632     (if vm-fsfemacs-p
 633         (fset 'vm-detach-extent 'delete-overlay)
 634       (fset 'vm-detach-extent 'detach-extent)))
 635
 636 (if (not (fboundp 'vm-extent-properties))
 637     (if vm-fsfemacs-p
 638         (fset 'vm-extent-properties 'overlay-properties)
 639       (fset 'vm-extent-properties 'extent-properties)))
 640
 641 (defun vm-extent-at (pos &optional object property)
 642   (if (fboundp 'extent-at)
 643       (extent-at pos object property)
 644     (let ((o-list (overlays-at pos))
 645           (o nil))
 646       (if (null property)
 647           (car o-list)
 648         (while o-list
 649           (if (overlay-get (car o-list) property)
 650               (setq o (car o-list)
 651                     o-list nil)
 652             (setq o-list (cdr o-list))))
 653         o ))))
 654
 655 (defun vm-copy-extent (e)
 656   (let ((props (vm-extent-properties e))
 657         (ee (vm-make-extent (vm-extent-start-position e)
 658                             (vm-extent-end-position e))))
 659     (while props
 660       (vm-set-extent-property ee (car props) (car (cdr props)))
 661       (setq props (cdr (cdr props))))))
 662
 663 (defun vm-make-tempfile (&optional filename-suffix proposed-filename)
 664   (let ((modes (default-file-modes))
 665         (file (vm-make-tempfile-name filename-suffix proposed-filename)))
 666     (unwind-protect
 667         (progn
 668           (set-default-file-modes (vm-octal 600))
 669           (vm-error-free-call 'delete-file file)
 670           (write-region (point) (point) file nil 0))
 671       (set-default-file-modes modes))
 672     file ))
 673
 674 (defun vm-make-tempfile-name (&optional filename-suffix proposed-filename)
 675   (if (stringp proposed-filename)
 676       (setq proposed-filename (file-name-nondirectory proposed-filename)))
 677   (let (filename)
 678     (cond ((and (stringp proposed-filename)
 679                 (not (file-exists-p
 680                       (setq filename (convert-standard-filename
 681                                       (expand-file-name
 682                                        proposed-filename
 683                                        vm-temp-file-directory))))))
 684            t )
 685           ((stringp proposed-filename)
 686            (let ((done nil))
 687              (while (not done)
 688                (setq filename (convert-standard-filename
 689                                (expand-file-name
 690                                 (format "%d-%s"
 691                                         vm-tempfile-counter
 692                                         proposed-filename)
 693                                 vm-temp-file-directory))
 694                      vm-tempfile-counter (1+ vm-tempfile-counter)
 695                      done (not (file-exists-p filename))))))
 696           (t
 697            (let ((done nil))
 698              (while (not done)
 699                (setq filename (convert-standard-filename
 700                                (expand-file-name
 701                                 (format "vm%d%d%s"
 702                                         vm-tempfile-counter
 703                                         (random 100000000)
 704                                         (or filename-suffix ""))
 705                                 vm-temp-file-directory))
 706                      vm-tempfile-counter (1+ vm-tempfile-counter)
 707                      done (not (file-exists-p filename)))))))
 708     filename ))
 709
 710 (defun vm-make-work-buffer (&optional name)
 711   (let ((default-enable-multibyte-characters nil)
 712         work-buffer)
 713     (setq work-buffer (generate-new-buffer (or name "*vm-workbuf*")))
 714     (buffer-disable-undo work-buffer)
 715 ;; probably not worth doing since no one sets buffer-offer-save
 716 ;; non-nil globally, do they?
 717 ;;    (save-excursion
 718 ;;      (set-buffer work-buffer)
 719 ;;      (setq buffer-offer-save nil))
 720     work-buffer ))
 721
 722 (defun vm-make-multibyte-work-buffer (&optional name)
 723   (let ((default-enable-multibyte-characters t)
 724         work-buffer)
 725     (setq work-buffer (generate-new-buffer (or name "*vm-workbuf*")))
 726     (buffer-disable-undo work-buffer)
 727 ;; probably not worth doing since no one sets buffer-offer-save
 728 ;; non-nil globally, do they?
 729 ;;    (save-excursion
 730 ;;      (set-buffer work-buffer)
 731 ;;      (setq buffer-offer-save nil))
 732     work-buffer ))
 733
 734 (defun vm-insert-char (char &optional count ignored buffer)
 735   (condition-case nil
 736       (progn
 737         (insert-char char count ignored buffer)
 738         (fset 'vm-insert-char 'insert-char))
 739     (wrong-number-of-arguments
 740      (fset 'vm-insert-char 'vm-xemacs-compatible-insert-char)
 741      (vm-insert-char char count ignored buffer))))
 742
 743 (defun vm-xemacs-compatible-insert-char (char &optional count ignored buffer)
 744   (if (and buffer (eq buffer (current-buffer)))
 745       (insert-char char count)
 746     (save-excursion
 747       (set-buffer buffer)
 748       (insert-char char count))))
 749
 750 (defun vm-symbol-lists-intersect-p (list1 list2)
 751   (catch 'done
 752     (while list1
 753       (and (memq (car list1) list2)
 754            (throw 'done t))
 755       (setq list1 (cdr list1)))
 756     nil ))
 757
 758 (defun vm-set-buffer-variable (buffer var value)
 759   (save-excursion
 760     (set-buffer buffer)
 761     (set var value)))
 762
 763 (defun vm-buffer-variable-value (buffer var)
 764   (save-excursion
 765     (set-buffer buffer)
 766     (symbol-value var)))
 767
 768 (defsubst vm-with-string-as-temp-buffer (string function)
 769   (let ((work-buffer nil))
 770     (unwind-protect
 771         (save-excursion
 772           (setq work-buffer (vm-make-multibyte-work-buffer))
 773           (set-buffer work-buffer)
 774           (insert string)
 775           (funcall function)
 776           (buffer-string))
 777       (and work-buffer (kill-buffer work-buffer)))))
 778
 779 (defun vm-string-assoc (elt list)
 780   (let ((case-fold-search t)
 781         (found nil)
 782         (elt (regexp-quote elt)))
 783     (while (and list (not found))
 784       (if (and (equal 0 (string-match elt (car (car list))))
 785                (= (match-end 0) (length (car (car list)))))
 786           (setq found t)
 787         (setq list (cdr list))))
 788     (car list)))
 789
 790 (defun vm-nonneg-string (n)
 791   (if (< n 0)
 792       "?"
 793     (int-to-string n)))
 794
 795 (defun vm-string-member (elt list)
 796   (let ((case-fold-search t)
 797         (found nil)
 798         (elt (regexp-quote elt)))
 799     (while (and list (not found))
 800       (if (and (equal 0 (string-match elt (car list)))
 801                (= (match-end 0) (length (car list))))
 802           (setq found t)
 803         (setq list (cdr list))))
 804     list))
 805
 806 (defun vm-string-equal-ignore-case (str1 str2)
 807   (let ((case-fold-search t)
 808         (reg (regexp-quote str1)))
 809     (and (equal 0 (string-match reg str2))
 810          (= (match-end 0) (length str2)))))
 811
 812 (defun vm-time-difference (t1 t2)
 813   (let (usecs secs 65536-secs carry)
 814     (setq usecs (- (nth 2 t1) (nth 2 t2)))
 815     (if (< usecs 0)
 816         (setq carry 1
 817               usecs (+ usecs 1000000))
 818       (setq carry 0))
 819     (setq secs (- (nth 1 t1) (nth 1 t2) carry))
 820     (if (< secs 0)
 821          (setq carry 1
 822                secs (+ secs 65536))
 823       (setq carry 0))
 824     (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry))
 825     (+ (* 65536-secs 65536)
 826        secs
 827        (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000)))))
 828
 829 (if (fboundp 'char-to-int)
 830     (fset 'vm-char-to-int 'char-to-int)
 831   (fset 'vm-char-to-int 'identity))
 832
 833 (cond ((fboundp 'charsets-in-region)
 834        (fset 'vm-charsets-in-region 'charsets-in-region))
 835       ((fboundp 'find-charset-region)
 836        (fset 'vm-charsets-in-region 'find-charset-region)))
 837
 838 (cond ((fboundp 'coding-system-name)
 839        (fset 'vm-coding-system-name 'coding-system-name))
 840       (t
 841        (fset 'vm-coding-system-name 'symbol-name)))
 842
 843 (defun vm-get-file-line-ending-coding-system (file)
 844   (if (not (or vm-fsfemacs-mule-p vm-xemacs-mule-p vm-xemacs-file-coding-p))
 845       nil
 846     (let ((coding-system-for-read  (vm-binary-coding-system))
 847           (work-buffer nil))
 848       (unwind-protect
 849           (save-excursion
 850             (setq work-buffer (vm-make-work-buffer))
 851             (set-buffer work-buffer)
 852             (condition-case nil
 853                 (insert-file-contents file nil 0 4096)
 854               (error nil))
 855             (goto-char (point-min))
 856             (cond ((re-search-forward "[^\r]\n" nil t)
 857                    (if vm-fsfemacs-mule-p 'raw-text-unix 'no-conversion-unix))
 858                   ((re-search-forward "\r[^\n]" nil t)
 859                    (if vm-fsfemacs-mule-p 'raw-text-mac 'no-conversion-mac))
 860                   ((search-forward "\r\n" nil t)
 861                    (if vm-fsfemacs-mule-p 'raw-text-dos 'no-conversion-dos))
 862                   (t (vm-line-ending-coding-system))))
 863         (and work-buffer (kill-buffer work-buffer))))))
 864
 865 (defun vm-new-folder-line-ending-coding-system ()
 866   (cond ((eq vm-default-new-folder-line-ending-type nil)
 867          (vm-line-ending-coding-system))
 868         ((eq vm-default-new-folder-line-ending-type 'lf)
 869          (if vm-fsfemacs-mule-p 'raw-text-unix 'no-conversion-unix))
 870         ((eq vm-default-new-folder-line-ending-type 'crlf)
 871          (if vm-fsfemacs-mule-p 'raw-text-dos 'no-conversion-dos))
 872         ((eq vm-default-new-folder-line-ending-type 'cr)
 873          (if vm-fsfemacs-mule-p 'raw-text-mac 'no-conversion-mac))
 874         (t
 875          (vm-line-ending-coding-system))))
 876
 877 (defun vm-collapse-whitespace ()
 878   (goto-char (point-min))
 879   (while (re-search-forward "[ \t\n]+" nil 0)
 880     (replace-match " " t t)))
 881
 882 (defun vm-fill-paragraphs-containing-long-lines (len start end)
 883   (let ((done nil)
 884         (buffer-read-only nil)
 885         (fill-column vm-paragraph-fill-column)
 886         ;; user doesn't want long lines, so set this to zero for them.
 887         (filladapt-fill-column-forward-fuzz 0))
 888     (save-excursion
 889       (vm-save-restriction
 890        (widen)
 891        (or (markerp end) (setq end (vm-marker end)))
 892        (goto-char start)
 893        (while (and (not done) (re-search-forward "[ \t]*$" end t))
 894          (replace-match "")
 895          (if (>= (current-column) len)
 896              ;; ignore errors
 897              (condition-case nil
 898                  (fill-paragraph nil)
 899                (error nil)))
 900          (forward-line)
 901          (setq done (>= (point) end)))))))
 902
 903 (defun vm-make-message-id ()
 904   (let (hostname
 905         (time (current-time)))
 906     (setq hostname (cond ((string-match "\\." (system-name))
 907                           (system-name))
 908                          ((and (stringp mail-host-address)
 909                                (string-match "\\." mail-host-address))
 910                           mail-host-address)
 911                          (t "gargle.gargle.HOWL")))
 912     (format "<%d.%d.%d.%d@%s>"
 913             (car time) (nth 1 time) (nth 2 time)
 914             (random 1000000)
 915             hostname)))
 916
 917 (defun vm-keep-some-buffers (buffer ring-variable number-to-keep)
 918   (if (memq buffer (symbol-value ring-variable))
 919       (set ring-variable (delq buffer (symbol-value ring-variable))))
 920   (set ring-variable (cons buffer (symbol-value ring-variable)))
 921   (set ring-variable (vm-delete 'buffer-name
 922                                 (symbol-value ring-variable) t))
 923   (if (not (eq number-to-keep t))
 924       (let ((extras (nthcdr (or number-to-keep 0)
 925                             (symbol-value ring-variable))))
 926         (mapcar (function
 927                  (lambda (b)
 928                    (and (buffer-name b)
 929                         (or (not (buffer-modified-p b))
 930                             (not (vm-buffer-variable-value
 931                                   b buffer-offer-save)))
 932                         (kill-buffer b))))
 933                 extras)
 934         (and (symbol-value ring-variable) extras
 935              (setcdr (memq (car extras) (symbol-value ring-variable))
 936                      nil)))))
 937
 938 (defvar enable-multibyte-characters)
 939 (defvar buffer-display-table)
 940 (defun vm-fsfemacs-nonmule-display-8bit-chars ()
 941   (cond ((and vm-fsfemacs-p
 942               (or (not vm-fsfemacs-mule-p)
 943                   (and (boundp 'enable-multibyte-characters)
 944                        (not enable-multibyte-characters))))
 945          (let* (tab (i 160))
 946            ;; We need the function make-display-table, but it is
 947            ;; in disp-table.el, which overwrites the value of
 948            ;; standard-display-table when it is loaded, which
 949            ;; sucks.  So here we cruftily copy just enough goop
 950            ;; out of disp-table.el so that a display table can be
 951            ;; created, and thereby avoid loading disp-table.
 952            (put 'display-table 'char-table-extra-slots 6)
 953            (setq tab (make-char-table 'display-table nil))
 954            (while (< i 256)
 955              (aset tab i (vector i))
 956              (setq i (1+ i)))
 957            (setq buffer-display-table tab)))))
 958
 959 (defun vm-url-decode-string (string)
 960   (vm-with-string-as-temp-buffer string 'vm-url-decode-buffer))
 961
 962 (defun vm-url-decode-buffer ()
 963   (let ((case-fold-search t)
 964         (hex-digit-alist '((?0 .  0)  (?1 .  1)  (?2 .  2)  (?3 .  3)
 965                            (?4 .  4)  (?5 .  5)  (?6 .  6)  (?7 .  7)
 966                            (?8 .  8)  (?9 .  9)  (?A . 10)  (?B . 11)
 967                            (?C . 12)  (?D . 13)  (?E . 14)  (?F . 15)
 968                            (?a . 10)  (?b . 11)  (?c . 12)  (?d . 13)
 969                            (?e . 14)  (?f . 15)))
 970         char)
 971     (save-excursion
 972       (goto-char (point-min))
 973       (while (re-search-forward "%[0-9A-F][0-9A-F]" nil t)
 974         (insert-char (+ (* (cdr (assq (char-after (- (point) 2))
 975                                       hex-digit-alist))
 976                            16)
 977                         (cdr (assq (char-after (- (point) 1))
 978                                    hex-digit-alist)))
 979                      1)
 980         (delete-region (- (point) 1) (- (point) 4))))))
 981
 982 (defun vm-process-sentinel-kill-buffer (process what-happened)
 983   (kill-buffer (process-buffer process)))
 984
 985 (defun vm-fsfemacs-scroll-bar-width ()
 986   (or vm-fsfemacs-cached-scroll-bar-width
 987       (let (size)
 988         (setq size (frame-pixel-width))
 989         (scroll-bar-mode nil)
 990         (setq size (- size (frame-pixel-width)))
 991         (scroll-bar-mode nil)
 992         (setq vm-fsfemacs-cached-scroll-bar-width size))))
 993
 994 (defvar vm-disable-modes-ignore nil
 995   "List of modes ignored by `vm-disable-modes'.
 996 Any mode causing an error while trying to disable it will be added to this
 997 list.  It still will try to diable it, but no error messages are generated
 998 anymore for it.")
 999
1000 (defun vm-disable-modes (&optional modes)
1001   "Disable the given minor modes.
1002 If MODES is nil the take the modes from the variable
1003 `vm-disable-modes-before-encoding'."
1004   (let (m)
1005     (while modes
1006       (setq m (car modes) modes (cdr modes))
1007       (condition-case errmsg
1008           (if (functionp m)
1009               (funcall m -1))
1010         (error
1011          (when (not (member m vm-disable-modes-ignore))
1012            (message "Could not disable mode `%S': %S" m errmsg)
1013            (setq vm-disable-modes-ignore (cons m vm-disable-modes-ignore)))
1014          nil)))))
1015
1016 (provide 'vm-misc)
1017
1018 ;;; vm-misc.el ends here