;;; viper-util.el --- Utilities used by viper.el
;; Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009 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
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, 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
;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+(provide 'viper-util)
+
+
;; 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)
(require 'ring)
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
;; 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)))
-
\f
-(defalias 'viper-overlay-p
+(defalias 'viper-overlay-p
(if (featurep 'xemacs) 'extentp 'overlayp))
-(defalias 'viper-make-overlay
+(defalias 'viper-make-overlay
(if (featurep 'xemacs) 'make-extent 'make-overlay))
-(defalias 'viper-overlay-live-p
+(defalias 'viper-overlay-live-p
(if (featurep 'xemacs) 'extent-live-p 'overlayp))
-(defalias 'viper-move-overlay
+(defalias 'viper-move-overlay
(if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay))
-(defalias 'viper-overlay-start
+(defalias 'viper-overlay-start
(if (featurep 'xemacs) 'extent-start-position 'overlay-start))
-(defalias 'viper-overlay-end
+(defalias 'viper-overlay-end
(if (featurep 'xemacs) 'extent-end-position 'overlay-end))
-(defalias 'viper-overlay-get
+(defalias 'viper-overlay-get
(if (featurep 'xemacs) 'extent-property 'overlay-get))
-(defalias 'viper-overlay-put
+(defalias 'viper-overlay-put
(if (featurep 'xemacs) 'set-extent-property 'overlay-put))
-(defalias 'viper-read-event
+(defalias 'viper-read-event
(if (featurep 'xemacs) 'next-command-event 'read-event))
-(defalias 'viper-characterp
+(defalias 'viper-characterp
(if (featurep 'xemacs) 'characterp 'integerp))
-(defalias 'viper-int-to-char
+(defalias 'viper-int-to-char
(if (featurep 'xemacs) 'int-to-char 'identity))
-(defalias 'viper-get-face
+(defalias 'viper-get-face
(if (featurep 'xemacs) 'get-face 'internal-get-face))
-(defalias 'viper-color-defined-p
+(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))
(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
- ))
+ (if (featurep 'xemacs) (eq (device-class (selected-device)) 'color)
+ (x-display-color-p)))
(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
- ))
-
+ (if (featurep 'xemacs)
+ (color-instance-name
+ (frame-property (or frame (selected-frame)) 'cursor-color))
+ (cdr (assoc 'cursor-color (frame-parameters)))))
+
+(defmacro viper-frame-value (variable)
+ "Return the value of VARIABLE local to the current frame, if there is one.
+Otherwise return the normal value."
+ `(if (featurep 'xemacs)
+ ,variable
+ ;; Frame-local variables are obsolete from Emacs 22.2 onwards,
+ ;; so we do it by hand instead.
+ ;; Buffer-local values take precedence over frame-local ones.
+ (if (local-variable-p ',variable)
+ ,variable
+ ;; Distinguish between no frame parameter and a frame parameter
+ ;; with a value of nil.
+ (let ((fp (assoc ',variable (frame-parameters))))
+ (if fp (cdr fp)
+ ,variable)))))
;; OS/2
(cond ((eq (viper-device-type) 'pm)
(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)))
- )
- ))
-
+ (if (featurep 'xemacs)
+ (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))))))
+
+;; Note that the colors this function uses might not be those
+;; associated with FRAME, if there are frame-local values.
+;; This was equally true before the advent of viper-frame-value.
+;; Now it could be changed by passing frame to v-f-v.
(defun viper-set-cursor-color-according-to-state (&optional frame)
(cond ((eq viper-current-state 'replace-state)
- (viper-change-cursor-color viper-replace-overlay-cursor-color frame))
+ (viper-change-cursor-color
+ (viper-frame-value viper-replace-overlay-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))
+ (viper-frame-value viper-emacs-state-cursor-color))
+ (viper-change-cursor-color
+ (viper-frame-value viper-emacs-state-cursor-color)
+ frame))
((eq viper-current-state 'insert-state)
- (viper-change-cursor-color viper-insert-state-cursor-color frame))
+ (viper-change-cursor-color
+ (viper-frame-value viper-insert-state-cursor-color)
+ frame))
(t
- (viper-change-cursor-color viper-vi-state-cursor-color frame))))
+ (viper-change-cursor-color
+ (viper-frame-value 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
(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)))
+ (not (string= color
+ (viper-frame-value
+ viper-replace-overlay-cursor-color))))
(modify-frame-parameters
(selected-frame)
(list
'viper-saved-cursor-color-in-emacs-mode)
(t
'viper-saved-cursor-color-in-insert-mode))
- color)))
- ))))
+ color)))))))
-(defsubst viper-get-saved-cursor-color-in-replace-mode ()
+(defun 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)))
+ (or (and (eq viper-current-state 'emacs-mode)
+ (viper-frame-value viper-emacs-state-cursor-color))
+ (viper-frame-value viper-vi-state-cursor-color))))
-(defsubst viper-get-saved-cursor-color-in-insert-mode ()
+(defun 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)))
+ (or (and (eq viper-current-state 'emacs-mode)
+ (viper-frame-value viper-emacs-state-cursor-color))
+ (viper-frame-value viper-vi-state-cursor-color))))
-(defsubst viper-get-saved-cursor-color-in-emacs-mode ()
+(defun 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))
+ (viper-frame-value viper-vi-state-cursor-color)))
;; restore cursor color from replace overlay
(defun viper-restore-cursor-color(after-which-mode)
;;; 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.
+;; This function is designed to work under Unix.
(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
(regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name))
(buf (find-file-noselect (substitute-in-file-name custom-file)))
)
- (message message)
+ (message "%s" (or message ""))
(save-excursion
(set-buffer buf)
(goto-char (point-min))
))
-;; 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
(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))))
- ))
+ (if (featurep 'xemacs) (not (vc-locking-user file))))))
;; checkout if visited file is checked in
(defun viper-maybe-checkout (buf)
(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)
- )
+ (viper-change-cursor-color
+ (viper-frame-value viper-replace-overlay-cursor-color)))
(defun viper-set-replace-overlay-glyphs (before-glyph after-glyph)
(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 (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)))
- )))
+ (when (viper-has-face-support-p)
+ (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 (featurep 'emacs) 'evaporate 'detachable)
+ nil)
+ ;; make viper-minibuffer-overlay open-ended
+ ;; In emacs, it is made open ended at creation time
+ (when (featurep 'xemacs)
+ (viper-overlay-put viper-minibuffer-overlay 'start-open nil)
+ (viper-overlay-put viper-minibuffer-overlay 'end-open nil))))
(defun viper-check-minibuffer-overlay ()
(if (viper-overlay-live-p viper-minibuffer-overlay)
(viper-make-overlay
(if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
(1+ (buffer-size))
- (current-buffer) nil 'rear-advance)))
- ))
+ (current-buffer) nil 'rear-advance)))))
(defsubst viper-is-in-minibuffer ()
;;; XEmacs compatibility
(defun viper-abbreviate-file-name (file)
- (viper-cond-compile-for-xemacs-or-emacs
- ;; XEmacs requires addl argument
- (abbreviate-file-name file t)
- ;; emacs
- (abbreviate-file-name file)
- ))
+ (if (featurep 'xemacs)
+ (abbreviate-file-name file t) ; XEmacs requires addl argument
+ (abbreviate-file-name file)))
;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg
;; in sit-for, so this function smoothes out the differences.
(and (<= pos (point-max)) (<= (point-min) pos))))))
(defsubst viper-mark-marker ()
- (viper-cond-compile-for-xemacs-or-emacs
- (mark-marker t) ; xemacs
- (mark-marker) ; emacs
- ))
+ (if (featurep 'xemacs) (mark-marker t)
+ (mark-marker)))
;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring)
;; is the same as (mark t).
;; highlighted due to Viper's pushing marks. So, we deactivate marks, unless
;; the user explicitly wants highlighting, e.g., by hitting '' or ``
(defun viper-deactivate-mark ()
- (viper-cond-compile-for-xemacs-or-emacs
- (zmacs-deactivate-region)
- (deactivate-mark)
- ))
+ (if (featurep 'xemacs)
+ (zmacs-deactivate-region)
+ (deactivate-mark)))
(defsubst viper-leave-region-active ()
- (viper-cond-compile-for-xemacs-or-emacs
- (setq zmacs-region-stays t)
- nil
- ))
+ (if (featurep 'xemacs) (setq zmacs-region-stays t)))
;; Check if arg is a valid character for register
;; TYPE is a list that can contain `letter', `Letter', and `digit'.
;; it is suggested that an event must be copied before it is assigned to
;; last-command-event in XEmacs
(defun viper-copy-event (event)
- (viper-cond-compile-for-xemacs-or-emacs
- (copy-event event) ; xemacs
- event ; emacs
- ))
+ (if (featurep 'xemacs) (copy-event event)
+ event))
;; Uses different timeouts for ESC-sequences and others
-(defsubst viper-fast-keysequence-p ()
+(defun viper-fast-keysequence-p ()
(not (viper-sit-for-short
(if (viper-ESC-event-p last-input-event)
- viper-ESC-keyseq-timeout
+ (viper-ESC-keyseq-timeout)
viper-fast-keyseq-timeout)
t)))
;; like read-event, but in XEmacs also try to convert to char, if possible
(defun viper-read-event-convert-to-char ()
(let (event)
- (viper-cond-compile-for-xemacs-or-emacs
- (progn
- (setq event (next-command-event))
- (or (event-to-character event)
- event))
- (read-event)
- )
- ))
+ (if (featurep 'xemacs)
+ (progn
+ (setq event (next-command-event))
+ (or (event-to-character event)
+ event))
+ (read-event))))
;; Viperized read-key-sequence
(defun viper-read-key-sequence (prompt &optional continue-echo)
;; This function lets function-key-map convert key sequences into logical
;; keys. This does a better job than viper-read-event when it comes to kbd
;; macros, since it enables certain macros to be shared between X and TTY modes
-;; by correctly mapping key sequences for Left/Right/... (one an ascii
+;; by correctly mapping key sequences for Left/Right/... (on an ascii
;; terminal) into logical keys left, right, etc.
(defun viper-read-key ()
(let ((overriding-local-map viper-overriding-map)
(defun viper-event-key (event)
(or (and event (eventp event))
(error "viper-event-key: Wrong type argument, eventp, %S" event))
- (when (viper-cond-compile-for-xemacs-or-emacs
+ (when (if (featurep 'xemacs)
(or (key-press-event-p event) (mouse-event-p event)) ; xemacs
t ; emacs
)
(let ((mod (event-modifiers event))
basis)
(setq basis
- (viper-cond-compile-for-xemacs-or-emacs
+ (if (featurep 'xemacs)
;; XEmacs
(cond ((key-press-event-p event)
(event-key event))
((and (null mod) (eq event 'backspace))
(setq event ?\C-h))
(t (event-basic-type event)))
- ) ; viper-cond-compile-for-xemacs-or-emacs
+ ) ; (featurep 'xemacs)
)
(if (viper-characterp basis)
(setq basis
(t (prin1-to-string event-seq)))))
(defun viper-key-press-events-to-chars (events)
- (mapconcat (viper-cond-compile-for-xemacs-or-emacs
- (lambda (elt) (char-to-string (event-to-character elt))) ; xemacs
- 'char-to-string ; emacs
- )
+ (mapconcat (if (featurep 'xemacs)
+ (lambda (elt) (char-to-string (event-to-character elt))) ; xemacs
+ 'char-to-string ; emacs
+ )
events
""))
-(provide 'viper-util)
-
-
-;;; Local Variables:
-;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
-;;; End:
+;; Local Variables:
+;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
+;; End:
-;;; arch-tag: 7f023fd5-dd9e-4378-a397-9c179553b0e3
+;; arch-tag: 7f023fd5-dd9e-4378-a397-9c179553b0e3
;;; viper-util.el ends here
HCoop / bpt / emacs.git / blobdiff