home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-misc.el < prev    next >
Encoding:
Text File  |  1991-04-10  |  8.8 KB  |  271 lines
  1. ;;; Miscellaneous functions for VM
  2. ;;; Copyright (C) 1989, 1990, 1991 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (defun vm-parse (string regexp &optional matchn)
  19.   (or matchn (setq matchn 1))
  20.   (let (list)
  21.     (store-match-data nil)
  22.     (while (string-match regexp string (match-end 0))
  23.       (setq list (cons (substring string (match-beginning matchn)
  24.                   (match-end matchn)) list)))
  25.     (nreverse list)))
  26.  
  27. (defun vm-parse-addresses (string)
  28.   (if (null string)
  29.       ()
  30.     (let (work-buffer)
  31.       (save-excursion
  32.        (unwind-protect
  33.        (let (list start s)
  34.          (setq work-buffer (generate-new-buffer "*VM parse*"))
  35.          (set-buffer work-buffer)
  36.          (insert string)
  37.          (goto-char (point-min))
  38.          (skip-chars-forward "\t\f\n\r ")
  39.          (setq start (point))
  40.          (while (not (eobp))
  41.            (skip-chars-forward "^\"\\,(")
  42.            (setq char (following-char))
  43.            (cond ((= char ?\\)
  44.               (forward-char 1)
  45.               (if (not (eobp))
  46.               (forward-char 1)))
  47.              ((= char ?,)
  48.               (setq s (buffer-substring start (point)))
  49.               (if (or (null (string-match "^[\t\f\n\r ]+$" s))
  50.                   (not (string= s "")))
  51.               (setq list (cons s list)))
  52.               (forward-char 1)
  53.               (skip-chars-forward "\t\f\n\r ")
  54.               (setq start (point)))
  55.              ((= char ?\")
  56.               (forward-char 1)
  57.               (re-search-forward "[^\\]\"" nil 0))
  58.              ((= char ?\()
  59.               (let ((parens 1))
  60.             (forward-char 1)
  61.             (while (and (not (eobp)) (not (zerop parens)))
  62.               (re-search-forward "[^\\][()]" nil 0)
  63.               (cond ((eobp))
  64.                 ((= (preceding-char) ?\()
  65.                  (setq parens (1+ parens)))
  66.                 ((= (preceding-char) ?\))
  67.                  (setq parens (1- parens)))))))))
  68.          (setq s (buffer-substring start (point)))
  69.          (if (and (null (string-match "^[\t\f\n\r ]+$" s))
  70.               (not (string= s "")))
  71.          (setq list (cons s list)))
  72.          list )
  73.     (and work-buffer (kill-buffer work-buffer)))))))
  74.  
  75. (defmacro vm-marker (pos &optional buffer)
  76.   (list 'set-marker '(make-marker) pos buffer))
  77.  
  78. (defmacro vm-increment (variable)
  79.   (list 'setq variable (list '1+ variable)))
  80.  
  81. (defmacro vm-decrement (variable)
  82.   (list 'setq variable (list '1- variable)))
  83.  
  84. (defmacro vm-select-folder-buffer ()
  85.   '(and vm-mail-buffer (buffer-name vm-mail-buffer)
  86.     (set-buffer vm-mail-buffer)))
  87.  
  88. (defmacro vm-check-for-killed-summary ()
  89.   '(and (bufferp vm-summary-buffer) (null (buffer-name vm-summary-buffer))
  90.     (setq vm-summary-buffer nil)))
  91.  
  92. (defmacro vm-error-if-folder-read-only ()
  93.   '(while vm-folder-read-only
  94.      (signal 'folder-read-only (list (current-buffer)))))
  95.  
  96. (put 'folder-read-only 'error-conditions '(folder-read-only error))
  97. (put 'folder-read-only 'error-message "Folder is read-only")
  98.  
  99. (defmacro vm-error-if-referenced-virtually ()
  100.   '(and (setq vm-virtual-buffers (vm-trim-dead-buffers vm-virtual-buffers))
  101.     (error "Can't execute command: folder is referenced virtually.")))
  102.  
  103. (defmacro vm-error-if-virtual-folder ()
  104.   '(and (eq major-mode 'vm-virtual-mode)
  105.     (error "%s cannot be applied to virtual folders." this-command)))
  106.  
  107. (defmacro vm-nuke-dead-virtual-buffers ()
  108.   '(setq vm-virtual-buffers (vm-trim-dead-buffers vm-virtual-buffers)))
  109.  
  110. (defmacro vm-check-message-clipping ()
  111.   '(and vm-virtual-buffers
  112.     (or (< (point-min) (vm-start-of (car vm-message-pointer)))
  113.         (> (point-max) (vm-text-end-of (car vm-message-pointer))))
  114.     (vm-preview-current-message)))
  115.  
  116. (defun vm-trim-dead-buffers (list)
  117.   (vm-delete 'buffer-name list t))
  118.  
  119. (defun vm-deferred-message (&rest args)
  120.   (setq vm-deferred-message (apply 'format args)))
  121.  
  122. (defun vm-abs (n) (if (< n 0) (- n) n))
  123.  
  124. (defun vm-read-number (prompt)
  125.   (let (result)
  126.     (while
  127.     (null
  128.      (string-match "^[ \t]*-?[0-9]+" (setq result (read-string prompt)))))
  129.     (string-to-int result)))
  130.  
  131. ;; save-restriction flubs restoring the clipping region if you
  132. ;; (widen) and modify text outside the old region.
  133. ;; This should do it right.
  134. (defmacro vm-save-restriction (&rest forms)
  135.   (let ((vm-sr-clip (make-symbol "vm-sr-clip"))
  136.     (vm-sr-min (make-symbol "vm-sr-min"))
  137.     (vm-sr-max (make-symbol "vm-sr-max")))
  138.     (list 'let (list (list vm-sr-clip '(> (buffer-size)
  139.                       (- (point-max) (point-min))))
  140.              ;; this shouldn't be necessary but the
  141.              ;; byte-compiler turns these into interned symbols
  142.              ;; which utterly defeats the purpose of the
  143.              ;; make-symbol calls above.  Soooo, until the compiler
  144.              ;; is fixed, these must be made into (let ...)
  145.              ;; temporaries so that nested calls to this macros
  146.              ;; won't misbehave.
  147.              vm-sr-min vm-sr-max)
  148.       (list 'and vm-sr-clip
  149.         (list 'setq vm-sr-min '(set-marker (make-marker) (point-min)))
  150.         (list 'setq vm-sr-max '(set-marker (make-marker) (point-max))))
  151.       (list 'unwind-protect (cons 'progn forms)
  152.         '(widen)
  153.         (list 'and vm-sr-clip
  154.               (list 'progn
  155.                 (list 'narrow-to-region vm-sr-min vm-sr-max)
  156.                 (list 'set-marker vm-sr-min nil)
  157.                 (list 'set-marker vm-sr-max nil)))))))
  158.  
  159. (defmacro vm-save-buffer-excursion (&rest forms)
  160.   (list 'let '((vm-sbe-buffer (current-buffer)))
  161.     (list 'unwind-protect
  162.           (cons 'progn forms)
  163.           '(and (not (eq vm-sbe-buffer (current-buffer)))
  164.             (buffer-name vm-sbe-buffer)
  165.             (set-buffer vm-sbe-buffer)))))
  166.  
  167. (defmacro vm-current-message-buffer ()
  168.   (list 'marker-buffer
  169.     (list 'vm-start-of
  170.           (list 'car 'vm-message-pointer))))
  171.  
  172. (defmacro vm-within-current-message-buffer (&rest forms)
  173.   (list 'let '((vm-sbe-buffer (current-buffer)))
  174.     '(and (eq major-mode 'vm-virtual-mode) vm-message-list
  175.           (set-buffer (marker-buffer (vm-start-of
  176.                       (car vm-message-pointer)))))
  177.     (list 'unwind-protect
  178.           (cons 'progn forms)
  179.           '(and (not (eq vm-sbe-buffer (current-buffer)))
  180.             (buffer-name vm-sbe-buffer)
  181.             (set-buffer vm-sbe-buffer)))))
  182.  
  183. (defun vm-last (list) (while (cdr-safe list) (setq list (cdr list))) list)
  184.  
  185. (defun vm-vector-to-list (vector)
  186.   (let ((i (1- (length vector)))
  187.     list)
  188.     (while (>= i 0)
  189.       (setq list (cons (aref vector i) list))
  190.       (vm-decrement i))
  191.     list ))
  192.  
  193. (defun vm-extend-vector (vector length &optional fill)
  194.   (let ((vlength (length vector)))
  195.     (if (< vlength length)
  196.     (apply 'vector (nconc (vm-vector-to-list vector)
  197.                   (make-list (- length vlength) fill)))
  198.       vector )))
  199.  
  200. (defun vm-mapcar (function &rest lists)
  201.   (let (arglist result)
  202.     (while (car lists)
  203.       (setq arglist (mapcar 'car lists))
  204.       (setq result (cons (apply function arglist) result))
  205.       (setq lists (mapcar 'cdr lists)))
  206.     (nreverse result)))
  207.  
  208. (defun vm-mapc (function &rest lists)
  209.   (let (arglist)
  210.     (while (car lists)
  211.       (setq arglist (mapcar 'car lists))
  212.       (apply function arglist)
  213.       (setq lists (mapcar 'cdr lists)))))
  214.  
  215. (defun vm-delete (predicate list &optional reverse)
  216.   (let ((p list) (reverse (if reverse 'not 'identity)) prev)
  217.     (while p
  218.       (if (funcall reverse (funcall predicate (car p)))
  219.       (if (null prev)
  220.           (setq list (cdr list) p list)
  221.         (setcdr prev (cdr p))
  222.         (setq p (cdr p)))
  223.     (setq prev p p (cdr p))))
  224.     list ))
  225.  
  226. (defun vm-delete-duplicates (list &optional all)
  227.   (setq list (sort list 'string<))
  228.   (let ((p list) prev)
  229.     (while p
  230.       (if (not (equal (car p) (car (cdr p))))
  231.       (setq prev p p (cdr p))
  232.     (setq p (cdr p))
  233.     (while (and p (equal (car p) (car (cdr p))))
  234.       (setq p (cdr p)))
  235.     (if (null prev)
  236.         (setq list (if all (cdr p) p)
  237.           prev (if all nil p)
  238.           p (cdr p))
  239.       (setcdr prev (if all (cdr p) p))
  240.       (setq p (cdr p)))))
  241.     list ))
  242.  
  243. (defun vm-copy-local-variables (buffer &rest variables)
  244.   (let ((values (mapcar 'symbol-value variables)))
  245.     (save-excursion
  246.       (set-buffer buffer)
  247.       (vm-mapc 'set variables values))))
  248.  
  249. (put 'folder-empty 'error-conditions '(folder-empty error))
  250. (put 'folder-empty 'error-message "Folder is empty")
  251.  
  252. (defun vm-error-if-folder-empty ()
  253.   (while (null vm-message-list)
  254.     (signal 'folder-empty nil)))
  255.  
  256. (defun vm-copy (object)
  257.   (cond ((consp object)
  258.      (let (return-value cons)
  259.        (setq return-value (cons (vm-copy (car object)) nil)
  260.          cons return-value
  261.          object (cdr object))
  262.        (while (consp object)
  263.          (setcdr cons (cons (vm-copy (car object)) nil))
  264.          (setq cons (cdr cons)
  265.            object (cdr object)))
  266.        (setcdr cons object)
  267.        return-value ))
  268.     ((vectorp object) (apply 'vector (mapcar 'vm-copy object)))
  269.     ((stringp object) (copy-sequence object))
  270.     (t object)))
  271.