root/trunk/lisp/emulation/viper-util.el

;;; viper-util.el --- Utilities used by viper.el

;; Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
;;   2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Michael Kifer <kifer@cs.stonybrook.edu>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;; Compiler pacifier
(defvar viper-overriding-map)
(defvar pm-color-alist)
(defvar zmacs-region-stays)
(defvar viper-minibuffer-current-face)
(defvar viper-minibuffer-insert-face)
(defvar viper-minibuffer-vi-face)
(defvar viper-minibuffer-emacs-face)
(defvar viper-replace-overlay-face)
(defvar viper-fast-keyseq-timeout)
(defvar ex-unix-type-shell)
(defvar ex-unix-type-shell-options)
(defvar viper-ex-tmp-buf-name)
(defvar viper-syntax-preference)
(defvar viper-saved-mark)

(require 'ring)

(if noninteractive
    (eval-when-compile
      (let ((load-path (cons (expand-file-name ".") load-path)))
        (or (featurep 'viper-init)
            (load "viper-init.el" nil nil 'nosuffix))
        )))
;; end pacifier

(require 'viper-init)


;; A fix for NeXT Step
;; Should go away, when NS people fix the design flaw, which leaves the
;; two x-* functions undefined.
(if (and (not (fboundp 'x-display-color-p)) (fboundp 'ns-display-color-p))
    (fset 'x-display-color-p (symbol-function 'ns-display-color-p)))
(if (and (not (fboundp 'x-color-defined-p)) (fboundp 'ns-color-defined-p))
      (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p)))


;;; XEmacs support


(viper-cond-compile-for-xemacs-or-emacs
 (progn ; xemacs
   (fset 'viper-overlay-p (symbol-function 'extentp))
   (fset 'viper-make-overlay (symbol-function 'make-extent))
   (fset 'viper-overlay-live-p (symbol-function 'extent-live-p))
   (fset 'viper-move-overlay (symbol-function 'set-extent-endpoints))
   (fset 'viper-overlay-start (symbol-function 'extent-start-position))
   (fset 'viper-overlay-end (symbol-function 'extent-end-position))
   (fset 'viper-overlay-get (symbol-function 'extent-property))
   (fset 'viper-overlay-put (symbol-function 'set-extent-property))
   (fset 'viper-read-event (symbol-function 'next-command-event))
   (fset 'viper-characterp (symbol-function 'characterp))
   (fset 'viper-int-to-char (symbol-function 'int-to-char))
   (if (viper-window-display-p)
       (fset 'viper-iconify (symbol-function 'iconify-frame)))
   (cond ((viper-has-face-support-p)
          (fset 'viper-get-face (symbol-function 'get-face))
          (fset 'viper-color-defined-p (symbol-function 'valid-color-name-p))
          )))
 (progn ; emacs
   (fset 'viper-overlay-p (symbol-function 'overlayp))
   (fset 'viper-make-overlay (symbol-function 'make-overlay))
   (fset 'viper-overlay-live-p (symbol-function 'overlayp))
   (fset 'viper-move-overlay (symbol-function 'move-overlay))
   (fset 'viper-overlay-start (symbol-function 'overlay-start))
   (fset 'viper-overlay-end (symbol-function 'overlay-end))
   (fset 'viper-overlay-get (symbol-function 'overlay-get))
   (fset 'viper-overlay-put (symbol-function 'overlay-put))
   (fset 'viper-read-event (symbol-function 'read-event))
   (fset 'viper-characterp (symbol-function 'integerp))
   (fset 'viper-int-to-char (symbol-function 'identity))
   (if (viper-window-display-p)
       (fset 'viper-iconify (symbol-function 'iconify-or-deiconify-frame)))
   (cond ((viper-has-face-support-p)
          (fset 'viper-get-face (symbol-function 'internal-get-face))
          (fset 'viper-color-defined-p (symbol-function 'x-color-defined-p))
          )))
 )



;; CHAR is supposed to be a char or an integer (positive or negative)
;; LIST is a list of chars, nil, and negative numbers
;; Check if CHAR is a member by trying to convert in characters, if necessary.
;; Introduced for compatibility with XEmacs, where integers are not the same as
;; chars.
(defun viper-memq-char (char list)
  (cond ((and (integerp char) (>= char 0))
         (memq (viper-int-to-char char) list))
        ((memq char list))))

;; Check if char-or-int and char are the same as characters
(defun viper-char-equal (char-or-int char)
  (cond ((and (integerp char-or-int) (>= char-or-int 0))
         (= (viper-int-to-char char-or-int) char))
        ((eq char-or-int char))))

;; Like =, but accommodates null and also is t for eq-objects
(defun viper= (char char1)
  (cond ((eq char char1) t)
        ((and (viper-characterp char) (viper-characterp char1))
         (= char char1))
        (t nil)))

(defsubst viper-color-display-p ()
  (viper-cond-compile-for-xemacs-or-emacs
   (eq (device-class (selected-device)) 'color) ; xemacs
   (x-display-color-p)  ; emacs
   ))

(defun viper-get-cursor-color (&optional frame)
  (viper-cond-compile-for-xemacs-or-emacs
   (color-instance-name
    (frame-property (or frame (selected-frame)) 'cursor-color)) ; xemacs
   (cdr (assoc 'cursor-color (frame-parameters))) ; emacs
   ))


;; OS/2
(cond ((eq (viper-device-type) 'pm)
       (fset 'viper-color-defined-p
             (lambda (color) (assoc color pm-color-alist)))))


;; cursor colors
(defun viper-change-cursor-color (new-color &optional frame)
  (if (and (viper-window-display-p)  (viper-color-display-p)
           (stringp new-color) (viper-color-defined-p new-color)
           (not (string= new-color (viper-get-cursor-color))))
      (viper-cond-compile-for-xemacs-or-emacs
       (set-frame-property
        (or frame (selected-frame))
        'cursor-color (make-color-instance new-color))
       (modify-frame-parameters
        (or frame (selected-frame))
        (list (cons 'cursor-color new-color)))
       )
    ))

(defun viper-set-cursor-color-according-to-state (&optional frame)
  (cond ((eq viper-current-state 'replace-state)
         (viper-change-cursor-color viper-replace-state-cursor-color frame))
        ((and (eq viper-current-state 'emacs-state)
              viper-emacs-state-cursor-color)
         (viper-change-cursor-color viper-emacs-state-cursor-color frame))
        ((eq viper-current-state 'insert-state)
         (viper-change-cursor-color viper-insert-state-cursor-color frame))
        (t
         (viper-change-cursor-color viper-vi-state-cursor-color frame))))

;; By default, saves current frame cursor color in the
;; viper-saved-cursor-color-in-replace-mode property of viper-replace-overlay
(defun viper-save-cursor-color (before-which-mode)
  (if (and (viper-window-display-p) (viper-color-display-p))
      (let ((color (viper-get-cursor-color)))
        (if (and (stringp color) (viper-color-defined-p color)
                 (not (string= color viper-replace-overlay-cursor-color)))
            (modify-frame-parameters
             (selected-frame)
             (list
              (cons
               (cond ((eq before-which-mode 'before-replace-mode)
                      'viper-saved-cursor-color-in-replace-mode)
                     ((eq before-which-mode 'before-emacs-mode)
                      'viper-saved-cursor-color-in-emacs-mode)
                     (t
                      'viper-saved-cursor-color-in-insert-mode))
               color)))
          ))))


(defsubst viper-get-saved-cursor-color-in-replace-mode ()
  (or
   (funcall
    (if viper-emacs-p 'frame-parameter 'frame-property)
    (selected-frame)
    'viper-saved-cursor-color-in-replace-mode)
   (if (and (eq viper-current-state 'emacs-mode) viper-emacs-state-cursor-color)
       viper-emacs-state-cursor-color
     viper-vi-state-cursor-color)))

(defsubst viper-get-saved-cursor-color-in-insert-mode ()
  (or
   (funcall
    (if viper-emacs-p 'frame-parameter 'frame-property)
    (selected-frame)
    'viper-saved-cursor-color-in-insert-mode)
   (if (and (eq viper-current-state 'emacs-mode) viper-emacs-state-cursor-color)
       viper-emacs-state-cursor-color
     viper-vi-state-cursor-color)))

(defsubst viper-get-saved-cursor-color-in-emacs-mode ()
  (or
   (funcall
    (if viper-emacs-p 'frame-parameter 'frame-property)
    (selected-frame)
    'viper-saved-cursor-color-in-emacs-mode)
   viper-vi-state-cursor-color))

;; restore cursor color from replace overlay
(defun viper-restore-cursor-color(after-which-mode)
  (if (viper-overlay-p viper-replace-overlay)
      (viper-change-cursor-color
       (cond ((eq after-which-mode 'after-replace-mode)
              (viper-get-saved-cursor-color-in-replace-mode))
             ((eq after-which-mode 'after-emacs-mode)
              (viper-get-saved-cursor-color-in-emacs-mode))
             (t (viper-get-saved-cursor-color-in-insert-mode)))
       )))


;; Check the current version against the major and minor version numbers
;; using op: cur-vers op major.minor If emacs-major-version or
;; emacs-minor-version are not defined, we assume that the current version
;; is hopelessly outdated.  We assume that emacs-major-version and
;; emacs-minor-version are defined.  Otherwise, for Emacs/XEmacs 19, if the
;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value
;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be
;; incorrect.  However, this gives correct result in our cases, since we are
;; testing for sufficiently high Emacs versions.
(defun viper-check-version (op major minor &optional type-of-emacs)
  (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version))
      (and (cond ((eq type-of-emacs 'xemacs) viper-xemacs-p)
                 ((eq type-of-emacs 'emacs) viper-emacs-p)
                 (t t))
           (cond ((eq op '=) (and (= emacs-minor-version minor)
                                  (= emacs-major-version major)))
                 ((memq op '(> >= < <=))
                  (and (or (funcall op emacs-major-version major)
                           (= emacs-major-version major))
                       (if (= emacs-major-version major)
                           (funcall op emacs-minor-version minor)
                         t)))
                 (t
                  (error "%S: Invalid op in viper-check-version" op))))
    (cond ((memq op '(= > >=)) nil)
          ((memq op '(< <=)) t))))


(defun viper-get-visible-buffer-window (wind)
  (if viper-xemacs-p
      (get-buffer-window wind t)
    (get-buffer-window wind 'visible)))


;; Return line position.
;; If pos is 'start then returns position of line start.
;; If pos is 'end, returns line end.  If pos is 'mid, returns line center.
;; Pos = 'indent returns beginning of indentation.
;; Otherwise, returns point.  Current point is not moved in any case."
(defun viper-line-pos (pos)
  (let ((cur-pos (point))
        (result))
    (cond
     ((equal pos 'start)
      (beginning-of-line))
     ((equal pos 'end)
      (end-of-line))
     ((equal pos 'mid)
      (goto-char (+ (viper-line-pos 'start) (viper-line-pos 'end) 2)))
     ((equal pos 'indent)
      (back-to-indentation))
     (t   nil))
    (setq result (point))
    (goto-char cur-pos)
    result))

;; Emacs used to count each multibyte character as several positions in the buffer,
;; so we had to use Emacs' chars-in-region to count characters. Since 20.3,
;; Emacs counts multibyte characters as 1 position.  XEmacs has always been
;; counting each char as just one pos. So, now we can simply subtract beg from
;; end to determine the number of characters in a region.
(defun viper-chars-in-region (beg end &optional preserve-sign)
  ;;(let ((count (abs (if (fboundp 'chars-in-region)
  ;;                    (chars-in-region beg end)
  ;;                  (- end beg)))))
  (let ((count (abs (- end beg))))
    (if (and (< end beg) preserve-sign)
        (- count)
      count)))

;; Test if POS is between BEG and END
(defsubst viper-pos-within-region (pos beg end)
  (and (>= pos (min beg end)) (>= (max beg end) pos)))


;; Like move-marker but creates a virgin marker if arg isn't already a marker.
;; The first argument must eval to a variable name.
;; Arguments: (var-name position &optional buffer).
;;
;; This is useful for moving markers that are supposed to be local.
;; For this, VAR-NAME should be made buffer-local with nil as a default.
;; Then, each time this var is used in `viper-move-marker-locally' in a new
;; buffer, a new marker will be created.
(defun viper-move-marker-locally (var pos &optional buffer)
  (if (markerp (eval var))
      ()
    (set var (make-marker)))
  (move-marker (eval var) pos buffer))


;; Print CONDITIONS as a message.
(defun viper-message-conditions (conditions)
  (let ((case (car conditions)) (msg (cdr conditions)))
    (if (null msg)
        (message "%s" case)
      (message "%s: %s" case (mapconcat 'prin1-to-string msg " ")))
    (beep 1)))



;;; List/alist utilities

;; Convert LIST to an alist
(defun viper-list-to-alist (lst)
  (let ((alist))
    (while lst
      (setq alist (cons (list (car lst)) alist))
      (setq lst (cdr lst)))
    alist))

;; Convert ALIST to a list.
(defun viper-alist-to-list (alst)
  (let ((lst))
    (while alst
      (setq lst (cons (car (car alst)) lst))
      (setq alst (cdr alst)))
    lst))

;; Filter ALIST using REGEXP.  Return alist whose elements match the regexp.
(defun viper-filter-alist (regexp alst)
  (interactive "s x")
  (let ((outalst) (inalst alst))
    (while (car inalst)
      (if (string-match regexp (car (car inalst)))
          (setq outalst (cons (car inalst) outalst)))
      (setq inalst (cdr inalst)))
    outalst))

;; Filter LIST using REGEXP.  Return list whose elements match the regexp.
(defun viper-filter-list (regexp lst)
  (interactive "s x")
  (let ((outlst) (inlst lst))
    (while (car inlst)
      (if (string-match regexp (car inlst))
          (setq outlst (cons (car inlst) outlst)))
      (setq inlst (cdr inlst)))
    outlst))


;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1
;; LIS2 is modified by filtering it: deleting its members of the form
;; \(car elt\) such that (car elt') is in LIS1.
(defun viper-append-filter-alist (lis1 lis2)
  (let ((temp lis1)
        elt)
    ;;filter-append the second list
    (while temp
      ;; delete all occurrences
      (while (setq elt (assoc (car (car temp)) lis2))
        (setq lis2 (delq elt lis2)))
      (setq temp (cdr temp)))

    (append lis1 lis2)))



;;; Support for :e, :r, :w file globbing

;; Glob the file spec.
;; This function is designed to work under Unix.  It might also work under VMS.
(defun viper-glob-unix-files (filespec)
  (let ((gshell
         (cond (ex-unix-type-shell shell-file-name)
               ((memq system-type '(vax-vms axp-vms)) "*dcl*") ; VAX VMS
               (t "sh"))) ; probably Unix anyway
        (gshell-options
         ;; using cond in anticipation of further additions
         (cond (ex-unix-type-shell-options)
               ))
        (command (cond (viper-ms-style-os-p (format "\"ls -1 -d %s\"" filespec))
                       (t (format "ls -1 -d %s" filespec))))
        status)
    (save-excursion
      (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
      (erase-buffer)
      (setq status
            (if gshell-options
                (call-process gshell nil t nil
                              gshell-options
                              "-c"
                              command)
              (call-process gshell nil t nil
                            "-c"
                            command)))
      (goto-char (point-min))
      ;; Issue an error, if no match.
      (unless (eq 0 status)
        (save-excursion
          (skip-chars-forward " \t\n\j")
          (if (looking-at "ls:")
              (viper-forward-Word 1))
          (error "%s: %s"
                 (if (stringp  gshell)
                     gshell
                   "shell")
                 (buffer-substring (point) (viper-line-pos 'end)))
          ))
      (goto-char (point-min))
      (viper-get-filenames-from-buffer 'one-per-line))
    ))


;; Interpret the stuff in the buffer as a list of file names
;; return a list of file names listed in the buffer beginning at point
;; If optional arg is supplied, assume each filename is listed on a separate
;; line
(defun viper-get-filenames-from-buffer (&optional one-per-line)
  (let ((skip-chars (if one-per-line "\t\n" " \t\n"))
         result fname delim)
    (skip-chars-forward skip-chars)
    (while (not (eobp))
      (if (cond ((looking-at "\"")
                 (setq delim ?\")
                 (re-search-forward "[^\"]+" nil t)) ; noerror
                ((looking-at "'")
                 (setq delim ?')
                 (re-search-forward "[^']+" nil t)) ; noerror
                (t
                 (re-search-forward
                  (concat "[^" skip-chars "]+") nil t))) ;noerror
          (setq fname
                (buffer-substring (match-beginning 0) (match-end 0))))
      (if delim
          (forward-char 1))
      (skip-chars-forward " \t\n")
      (setq result (cons fname result)))
    result))

;; convert MS-DOS wildcards to regexp
(defun viper-wildcard-to-regexp (wcard)
  (save-excursion
    (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
    (erase-buffer)
    (insert wcard)
    (goto-char (point-min))
    (while (not (eobp))
      (skip-chars-forward "^*?.\\\\")
      (cond ((eq (char-after (point)) ?*) (insert ".")(forward-char 1))
            ((eq (char-after (point)) ?.) (insert "\\")(forward-char 1))
            ((eq (char-after (point)) ?\\) (insert "\\")(forward-char 1))
            ((eq (char-after (point)) ??) (delete-char 1)(insert ".")))
      )
    (buffer-string)
    ))


;; glob windows files
;; LIST is expected to be in reverse order
(defun viper-glob-mswindows-files (filespec)
  (let ((case-fold-search t)
        tmp tmp2)
    (save-excursion
      (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
      (erase-buffer)
      (insert filespec)
      (goto-char (point-min))
      (setq tmp (viper-get-filenames-from-buffer))
      (while tmp
        (setq tmp2 (cons (directory-files
                          ;; the directory part
                          (or (file-name-directory (car tmp))
                              "")
                          t  ; return full names
                          ;; the regexp part: globs the file names
                          (concat "^"
                                  (viper-wildcard-to-regexp
                                   (file-name-nondirectory (car tmp)))
                                  "$"))
                         tmp2))
        (setq tmp (cdr tmp)))
      (reverse (apply 'append tmp2)))))


;;; Insertion ring

;; Rotate RING's index.  DIRection can be positive or negative.
(defun viper-ring-rotate1 (ring dir)
  (if (and (ring-p ring) (> (ring-length ring) 0))
      (progn
        (setcar ring (cond ((> dir 0)
                            (ring-plus1 (car ring) (ring-length ring)))
                           ((< dir 0)
                            (ring-minus1 (car ring) (ring-length ring)))
                           ;; don't rotate if dir = 0
                           (t (car ring))))
        (viper-current-ring-item ring)
        )))

(defun viper-special-ring-rotate1 (ring dir)
  (if (memq viper-intermediate-command
            '(repeating-display-destructive-command
              repeating-insertion-from-ring))
      (viper-ring-rotate1 ring dir)
    ;; don't rotate otherwise
    (viper-ring-rotate1 ring 0)))

;; current ring item; if N is given, then so many items back from the
;; current
(defun viper-current-ring-item (ring &optional n)
  (setq n (or n 0))
  (if (and (ring-p ring) (> (ring-length ring) 0))
      (aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring)))))

;; Push item onto ring.  The second argument is a ring-variable, not value.
(defun viper-push-onto-ring (item ring-var)
  (or (ring-p (eval ring-var))
      (set ring-var (make-ring (eval (intern (format "%S-size" ring-var))))))
  (or (null item) ; don't push nil
      (and (stringp item) (string= item "")) ; or empty strings
      (equal item (viper-current-ring-item (eval ring-var))) ; or old stuff
      ;; Since viper-set-destructive-command checks if we are inside
      ;; viper-repeat, we don't check whether this-command-keys is a `.'.  The
      ;; cmd viper-repeat makes a call to the current function only if `.' is
      ;; executing a command from the command history.  It doesn't call the
      ;; push-onto-ring function if `.' is simply repeating the last
      ;; destructive command.  We only check for ESC (which happens when we do
      ;; insert with a prefix argument, or if this-command-keys doesn't give
      ;; anything meaningful (in that case we don't know what to show to the
      ;; user).
      (and (eq ring-var 'viper-command-ring)
           (string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)"
                         (viper-array-to-string (this-command-keys))))
      (viper-ring-insert (eval ring-var) item))
  )


;; removing elts from ring seems to break it
(defun viper-cleanup-ring (ring)
  (or (< (ring-length ring) 2)
      (null (viper-current-ring-item ring))
      ;; last and previous equal
      (if (equal (viper-current-ring-item ring)
                 (viper-current-ring-item ring 1))
          (viper-ring-pop ring))))

;; ring-remove seems to be buggy, so we concocted this for our purposes.
(defun viper-ring-pop (ring)
  (let* ((ln (ring-length ring))
         (vec (cdr (cdr ring)))
         (veclen (length vec))
         (hd (car ring))
         (idx (max 0 (ring-minus1 hd ln)))
         (top-elt (aref vec idx)))

        ;; shift elements
        (while (< (1+ idx) veclen)
          (aset vec idx (aref vec (1+ idx)))
          (setq idx (1+ idx)))
        (aset vec idx nil)

        (setq hd (max 0 (ring-minus1 hd ln)))
        (if (= hd (1- ln)) (setq hd 0))
        (setcar ring hd) ; move head
        (setcar (cdr ring) (max 0 (1- ln))) ; adjust length
        top-elt
        ))

(defun viper-ring-insert (ring item)
  (let* ((ln (ring-length ring))
         (vec (cdr (cdr ring)))
         (veclen (length vec))
         (hd (car ring))
         (vecpos-after-hd (if (= hd 0) ln hd))
         (idx ln))

    (if (= ln veclen)
        (progn
          (aset vec hd item) ; hd is always 1+ the actual head index in vec
          (setcar ring (ring-plus1 hd ln)))
      (setcar (cdr ring) (1+ ln))
      (setcar ring (ring-plus1 vecpos-after-hd (1+ ln)))
      (while (and (>= idx vecpos-after-hd) (> ln 0))
        (aset vec idx (aref vec (1- idx)))
        (setq idx (1- idx)))
      (aset vec vecpos-after-hd item))
    item))


;;; String utilities

;; If STRING is longer than MAX-LEN, truncate it and print ...... instead
;; PRE-STRING is a string to prepend to the abbrev string.
;; POST-STRING is a string to append to the abbrev string.
;; ABBREV_SIGN is a string to be inserted before POST-STRING
;; if the orig string was truncated.
(defun viper-abbreviate-string (string max-len
                                     pre-string post-string abbrev-sign)
  (let (truncated-str)
    (setq truncated-str
          (if (stringp string)
              (substring string 0 (min max-len (length string)))))
    (cond ((null truncated-str) "")
          ((> (length string) max-len)
           (format "%s%s%s%s"
                   pre-string truncated-str abbrev-sign post-string))
          (t (format "%s%s%s" pre-string truncated-str post-string)))))

;; tells if we are over a whitespace-only line
(defsubst viper-over-whitespace-line ()
  (save-excursion
    (beginning-of-line)
    (looking-at "^[ \t]*$")))


;;; Saving settings in custom file

;; Save the current setting of VAR in CUSTOM-FILE.
;; If given, MESSAGE is a message to be displayed after that.
;; This message is erased after 2 secs, if erase-msg is non-nil.
;; Arguments: var message custom-file &optional erase-message
(defun viper-save-setting (var message custom-file &optional erase-msg)
  (let* ((var-name (symbol-name var))
         (var-val (if (boundp var) (eval var)))
         (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name))
         (buf (find-file-noselect (substitute-in-file-name custom-file)))
        )
    (message message)
    (save-excursion
      (set-buffer buf)
      (goto-char (point-min))
      (if (re-search-forward regexp nil t)
          (let ((reg-end (1- (match-end 0))))
            (search-backward var-name)
            (delete-region (match-beginning 0) reg-end)
            (goto-char (match-beginning 0))
            (insert (format "%s  '%S" var-name var-val)))
        (goto-char (point-max))
        (if (not (bolp)) (insert "\n"))
        (insert (format "(setq %s '%S)\n" var-name var-val)))
      (save-buffer))
      (kill-buffer buf)
      (if erase-msg
          (progn
            (sit-for 2)
            (message "")))
      ))

;; Save STRING in CUSTOM-FILE.  If PATTERN is non-nil, remove strings that
;; match this pattern.
(defun viper-save-string-in-file (string custom-file &optional pattern)
  (let ((buf (find-file-noselect (substitute-in-file-name custom-file))))
    (save-excursion
      (set-buffer buf)
      (let (buffer-read-only)
        (goto-char (point-min))
        (if pattern (delete-matching-lines pattern))
        (goto-char (point-max))
        (if string (insert string))
        (save-buffer)))
    (kill-buffer buf)
    ))


;; define remote file test
(defun viper-file-remote-p (file-name)
  (file-remote-p file-name))


;; This is a simple-minded check for whether a file is under version control.
;; If file,v exists but file doesn't, this file is considered to be not checked
;; in and not checked out for the purpose of patching (since patch won't be
;; able to read such a file anyway).
;; FILE is a string representing file name
;;(defun viper-file-under-version-control (file)
;;  (let* ((filedir (file-name-directory file))
;;       (file-nondir (file-name-nondirectory file))
;;       (trial (concat file-nondir ",v"))
;;       (full-trial (concat filedir trial))
;;       (full-rcs-trial (concat filedir "RCS/" trial)))
;;    (and (stringp file)
;;       (file-exists-p file)
;;       (or
;;        (and
;;         (file-exists-p full-trial)
;;         ;; in FAT FS, `file,v' and `file' may turn out to be the same!
;;         ;; don't be fooled by this!
;;         (not (equal (file-attributes file)
;;                     (file-attributes full-trial))))
;;        ;; check if a version is in RCS/ directory
;;        (file-exists-p full-rcs-trial)))
;;       ))


(defsubst viper-file-checked-in-p (file)
  (and (featurep 'vc-hooks)
       ;; CVS files are considered not checked in
       (not (memq (vc-backend file) '(nil CVS)))
       (if (fboundp 'vc-state)
           (and
             (not (memq (vc-state file) '(edited needs-merge)))
             (not (stringp (vc-state file))))
         ;; XEmacs has no vc-state
         (not (vc-locking-user file)))
       ))

;; checkout if visited file is checked in
(defun viper-maybe-checkout (buf)
  (let ((file (expand-file-name (buffer-file-name buf)))
        (checkout-function (key-binding "\C-x\C-q")))
    (if (and (viper-file-checked-in-p file)
             (or (beep 1) t)
             (y-or-n-p
              (format
               "File %s is checked in.  Check it out? "
               (viper-abbreviate-file-name file))))
        (with-current-buffer buf
          (command-execute checkout-function)))))




;;; Overlays
(defun viper-put-on-search-overlay (beg end)
  (if (viper-overlay-p viper-search-overlay)
      (viper-move-overlay viper-search-overlay beg end)
    (setq viper-search-overlay (viper-make-overlay beg end (current-buffer)))
    (viper-overlay-put
     viper-search-overlay 'priority viper-search-overlay-priority))
  (viper-overlay-put viper-search-overlay 'face viper-search-face))

;; Search

(defun viper-flash-search-pattern ()
  (if (not (viper-has-face-support-p))
      nil
    (viper-put-on-search-overlay (match-beginning 0) (match-end 0))
    (sit-for 2)
    (viper-overlay-put viper-search-overlay 'face nil)))

(defun viper-hide-search-overlay ()
  (if (not (viper-overlay-p viper-search-overlay))
      (progn
        (setq viper-search-overlay
              (viper-make-overlay (point-min) (point-min) (current-buffer)))
        (viper-overlay-put
         viper-search-overlay 'priority viper-search-overlay-priority)))
  (viper-overlay-put viper-search-overlay 'face nil))

;; Replace state

(defsubst viper-move-replace-overlay (beg end)
  (viper-move-overlay viper-replace-overlay beg end))

(defun viper-set-replace-overlay (beg end)
  (if (viper-overlay-live-p viper-replace-overlay)
      (viper-move-replace-overlay beg end)
    (setq viper-replace-overlay (viper-make-overlay beg end (current-buffer)))
    ;; never detach
    (viper-overlay-put
     viper-replace-overlay (if viper-emacs-p 'evaporate 'detachable) nil)
    (viper-overlay-put
     viper-replace-overlay 'priority viper-replace-overlay-priority)
    ;; If Emacs will start supporting overlay maps, as it currently supports
    ;; text-property maps, we could do away with viper-replace-minor-mode and
    ;; just have keymap attached to replace overlay.
    ;;(viper-overlay-put
    ;; viper-replace-overlay
    ;; (if viper-xemacs-p 'keymap 'local-map)
    ;; viper-replace-map)
    )
  (if (viper-has-face-support-p)
      (viper-overlay-put
       viper-replace-overlay 'face viper-replace-overlay-face))
  (viper-save-cursor-color 'before-replace-mode)
  (viper-change-cursor-color viper-replace-overlay-cursor-color)
  )


(defun viper-set-replace-overlay-glyphs (before-glyph after-glyph)
  (or (viper-overlay-live-p viper-replace-overlay)
      (viper-set-replace-overlay (point-min) (point-min)))
  (if (or (not (viper-has-face-support-p))
          viper-use-replace-region-delimiters)
      (let ((before-name (if viper-xemacs-p 'begin-glyph 'before-string))
            (after-name (if viper-xemacs-p 'end-glyph 'after-string)))
        (viper-overlay-put viper-replace-overlay before-name before-glyph)
        (viper-overlay-put viper-replace-overlay after-name after-glyph))))

(defun viper-hide-replace-overlay ()
  (viper-set-replace-overlay-glyphs nil nil)
  (viper-restore-cursor-color 'after-replace-mode)
  (viper-restore-cursor-color 'after-insert-mode)
  (if (viper-has-face-support-p)
      (viper-overlay-put viper-replace-overlay 'face nil)))


(defsubst viper-replace-start ()
  (viper-overlay-start viper-replace-overlay))
(defsubst viper-replace-end ()
  (viper-overlay-end viper-replace-overlay))


;; Minibuffer

(defun viper-set-minibuffer-overlay ()
  (viper-check-minibuffer-overlay)
  (if (viper-has-face-support-p)
      (progn
        (viper-overlay-put
         viper-minibuffer-overlay 'face viper-minibuffer-current-face)
        (viper-overlay-put
         viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority)
        ;; never detach
        (viper-overlay-put
         viper-minibuffer-overlay
         (if viper-emacs-p 'evaporate 'detachable)
         nil)
        ;; make viper-minibuffer-overlay open-ended
        ;; In emacs, it is made open ended at creation time
        (if viper-xemacs-p
            (progn
              (viper-overlay-put viper-minibuffer-overlay 'start-open nil)
              (viper-overlay-put viper-minibuffer-overlay 'end-open nil)))
        )))

(defun viper-check-minibuffer-overlay ()