comparison lisp/emulation/viper-util.el @ 85972:51aa47312c4b

* ediff-init.el (ediff-xemacs-p, ediff-emacs-p): Remove. (ediff-has-face-support-p, ediff-BAD-INFO, ediff-check-version) (ediff-current-diff-A, ediff-current-diff-B) (ediff-current-diff-C, ediff-fine-diff-C, ediff-fine-diff-A) (ediff-fine-diff-B, ediff-fine-diff-Ancestor, ediff-even-diff-A) (ediff-even-diff-B, ediff-even-diff-C, ediff-even-diff-Ancestor) (ediff-odd-diff-A, ediff-odd-diff-B, ediff-odd-diff-C) (ediff-odd-diff-Ancestor, ediff-reset-mouse): * ediff-wind.el (ediff-narrow-control-frame-leftward-shift) (ediff-setup-windows-plain-merge) (ediff-setup-windows-plain-compare, ediff-setup-control-frame) (ediff-refresh-control-frame, ediff-get-visible-buffer-window): * ediff-util.el (ediff-setup-keymap, ) (ediff-toggle-wide-display, ediff-toggle-multiframe) (ediff-toggle-use-toolbar, ediff-really-quit) (ediff-good-frame-under-mouse) (ediff-highlight-diff-in-one-buffer) (ediff-remove-flags-from-buffer, ediff-place-flags-in-buffer1) (ediff-make-bullet-proof-overlay): * ediff-mult.el (ediff-setup-meta-map, ediff-emacs-p) (ediff-set-meta-overlay): * ediff-help.el (ediff-help-region-map, ediff-set-help-overlays): * ediff.el (ediff-documentation): Replace ediff-xemacs-p and ediff-emacs-p with their former definitions. * emulation/viper-init.el (viper-xemacs-p, viper-emacs-p): Remove. (viper-has-face-support-p, viper-inactivate-input-method) (viper-activate-input-method) (viper-use-replace-region-delimiters, viper-restore-cursor-type): * emulation/viper-mous.el (viper-multiclick-timeout) (viper-surrounding-word, viper-mouse-click-insert-word) (viper-mouse-click-search-word, viper-parse-mouse-key): * emulation/viper-macs.el (viper-char-array-to-macro): * emulation/viper.el (viper-go-away, viper-set-hooks) (viper-non-hook-settings): * emulation/viper-util.el (viper-get-saved-cursor-color-in-replace-mode) (viper-get-saved-cursor-color-in-insert-mode) (viper-get-saved-cursor-color-in-emacs-mode) (viper-check-version, viper-get-visible-buffer-window) (viper-file-checked-in-p, viper-set-replace-overlay) (viper-set-replace-overlay-glyphs, viper-set-minibuffer-overlay) (viper-check-minibuffer-overlay, viper-read-key-sequence) (viper-key-to-emacs-key): Replace viper-xemacs-p and viper-emacs-p with their former definitions. (viper-eventify-list-xemacs): Only do work for XEmacs. (viper-set-unread-command-events): Only do work for Emacs. (viper-overlay-p, viper-make-overlay, viper-overlay-live-p) (viper-move-overlay, viper-overlay-start, viper-overlay-end) (viper-overlay-get, viper-overlay-put, viper-read-event) (viper-characterp, viper-int-to-char, viper-get-face) (viper-color-defined-p, viper-iconify): New defaliases replacing the old fsets. * progmodes/fortran.el (comment-region-function) (uncomment-region-function): Pacify byte compiler. * vc.el (vc-diff-internal): Remove code for an old version of gnus.

85971:2e692f327278

    (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.

(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

;; 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)

    (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.

(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)))

  (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))

(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-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)))
	)))

      (viper-move-overlay
       viper-minibuffer-overlay
       (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
       (1+ (buffer-size)))
    (setq viper-minibuffer-overlay
	  (if viper-xemacs-p
	      (viper-make-overlay 1 (1+ (buffer-size)) (current-buffer))
	    ;; make overlay open-ended
	    (viper-make-overlay
	     (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
	     (1+ (buffer-size))

;; Viperized read-key-sequence
(defun viper-read-key-sequence (prompt &optional continue-echo)
  (let (inhibit-quit event keyseq)
    (setq keyseq (read-key-sequence prompt continue-echo))
    (setq event (if viper-xemacs-p
		    (elt keyseq 0) ; XEmacs returns vector of events
		  (elt (listify-key-sequence keyseq) 0)))
    (if (viper-ESC-event-p event)
	(let (unread-command-events)
	  (if (viper-fast-keysequence-p)

	  (append mod (list basis))
	basis))))

(defun viper-key-to-emacs-key (key)
  (let (key-name char-p modifiers mod-char-list base-key base-key-name)
    (cond (viper-xemacs-p key)

	  ((symbolp key)
	   (setq key-name (symbol-name key))
	   (cond ((= (length key-name) 1) ; character event
		  (string-to-char key-name))
		 ;; Emacs doesn't recognize `return' and `escape' as events on
		 ;; dumb terminals, so we translate them into characters
		 ((and viper-emacs-p (not (viper-window-display-p))
		       (string= key-name "return"))
		  ?\C-m)
		 ((and viper-emacs-p (not (viper-window-display-p))
		       (string= key-name "escape"))
		  ?\e)
		 ;; pass symbol-event as is
		 (t key)))

    ))


;; LIS is assumed to be a list of events of characters
(defun viper-eventify-list-xemacs (lis)
  (mapcar
   (lambda (elt)
     (cond ((viper-characterp elt) (character-to-event elt))
	   ((eventp elt)  elt)
	   (t (error
	       "viper-eventify-list-xemacs: can't convert to event, %S"
	       elt))))
   lis))


;; Smoothes out the difference between Emacs' unread-command-events
;; and XEmacs unread-command-event.  Arg is a character, an event, a list of
;; events or a sequence of keys.

;; Due to the way unread-command-events in Emacs (not XEmacs), a non-event
;; symbol in unread-command-events list may cause Emacs to turn this symbol
;; into an event.  Below, we delete nil from event lists, since nil is the most
;; common symbol that might appear in this wrong context.
(defun viper-set-unread-command-events (arg)
  (if viper-emacs-p
      (setq
       unread-command-events
       (let ((new-events
	      (cond ((eventp arg) (list arg))
		    ((listp arg) arg)

85972:51aa47312c4b

    (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)))


(defalias 'viper-overlay-p 
  (if (featurep 'xemacs) 'extentp 'overlayp))
(defalias 'viper-make-overlay 
  (if (featurep 'xemacs) 'make-extent 'make-overlay))
(defalias 'viper-overlay-live-p 
  (if (featurep 'xemacs) 'extent-live-p 'overlayp))
(defalias 'viper-move-overlay 
  (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay))
(defalias 'viper-overlay-start 
  (if (featurep 'xemacs) 'extent-start-position 'overlay-start))
(defalias 'viper-overlay-end 
  (if (featurep 'xemacs) 'extent-end-position 'overlay-end))
(defalias 'viper-overlay-get 
  (if (featurep 'xemacs) 'extent-property 'overlay-get))
(defalias 'viper-overlay-put 
  (if (featurep 'xemacs) 'set-extent-property 'overlay-put))
(defalias 'viper-read-event 
  (if (featurep 'xemacs) 'next-command-event 'read-event))
(defalias 'viper-characterp 
  (if (featurep 'xemacs) 'characterp 'integerp))
(defalias 'viper-int-to-char 
  (if (featurep 'xemacs) 'int-to-char 'identity))
(defalias 'viper-get-face 
  (if (featurep 'xemacs) 'get-face 'internal-get-face))
(defalias 'viper-color-defined-p 
  (if (featurep 'xemacs) 'valid-color-name-p 'x-color-defined-p))
(defalias 'viper-iconify
  (if (featurep 'xemacs) 'iconify-frame 'iconify-or-deiconify-frame))


;; 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.

(defsubst viper-get-saved-cursor-color-in-replace-mode ()
  (or
   (funcall
    (if (featurep 'emacs) '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 (featurep 'emacs) '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 (featurep 'emacs) 'frame-parameter 'frame-property)
    (selected-frame)
    'viper-saved-cursor-color-in-emacs-mode)
   viper-vi-state-cursor-color))

;; restore cursor color from replace overlay

;; 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) (featurep 'xemacs))
		 ((eq type-of-emacs 'emacs) (featurep 'emacs))
		 (t t))
	   (cond ((eq op '=) (and (= emacs-minor-version minor)
				  (= emacs-major-version major)))
		 ((memq op '(> >= < <=))
		  (and (or (funcall op emacs-major-version major)

    (cond ((memq op '(= > >=)) nil)
	  ((memq op '(< <=)) t))))


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


;; Return line position.

(defsubst viper-file-checked-in-p (file)
  (and (featurep 'vc-hooks)
       ;; CVS files are considered not checked in
       ;; FIXME: Should this deal with more than CVS?
       (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
	 (if (featurep 'xemacs)(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)))

  (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 (featurep 'emacs) '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 (featurep 'xemacs) 'keymap 'local-map)
    ;; viper-replace-map)
    )
  (if (viper-has-face-support-p)
      (viper-overlay-put
       viper-replace-overlay 'face viper-replace-overlay-face))

(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 (featurep 'xemacs) 'begin-glyph 'before-string))
	    (after-name (if (featurep 'xemacs) '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-overlay-put
	 viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority)
	;; never detach
	(viper-overlay-put
	 viper-minibuffer-overlay
	 (if (featurep 'emacs) 'evaporate 'detachable)
	 nil)
	;; make viper-minibuffer-overlay open-ended
	;; In emacs, it is made open ended at creation time
	(if (featurep 'xemacs)
	    (progn
	      (viper-overlay-put viper-minibuffer-overlay 'start-open nil)
	      (viper-overlay-put viper-minibuffer-overlay 'end-open nil)))
	)))

      (viper-move-overlay
       viper-minibuffer-overlay
       (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
       (1+ (buffer-size)))
    (setq viper-minibuffer-overlay
	  (if (featurep 'xemacs)
	      (viper-make-overlay 1 (1+ (buffer-size)) (current-buffer))
	    ;; make overlay open-ended
	    (viper-make-overlay
	     (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
	     (1+ (buffer-size))

;; Viperized read-key-sequence
(defun viper-read-key-sequence (prompt &optional continue-echo)
  (let (inhibit-quit event keyseq)
    (setq keyseq (read-key-sequence prompt continue-echo))
    (setq event (if (featurep 'xemacs)
		    (elt keyseq 0) ; XEmacs returns vector of events
		  (elt (listify-key-sequence keyseq) 0)))
    (if (viper-ESC-event-p event)
	(let (unread-command-events)
	  (if (viper-fast-keysequence-p)

	  (append mod (list basis))
	basis))))

(defun viper-key-to-emacs-key (key)
  (let (key-name char-p modifiers mod-char-list base-key base-key-name)
    (cond ((featurep 'xemacs) key)

	  ((symbolp key)
	   (setq key-name (symbol-name key))
	   (cond ((= (length key-name) 1) ; character event
		  (string-to-char key-name))
		 ;; Emacs doesn't recognize `return' and `escape' as events on
		 ;; dumb terminals, so we translate them into characters
		 ((and (featurep 'emacs) (not (viper-window-display-p))
		       (string= key-name "return"))
		  ?\C-m)
		 ((and (featurep 'emacs) (not (viper-window-display-p))
		       (string= key-name "escape"))
		  ?\e)
		 ;; pass symbol-event as is
		 (t key)))

    ))


;; LIS is assumed to be a list of events of characters
(defun viper-eventify-list-xemacs (lis)
  (if (featurep 'xemacs)
      (mapcar
       (lambda (elt)
	 (cond ((viper-characterp elt) (character-to-event elt))
	       ((eventp elt)  elt)
	       (t (error
		   "viper-eventify-list-xemacs: can't convert to event, %S"
		   elt))))
       lis)))


;; Smoothes out the difference between Emacs' unread-command-events
;; and XEmacs unread-command-event.  Arg is a character, an event, a list of
;; events or a sequence of keys.

;; Due to the way unread-command-events in Emacs (not XEmacs), a non-event
;; symbol in unread-command-events list may cause Emacs to turn this symbol
;; into an event.  Below, we delete nil from event lists, since nil is the most
;; common symbol that might appear in this wrong context.
(defun viper-set-unread-command-events (arg)
  (if (featurep 'emacs)
      (setq
       unread-command-events
       (let ((new-events
	      (cond ((eventp arg) (list arg))
		    ((listp arg) arg)