(vip-event-key): now handles keys 128--255 as meta-chars.

Changed vip-*-frame-* to *-frame-*, incorporated overlay strings,
unread-command-events, removed support for emacs versions 19.28 and
xemacs 19.11 and earlier.

1 files changed, 117 insertions, 91 deletions

diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el
index 542b0523494..3a0962d47b2 100644
--- a/lisp/emulation/viper-util.el
+++ b/lisp/emulation/viper-util.el
@@ -1,6 +1,5 @@
 ;;; viper-util.el --- Utilities used by viper.el
-
-;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
 
 ;; This file is part of GNU Emacs.
 
@@ -20,10 +19,18 @@
 
 (require 'ring)
 
-(defconst vip-xemacs-p (string-match "\\(Lucid\\|Xemacs\\)" emacs-version)
-  "Whether it is XEmacs or not.")
-(defconst vip-emacs-p (not vip-xemacs-p)
-  "Whether it is Emacs or not.")
+;; Whether it is XEmacs or not
+(defconst vip-xemacs-p (string-match "\\(Lucid\\|Xemacs\\)" emacs-version))
+;; Whether it is Emacs or not
+(defconst vip-emacs-p (not vip-xemacs-p))
+;; Tell whether we are running as a window application or on a TTY
+(defsubst vip-device-type ()
+  (if vip-emacs-p
+      window-system
+    (device-type (selected-device))))
+;; in XEmacs: device-type is tty on tty and stream in batch.
+(defsubst vip-window-display-p ()
+  (and (vip-device-type) (not (memq (vip-device-type) '(tty stream)))))
 
 
 ;;; Macros
@@ -92,8 +99,9 @@
           (and (<= ?A reg) (<= reg ?Z)))
       ))
       
+;; checks if object is a marker, has a buffer, and points to within that buffer
 (defun vip-valid-marker (marker)
-  (if (markerp marker)
+  (if (and (markerp marker) (marker-buffer marker))
       (let ((buf (marker-buffer marker))
             (pos (marker-position marker)))
         (save-excursion
@@ -118,23 +126,13 @@
       (fset 'vip-overlay-p (symbol-function 'extentp))
       (fset 'vip-overlay-get (symbol-function 'extent-property))
       (fset 'vip-move-overlay (symbol-function 'set-extent-endpoints))
-      (if window-system
-          (fset 'vip-iconify (symbol-function 'iconify-screen)))
-      (fset 'vip-raise-frame (symbol-function 'raise-screen))
-      (fset 'vip-window-frame (symbol-function 'window-screen))
-      (fset 'vip-select-frame (symbol-function 'select-screen))
-      (fset 'vip-selected-frame (symbol-function 'selected-screen))
-      (fset 'vip-frame-selected-window
-            (symbol-function 'screen-selected-window))
-      (fset 'vip-frame-parameters (symbol-function 'screen-parameters))
-      (fset 'vip-modify-frame-parameters
-            (symbol-function 'modify-screen-parameters))
-      (cond (window-system
+      (if (vip-window-display-p)
+          (fset 'vip-iconify (symbol-function 'iconify-frame)))
+      (cond ((vip-window-display-p)
              (fset 'vip-get-face (symbol-function 'get-face))
              (fset 'vip-color-defined-p
-                   (symbol-function 'x-valid-color-name-p))
-             (fset 'vip-display-color-p
-                   (symbol-function 'x-color-display-p)))))
+                   (symbol-function 'valid-color-name-p))
+             )))
   (fset 'vip-read-event (symbol-function 'read-event))
   (fset 'vip-make-overlay (symbol-function 'make-overlay))
   (fset 'vip-overlay-start (symbol-function 'overlay-start))
@@ -143,23 +141,20 @@
   (fset 'vip-overlay-p (symbol-function 'overlayp))
   (fset 'vip-overlay-get (symbol-function 'overlay-get))
   (fset 'vip-move-overlay (symbol-function 'move-overlay))
-  (if window-system
+  (if (vip-window-display-p)
       (fset 'vip-iconify (symbol-function 'iconify-or-deiconify-frame)))
-  (fset 'vip-raise-frame (symbol-function 'raise-frame))
-  (fset 'vip-window-frame (symbol-function 'window-frame))
-  (fset 'vip-select-frame (symbol-function 'select-frame))
-  (fset 'vip-selected-frame (symbol-function 'selected-frame))
-  (fset 'vip-frame-selected-window (symbol-function 'frame-selected-window))
-  (fset 'vip-frame-parameters (symbol-function 'frame-parameters))
-  (fset 'vip-modify-frame-parameters
-        (symbol-function 'modify-frame-parameters))
-  (cond (window-system
+  (cond ((vip-window-display-p)
          (fset 'vip-get-face (symbol-function 'internal-get-face))
          (fset 'vip-color-defined-p (symbol-function 'x-color-defined-p))
-         (fset 'vip-display-color-p (symbol-function 'x-display-color-p)))))
+         )))
+
+(defsubst vip-color-display-p ()
+  (if vip-emacs-p
+      (x-display-color-p)
+    (eq (device-class (selected-device)) 'color)))
   
 ;; OS/2
-(cond ((eq window-system 'pm)
+(cond ((eq (vip-device-type) 'pm)
        (fset 'vip-color-defined-p
              (function (lambda (color) (assoc color pm-color-alist))))))
     
@@ -171,20 +166,21 @@
     
 ;; test if display is color and the colors are defined
 (defsubst vip-can-use-colors (&rest colors)
-  (if (vip-display-color-p)
+  (if (vip-color-display-p)
       (not (memq nil (mapcar 'vip-color-defined-p colors)))
     ))
 
 ;; currently doesn't work for XEmacs
 (defun vip-change-cursor-color (new-color)
-  (if (and window-system  (vip-display-color-p)
-           (stringp new-color) (vip-color-defined-p new-color))
-      (vip-modify-frame-parameters
-       (vip-selected-frame) (list (cons 'cursor-color new-color)))))
+  (if (and (vip-window-display-p)  (vip-color-display-p)
+           (stringp new-color) (vip-color-defined-p new-color)
+           (not (string= new-color (vip-get-cursor-color))))
+      (modify-frame-parameters
+       (selected-frame) (list (cons 'cursor-color new-color)))))
          
 (defsubst vip-save-cursor-color ()
-  (if (and window-system (vip-display-color-p))
-      (let ((color (cdr (assoc 'cursor-color (vip-frame-parameters)))))
+  (if (and (vip-window-display-p) (vip-color-display-p))
+      (let ((color (vip-get-cursor-color)))
         (if (and (stringp color) (vip-color-defined-p color)
                  (not (string= color vip-replace-overlay-cursor-color)))
             (vip-overlay-put vip-replace-overlay 'vip-cursor-color color)))))
@@ -192,6 +188,9 @@
 (defsubst vip-restore-cursor-color ()
   (vip-change-cursor-color
    (vip-overlay-get vip-replace-overlay 'vip-cursor-color)))
+   
+(defsubst vip-get-cursor-color ()
+  (cdr (assoc 'cursor-color (frame-parameters))))
          
 
 ;; Check the current version against the major and minor version numbers
@@ -220,20 +219,31 @@
                   (error "%S: Invalid op in vip-check-version" op))))
     (cond ((memq op '(= > >=)) nil)
           ((memq op '(< <=)) t))))
-  
-    
-;; Early versions of XEmacs didn't have window-live-p (or it didn't work right)
-(if (vip-check-version '< 19 11 'xemacs)
-    (defun window-live-p (win)
-      (let ((visible nil))
-        (walk-windows
-         '(lambda (walk-win)
-            (if(equal walk-win win)
-                (setq visible t)))
-         nil 'all-screens)
-        visible))
-  )
+          
+;; warn if it is a wrong emacs
+(if (or (vip-check-version '< 19 29 'emacs)
+        (vip-check-version '< 19 12 'xemacs))
+    (progn
+      (with-output-to-temp-buffer " *vip-info*"
+        (switch-to-buffer " *vip-info*")
+        (insert
+         (format "
+
+This version of Viper requires 
+
+\t Emacs 19.29 and higher
+\t OR
+\t XEmacs 19.12 and higher
+
+It is unlikely to work under Emacs version %s
+that you are using...
 
+Type any key to continue..." emacs-version))
+        (beep 1)
+        (beep 1)
+        (vip-read-event))
+      (kill-buffer " *vip-info*")))
+  
 
 (defun vip-get-visible-buffer-window (wind)
   (if vip-xemacs-p
@@ -241,12 +251,12 @@
     (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 vip-line-pos (pos)
-  "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."
   (let ((cur-pos (point))
         (result))
     (cond
@@ -264,50 +274,51 @@ Otherwise, returns point. Current point is not moved in any case."
     result))
 
 
+;; 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 `vip-move-marker-locally' in a new
+;; buffer, a new marker will be created.
 (defun vip-move-marker-locally (var pos &optional buffer)
-  "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 `vip-move-marker-locally' in a new
-buffer, a new marker will be created."
   (if (markerp (eval var))
       ()
     (set var (make-marker)))
   (move-marker (eval var) pos buffer))
 
 
+;; Print CONDITIONS as a message.
 (defun vip-message-conditions (conditions)
-  "Print CONDITIONS as a message."
   (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 vip-list-to-alist (lst)
-  "Convert LIST to an alist."
   (let ((alist))
     (while lst
       (setq alist (cons (list (car lst)) alist))
       (setq lst (cdr lst)))
     alist))     
 
+;; Convert ALIST to a list.
 (defun vip-alist-to-list (alst)
-  "Convert ALIST to a list."
   (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 vip-filter-alist (regexp alst)
-  "Filter ALIST using REGEXP. Return alist whose elements match the regexp."
   (interactive "s x")
   (let ((outalst) (inalst alst))
     (while (car inalst)
@@ -316,8 +327,8 @@ buffer, a new marker will be created."
       (setq inalst (cdr inalst)))
     outalst))    
        
+;; Filter LIST using REGEXP. Return list whose elements match the regexp.
 (defun vip-filter-list (regexp lst)
-  "Filter LIST using REGEXP. Return list whose elements match the regexp."
   (interactive "s x")
   (let ((outlst) (inlst lst))
     (while (car inlst)
@@ -472,11 +483,11 @@ buffer, a new marker will be created."
 
 ;;; 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 vip-save-setting (var message custom-file &optional erase-msg)
-  "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: (vip-save-setting var message custom-file &optional erase-message)"
   (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))
@@ -530,7 +541,7 @@ Arguments: (vip-save-setting var message custom-file &optional erase-message)"
            (match-beginning 0) (match-end 0) (current-buffer))))
   
   (vip-overlay-put vip-search-overlay 'priority vip-search-overlay-priority)
-  (if window-system
+  (if (vip-window-display-p)
       (progn
         (vip-overlay-put vip-search-overlay 'face vip-search-face)
         (sit-for 2)
@@ -552,7 +563,7 @@ Arguments: (vip-save-setting var message custom-file &optional erase-message)"
                                   (vip-overlay-end vip-replace-overlay)))
     (vip-overlay-put 
      vip-replace-overlay 'priority vip-replace-overlay-priority)) 
-  (if window-system
+  (if (vip-window-display-p)
       (vip-overlay-put vip-replace-overlay 'face vip-replace-overlay-face))
   (vip-save-cursor-color)
   (vip-change-cursor-color vip-replace-overlay-cursor-color)
@@ -560,10 +571,18 @@ Arguments: (vip-save-setting var message custom-file &optional erase-message)"
   
   
 (defsubst vip-hide-replace-overlay ()
+  (vip-set-replace-overlay-glyphs nil nil)
   (vip-restore-cursor-color)
-  (if window-system
+  (if (vip-window-display-p)
       (vip-overlay-put vip-replace-overlay 'face nil)))
-
+      
+(defsubst vip-set-replace-overlay-glyphs (before-glyph after-glyph)
+  (if (or (not (vip-window-display-p))
+           vip-use-replace-region-delimiters)
+      (let ((before-name (if vip-xemacs-p 'begin-glyph 'before-string))
+            (after-name (if vip-xemacs-p 'end-glyph 'after-string)))
+        (vip-overlay-put vip-replace-overlay before-name before-glyph)
+        (vip-overlay-put vip-replace-overlay after-name after-glyph))))
 
     
 (defsubst vip-replace-start ()
@@ -583,10 +602,10 @@ Arguments: (vip-save-setting var message custom-file &optional erase-message)"
   (vip-check-minibuffer-overlay)
   ;; We always move the minibuffer overlay, since in XEmacs
   ;; this overlay may get detached. Moving will reattach it.
-  ;; This overlay is also moved via the post-command-hook,
-  ;; to insure taht it covers the whole minibuffer.
+  ;; This overlay is also moved via the vip-post-command-hook,
+  ;; to insure that it covers the whole minibuffer.
   (vip-move-minibuffer-overlay)
-  (if window-system
+  (if (vip-window-display-p)
       (progn
         (vip-overlay-put
          vip-minibuffer-overlay 'face vip-minibuffer-current-face)
@@ -616,8 +635,8 @@ Arguments: (vip-save-setting var message custom-file &optional erase-message)"
 
 ;;; XEmacs compatibility
     
-;; Sit for VAL miliseconds. XEmacs doesn't support the milisecond arg to
-;; sit-for, so this is for compatibility.
+;; Sit for VAL miliseconds. XEmacs doesn't support the millisecond arg 
+;; in sit-for, so this function smoothes out the differences.
 (defsubst vip-sit-for-short (val &optional nodisp)
   (if vip-xemacs-p
       (sit-for (/ val 1000.0) nodisp)
@@ -677,7 +696,7 @@ Arguments: (vip-save-setting var message custom-file &optional erase-message)"
     ))
 
 
-;; Enacs has a bug in eventp, which causes (eventp nil) to return (nil)
+;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
 ;; instead of nil, if '(nil) was previously inadvertantly assigned to
 ;; unread-command-events
 (defun vip-event-key (event)
@@ -691,17 +710,24 @@ Arguments: (vip-save-setting var message custom-file &optional erase-message)"
             (cond ((key-press-event-p event)
                    (event-key event))
                   ((button-event-p event)
-                   (concat "mouse-" (event-button event)))
+                   (concat "mouse-" (prin1-to-string (event-button event))))
                   (t 
                    (error "vip-event-key: Unknown event, %S" event))))
            (t 
             ;; Emacs doesn't handle capital letters correctly, since
             ;; \S-a isn't considered the same as A (it behaves as
             ;; plain `a' instead). So we take care of this here
-            (if (and (numberp event) (<= ?A event) (<= event ?Z))
-                (setq mod nil
-                      event event)
-              (event-basic-type event)))))
+            (cond ((and (numberp event) (<= ?A event) (<= event ?Z))
+                   (setq mod nil
+                         event event))
+                  ;; Emacs has the oddity whereby characters 128+char
+                  ;; represent M-char *if* this appears inside a string.
+                  ;; So, we convert them manually into (mata char).
+                  ((and (numberp event) (< ?\C-? event) (<= event 255))
+                   (setq mod '(meta)
+                         event (- event ?\C-? 1)))
+                  (t (event-basic-type event)))
+            )))
     
     (if (numberp basis)
         (setq basis