/[emacs]/emacs/lisp/emulation/viper-util.el
ViewVC logotype

Diff of /emacs/lisp/emulation/viper-util.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.47 by kifer, Sun Feb 10 06:46:12 2002 UTC revision 1.47.4.1 by miles, Fri Apr 4 06:20:20 2003 UTC
# Line 136  Line 136 
136     (eq (device-class (selected-device)) 'color) ; xemacs     (eq (device-class (selected-device)) 'color) ; xemacs
137     (x-display-color-p)  ; emacs     (x-display-color-p)  ; emacs
138     ))     ))
139      
140  (defsubst viper-get-cursor-color ()  (defsubst viper-get-cursor-color ()
141    (viper-cond-compile-for-xemacs-or-emacs    (viper-cond-compile-for-xemacs-or-emacs
142     ;; xemacs     ;; xemacs
143     (color-instance-name (frame-property (selected-frame) 'cursor-color))     (color-instance-name (frame-property (selected-frame) 'cursor-color))
144     (cdr (assoc 'cursor-color (frame-parameters))) ; emacs     (cdr (assoc 'cursor-color (frame-parameters))) ; emacs
145     ))     ))
146      
147    
148  ;; OS/2  ;; OS/2
149  (cond ((eq (viper-device-type) 'pm)  (cond ((eq (viper-device-type) 'pm)
150         (fset 'viper-color-defined-p         (fset 'viper-color-defined-p
151               (lambda (color) (assoc color pm-color-alist)))))               (lambda (color) (assoc color pm-color-alist)))))
152        
153    
154  ;; cursor colors  ;; cursor colors
155  (defun viper-change-cursor-color (new-color)  (defun viper-change-cursor-color (new-color)
# Line 163  Line 163 
163          (selected-frame) (list (cons 'cursor-color new-color)))          (selected-frame) (list (cons 'cursor-color new-color)))
164         )         )
165      ))      ))
166            
167  ;; By default, saves current frame cursor color in the  ;; By default, saves current frame cursor color in the
168  ;; viper-saved-cursor-color-in-replace-mode property of viper-replace-overlay  ;; viper-saved-cursor-color-in-replace-mode property of viper-replace-overlay
169  (defun viper-save-cursor-color (before-which-mode)  (defun viper-save-cursor-color (before-which-mode)
# Line 180  Line 180 
180                   'viper-saved-cursor-color-in-insert-mode)                   'viper-saved-cursor-color-in-insert-mode)
181                 color)))                 color)))
182            ))))            ))))
183            
184    
185  (defsubst viper-get-saved-cursor-color-in-replace-mode ()  (defsubst viper-get-saved-cursor-color-in-replace-mode ()
186    (or    (or
# Line 197  Line 197 
197      (selected-frame)      (selected-frame)
198      'viper-saved-cursor-color-in-insert-mode)      'viper-saved-cursor-color-in-insert-mode)
199     viper-vi-state-cursor-color))     viper-vi-state-cursor-color))
200            
201  ;; restore cursor color from replace overlay  ;; restore cursor color from replace overlay
202  (defun viper-restore-cursor-color(after-which-mode)  (defun viper-restore-cursor-color(after-which-mode)
203    (if (viper-overlay-p viper-replace-overlay)    (if (viper-overlay-p viper-replace-overlay)
# Line 206  Line 206 
206             (viper-get-saved-cursor-color-in-replace-mode)             (viper-get-saved-cursor-color-in-replace-mode)
207           (viper-get-saved-cursor-color-in-insert-mode))           (viper-get-saved-cursor-color-in-insert-mode))
208         )))         )))
209      
210    
211  ;; Check the current version against the major and minor version numbers  ;; Check the current version against the major and minor version numbers
212  ;; using op: cur-vers op major.minor If emacs-major-version or  ;; using op: cur-vers op major.minor If emacs-major-version or
# Line 234  Line 234 
234                    (error "%S: Invalid op in viper-check-version" op))))                    (error "%S: Invalid op in viper-check-version" op))))
235      (cond ((memq op '(= > >=)) nil)      (cond ((memq op '(= > >=)) nil)
236            ((memq op '(< <=)) t))))            ((memq op '(< <=)) t))))
237              
238    
239  (defun viper-get-visible-buffer-window (wind)  (defun viper-get-visible-buffer-window (wind)
240    (if viper-xemacs-p    (if viper-xemacs-p
241        (get-buffer-window wind t)        (get-buffer-window wind t)
242      (get-buffer-window wind 'visible)))      (get-buffer-window wind 'visible)))
243        
244        
245  ;; Return line position.  ;; Return line position.
246  ;; If pos is 'start then returns position of line start.  ;; If pos is 'start then returns position of line start.
247  ;; If pos is 'end, returns line end.  If pos is 'mid, returns line center.  ;; If pos is 'end, returns line end.  If pos is 'mid, returns line center.
# Line 264  Line 264 
264      (goto-char cur-pos)      (goto-char cur-pos)
265      result))      result))
266    
267  ;; Emacs counts each multibyte character as several positions in the buffer, so  ;; Emacs used to count each multibyte character as several positions in the buffer,
268  ;; we use Emacs' chars-in-region.  XEmacs is counting each char as just one pos,  ;; so we had to use Emacs' chars-in-region to count characters. Since 20.3,
269  ;; so we can simply subtract.  ;; Emacs counts multibyte characters as 1 position.  XEmacs has always been
270    ;; counting each char as just one pos. So, now we can simply subtract beg from
271    ;; end to determine the number of characters in a region.
272  (defun viper-chars-in-region (beg end &optional preserve-sign)  (defun viper-chars-in-region (beg end &optional preserve-sign)
273    (let ((count (abs (if (fboundp 'chars-in-region)    ;;(let ((count (abs (if (fboundp 'chars-in-region)
274                          (chars-in-region beg end)    ;;                    (chars-in-region beg end)
275                        (- end beg)))))    ;;                  (- end beg)))))
276      (let ((count (abs (- end beg))))
277      (if (and (< end beg) preserve-sign)      (if (and (< end beg) preserve-sign)
278          (- count)          (- count)
279        count)))        count)))
# Line 283  Line 286 
286  ;; Like move-marker but creates a virgin marker if arg isn't already a marker.  ;; Like move-marker but creates a virgin marker if arg isn't already a marker.
287  ;; The first argument must eval to a variable name.  ;; The first argument must eval to a variable name.
288  ;; Arguments: (var-name position &optional buffer).  ;; Arguments: (var-name position &optional buffer).
289  ;;  ;;
290  ;; This is useful for moving markers that are supposed to be local.  ;; This is useful for moving markers that are supposed to be local.
291  ;; For this, VAR-NAME should be made buffer-local with nil as a default.  ;; For this, VAR-NAME should be made buffer-local with nil as a default.
292  ;; Then, each time this var is used in `viper-move-marker-locally' in a new  ;; Then, each time this var is used in `viper-move-marker-locally' in a new
# Line 306  Line 309 
309    
310    
311  ;;; List/alist utilities  ;;; List/alist utilities
312            
313  ;; Convert LIST to an alist  ;; Convert LIST to an alist
314  (defun viper-list-to-alist (lst)  (defun viper-list-to-alist (lst)
315    (let ((alist))    (let ((alist))
316      (while lst      (while lst
317        (setq alist (cons (list (car lst)) alist))        (setq alist (cons (list (car lst)) alist))
318        (setq lst (cdr lst)))        (setq lst (cdr lst)))
319      alist))          alist))
320    
321  ;; Convert ALIST to a list.  ;; Convert ALIST to a list.
322  (defun viper-alist-to-list (alst)  (defun viper-alist-to-list (alst)
# Line 331  Line 334 
334        (if (string-match regexp (car (car inalst)))        (if (string-match regexp (car (car inalst)))
335            (setq outalst (cons (car inalst) outalst)))            (setq outalst (cons (car inalst) outalst)))
336        (setq inalst (cdr inalst)))        (setq inalst (cdr inalst)))
337      outalst))          outalst))
338          
339  ;; Filter LIST using REGEXP.  Return list whose elements match the regexp.  ;; Filter LIST using REGEXP.  Return list whose elements match the regexp.
340  (defun viper-filter-list (regexp lst)  (defun viper-filter-list (regexp lst)
341    (interactive "s x")    (interactive "s x")
# Line 341  Line 344 
344        (if (string-match regexp (car inlst))        (if (string-match regexp (car inlst))
345            (setq outlst (cons (car inlst) outlst)))            (setq outlst (cons (car inlst) outlst)))
346        (setq inlst (cdr inlst)))        (setq inlst (cdr inlst)))
347      outlst))          outlst))
348    
349    
     
350  ;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1  ;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1
351  ;; LIS2 is modified by filtering it: deleting its members of the form  ;; LIS2 is modified by filtering it: deleting its members of the form
352  ;; \(car elt\) such that (car elt') is in LIS1.  ;; \(car elt\) such that (car elt') is in LIS1.
# Line 356  Line 359 
359        (while (setq elt (assoc (car (car temp)) lis2))        (while (setq elt (assoc (car (car temp)) lis2))
360          (setq lis2 (delq elt lis2)))          (setq lis2 (delq elt lis2)))
361        (setq temp (cdr temp)))        (setq temp (cdr temp)))
362        
363      (nconc lis1 lis2)))      (nconc lis1 lis2)))
364    
365    
# Line 377  Line 380 
380          (command (cond (viper-ms-style-os-p (format "\"ls -1 -d %s\"" filespec))          (command (cond (viper-ms-style-os-p (format "\"ls -1 -d %s\"" filespec))
381                         (t (format "ls -1 -d %s" filespec))))                         (t (format "ls -1 -d %s" filespec))))
382          status)          status)
383      (save-excursion      (save-excursion
384        (set-buffer (get-buffer-create viper-ex-tmp-buf-name))        (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
385        (erase-buffer)        (erase-buffer)
386        (setq status        (setq status
# Line 422  Line 425 
425                  ((looking-at "'")                  ((looking-at "'")
426                   (setq delim ?')                   (setq delim ?')
427                   (re-search-forward "[^']+" nil t)) ; noerror                   (re-search-forward "[^']+" nil t)) ; noerror
428                  (t                  (t
429                   (re-search-forward                   (re-search-forward
430                    (concat "[^" skip-chars "]+") nil t))) ;noerror                    (concat "[^" skip-chars "]+") nil t))) ;noerror
431            (setq fname            (setq fname
# Line 456  Line 459 
459  (defun viper-glob-mswindows-files (filespec)  (defun viper-glob-mswindows-files (filespec)
460    (let ((case-fold-search t)    (let ((case-fold-search t)
461          tmp tmp2)          tmp tmp2)
462      (save-excursion      (save-excursion
463        (set-buffer (get-buffer-create viper-ex-tmp-buf-name))        (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
464        (erase-buffer)        (erase-buffer)
465        (insert filespec)        (insert filespec)
466        (goto-char (point-min))        (goto-char (point-min))
467        (setq tmp (viper-get-filenames-from-buffer))        (setq tmp (viper-get-filenames-from-buffer))
468        (while tmp        (while tmp
469          (setq tmp2 (cons (directory-files          (setq tmp2 (cons (directory-files
470                            ;; the directory part                            ;; the directory part
471                            (or (file-name-directory (car tmp))                            (or (file-name-directory (car tmp))
472                                "")                                "")
# Line 492  Line 495 
495                             (t (car ring))))                             (t (car ring))))
496          (viper-current-ring-item ring)          (viper-current-ring-item ring)
497          )))          )))
498            
499  (defun viper-special-ring-rotate1 (ring dir)  (defun viper-special-ring-rotate1 (ring dir)
500    (if (memq viper-intermediate-command    (if (memq viper-intermediate-command
501              '(repeating-display-destructive-command              '(repeating-display-destructive-command
# Line 500  Line 503 
503        (viper-ring-rotate1 ring dir)        (viper-ring-rotate1 ring dir)
504      ;; don't rotate otherwise      ;; don't rotate otherwise
505      (viper-ring-rotate1 ring 0)))      (viper-ring-rotate1 ring 0)))
506        
507  ;; current ring item; if N is given, then so many items back from the  ;; current ring item; if N is given, then so many items back from the
508  ;; current  ;; current
509  (defun viper-current-ring-item (ring &optional n)  (defun viper-current-ring-item (ring &optional n)
510    (setq n (or n 0))    (setq n (or n 0))
511    (if (and (ring-p ring) (> (ring-length ring) 0))    (if (and (ring-p ring) (> (ring-length ring) 0))
512        (aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring)))))        (aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring)))))
513        
514  ;; Push item onto ring.  The second argument is a ring-variable, not value.  ;; Push item onto ring.  The second argument is a ring-variable, not value.
515  (defun viper-push-onto-ring (item ring-var)  (defun viper-push-onto-ring (item ring-var)
516    (or (ring-p (eval ring-var))    (or (ring-p (eval ring-var))
# Line 529  Line 532 
532                           (viper-array-to-string (this-command-keys))))                           (viper-array-to-string (this-command-keys))))
533        (viper-ring-insert (eval ring-var) item))        (viper-ring-insert (eval ring-var) item))
534    )    )
535      
536    
537  ;; removing elts from ring seems to break it  ;; removing elts from ring seems to break it
538  (defun viper-cleanup-ring (ring)  (defun viper-cleanup-ring (ring)
# Line 539  Line 542 
542        (if (equal (viper-current-ring-item ring)        (if (equal (viper-current-ring-item ring)
543                   (viper-current-ring-item ring 1))                   (viper-current-ring-item ring 1))
544            (viper-ring-pop ring))))            (viper-ring-pop ring))))
545              
546  ;; ring-remove seems to be buggy, so we concocted this for our purposes.  ;; ring-remove seems to be buggy, so we concocted this for our purposes.
547  (defun viper-ring-pop (ring)  (defun viper-ring-pop (ring)
548    (let* ((ln (ring-length ring))    (let* ((ln (ring-length ring))
# Line 548  Line 551 
551           (hd (car ring))           (hd (car ring))
552           (idx (max 0 (ring-minus1 hd ln)))           (idx (max 0 (ring-minus1 hd ln)))
553           (top-elt (aref vec idx)))           (top-elt (aref vec idx)))
554            
555          ;; shift elements          ;; shift elements
556          (while (< (1+ idx) veclen)          (while (< (1+ idx) veclen)
557            (aset vec idx (aref vec (1+ idx)))            (aset vec idx (aref vec (1+ idx)))
558            (setq idx (1+ idx)))            (setq idx (1+ idx)))
559          (aset vec idx nil)          (aset vec idx nil)
560            
561          (setq hd (max 0 (ring-minus1 hd ln)))          (setq hd (max 0 (ring-minus1 hd ln)))
562          (if (= hd (1- ln)) (setq hd 0))          (if (= hd (1- ln)) (setq hd 0))
563          (setcar ring hd) ; move head          (setcar ring hd) ; move head
564          (setcar (cdr ring) (max 0 (1- ln))) ; adjust length          (setcar (cdr ring) (max 0 (1- ln))) ; adjust length
565          top-elt          top-elt
566          ))          ))
567            
568  (defun viper-ring-insert (ring item)  (defun viper-ring-insert (ring item)
569    (let* ((ln (ring-length ring))    (let* ((ln (ring-length ring))
570           (vec (cdr (cdr ring)))           (vec (cdr (cdr ring)))
# Line 569  Line 572 
572           (hd (car ring))           (hd (car ring))
573           (vecpos-after-hd (if (= hd 0) ln hd))           (vecpos-after-hd (if (= hd 0) ln hd))
574           (idx ln))           (idx ln))
575            
576      (if (= ln veclen)      (if (= ln veclen)
577          (progn          (progn
578            (aset vec hd item) ; hd is always 1+ the actual head index in vec            (aset vec hd item) ; hd is always 1+ the actual head index in vec
# Line 581  Line 584 
584          (setq idx (1- idx)))          (setq idx (1- idx)))
585        (aset vec vecpos-after-hd item))        (aset vec vecpos-after-hd item))
586      item))      item))
587            
588    
589  ;;; String utilities  ;;; String utilities
590    
# Line 589  Line 592 
592  ;; PRE-STRING is a string to prepend to the abbrev string.  ;; PRE-STRING is a string to prepend to the abbrev string.
593  ;; POST-STRING is a string to append to the abbrev string.  ;; POST-STRING is a string to append to the abbrev string.
594  ;; ABBREV_SIGN is a string to be inserted before POST-STRING  ;; ABBREV_SIGN is a string to be inserted before POST-STRING
595  ;; if the orig string was truncated.  ;; if the orig string was truncated.
596  (defun viper-abbreviate-string (string max-len  (defun viper-abbreviate-string (string max-len
597                                       pre-string post-string abbrev-sign)                                       pre-string post-string abbrev-sign)
598    (let (truncated-str)    (let (truncated-str)
599      (setq truncated-str      (setq truncated-str
600            (if (stringp string)            (if (stringp string)
601                (substring string 0 (min max-len (length string)))))                (substring string 0 (min max-len (length string)))))
602      (cond ((null truncated-str) "")      (cond ((null truncated-str) "")
603            ((> (length string) max-len)            ((> (length string) max-len)
# Line 607  Line 610 
610    (save-excursion    (save-excursion
611      (beginning-of-line)      (beginning-of-line)
612      (looking-at "^[ \t]*$")))      (looking-at "^[ \t]*$")))
613              
614    
615  ;;; Saving settings in custom file  ;;; Saving settings in custom file
616    
# Line 641  Line 644 
644              (sit-for 2)              (sit-for 2)
645              (message "")))              (message "")))
646        ))        ))
647          
648  ;; Save STRING in CUSTOM-FILE.  If PATTERN is non-nil, remove strings that  ;; Save STRING in CUSTOM-FILE.  If PATTERN is non-nil, remove strings that
649  ;; match this pattern.  ;; match this pattern.
650  (defun viper-save-string-in-file (string custom-file &optional pattern)  (defun viper-save-string-in-file (string custom-file &optional pattern)
# Line 667  Line 670 
670                      ;; Can happen only in Emacs, since XEmacs has file-remote-p                      ;; Can happen only in Emacs, since XEmacs has file-remote-p
671                      (ange-ftp-ftp-name file-name))))))                      (ange-ftp-ftp-name file-name))))))
672    
673        
674    
675  ;; This is a simple-minded check for whether a file is under version control.  ;; This is a simple-minded check for whether a file is under version control.
676  ;; If file,v exists but file doesn't, this file is considered to be not checked  ;; If file,v exists but file doesn't, this file is considered to be not checked
# Line 718  Line 721 
721                 (viper-abbreviate-file-name file))))                 (viper-abbreviate-file-name file))))
722          (with-current-buffer buf          (with-current-buffer buf
723            (command-execute checkout-function)))))            (command-execute checkout-function)))))
           
724    
725        
726    
727    
728  ;;; Overlays  ;;; Overlays
729  (defun viper-put-on-search-overlay (beg end)  (defun viper-put-on-search-overlay (beg end)
# Line 753  Line 756 
756    
757  (defsubst viper-move-replace-overlay (beg end)  (defsubst viper-move-replace-overlay (beg end)
758    (viper-move-overlay viper-replace-overlay beg end))    (viper-move-overlay viper-replace-overlay beg end))
759      
760  (defun viper-set-replace-overlay (beg end)  (defun viper-set-replace-overlay (beg end)
761    (if (viper-overlay-live-p viper-replace-overlay)    (if (viper-overlay-live-p viper-replace-overlay)
762        (viper-move-replace-overlay beg end)        (viper-move-replace-overlay beg end)
# Line 761  Line 764 
764      ;; never detach      ;; never detach
765      (viper-overlay-put      (viper-overlay-put
766       viper-replace-overlay (if viper-emacs-p 'evaporate 'detachable) nil)       viper-replace-overlay (if viper-emacs-p 'evaporate 'detachable) nil)
767      (viper-overlay-put      (viper-overlay-put
768       viper-replace-overlay 'priority viper-replace-overlay-priority)       viper-replace-overlay 'priority viper-replace-overlay-priority)
769      ;; If Emacs will start supporting overlay maps, as it currently supports      ;; If Emacs will start supporting overlay maps, as it currently supports
770      ;; text-property maps, we could do away with viper-replace-minor-mode and      ;; text-property maps, we could do away with viper-replace-minor-mode and
# Line 770  Line 773 
773      ;; viper-replace-overlay      ;; viper-replace-overlay
774      ;; (if viper-xemacs-p 'keymap 'local-map)      ;; (if viper-xemacs-p 'keymap 'local-map)
775      ;; viper-replace-map)      ;; viper-replace-map)
776      )      )
777    (if (viper-has-face-support-p)    (if (viper-has-face-support-p)
778        (viper-overlay-put        (viper-overlay-put
779         viper-replace-overlay 'face viper-replace-overlay-face))         viper-replace-overlay 'face viper-replace-overlay-face))
780    (viper-save-cursor-color 'before-replace-mode)    (viper-save-cursor-color 'before-replace-mode)
781    (viper-change-cursor-color viper-replace-overlay-cursor-color)    (viper-change-cursor-color viper-replace-overlay-cursor-color)
782    )    )
783      
784          
785  (defun viper-set-replace-overlay-glyphs (before-glyph after-glyph)  (defun viper-set-replace-overlay-glyphs (before-glyph after-glyph)
786    (or (viper-overlay-live-p viper-replace-overlay)    (or (viper-overlay-live-p viper-replace-overlay)
787        (viper-set-replace-overlay (point-min) (point-min)))        (viper-set-replace-overlay (point-min) (point-min)))
# Line 788  Line 791 
791              (after-name (if viper-xemacs-p 'end-glyph 'after-string)))              (after-name (if viper-xemacs-p 'end-glyph 'after-string)))
792          (viper-overlay-put viper-replace-overlay before-name before-glyph)          (viper-overlay-put viper-replace-overlay before-name before-glyph)
793          (viper-overlay-put viper-replace-overlay after-name after-glyph))))          (viper-overlay-put viper-replace-overlay after-name after-glyph))))
794      
795  (defun viper-hide-replace-overlay ()  (defun viper-hide-replace-overlay ()
796    (viper-set-replace-overlay-glyphs nil nil)    (viper-set-replace-overlay-glyphs nil nil)
797    (viper-restore-cursor-color 'after-replace-mode)    (viper-restore-cursor-color 'after-replace-mode)
# Line 796  Line 799 
799    (if (viper-has-face-support-p)    (if (viper-has-face-support-p)
800        (viper-overlay-put viper-replace-overlay 'face nil)))        (viper-overlay-put viper-replace-overlay 'face nil)))
801    
802        
803  (defsubst viper-replace-start ()  (defsubst viper-replace-start ()
804    (viper-overlay-start viper-replace-overlay))    (viper-overlay-start viper-replace-overlay))
805  (defsubst viper-replace-end ()  (defsubst viper-replace-end ()
806    (viper-overlay-end viper-replace-overlay))    (viper-overlay-end viper-replace-overlay))
807    
808    
809  ;; Minibuffer  ;; Minibuffer
810    
# Line 811  Line 814 
814        (progn        (progn
815          (viper-overlay-put          (viper-overlay-put
816           viper-minibuffer-overlay 'face viper-minibuffer-current-face)           viper-minibuffer-overlay 'face viper-minibuffer-current-face)
817          (viper-overlay-put          (viper-overlay-put
818           viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority)           viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority)
819          ;; never detach          ;; never detach
820          (viper-overlay-put          (viper-overlay-put
# Line 825  Line 828 
828                (viper-overlay-put viper-minibuffer-overlay 'start-open nil)                (viper-overlay-put viper-minibuffer-overlay 'start-open nil)
829                (viper-overlay-put viper-minibuffer-overlay 'end-open nil)))                (viper-overlay-put viper-minibuffer-overlay 'end-open nil)))
830          )))          )))
831          
832  (defun viper-check-minibuffer-overlay ()  (defun viper-check-minibuffer-overlay ()
833    (if (viper-overlay-live-p viper-minibuffer-overlay)    (if (viper-overlay-live-p viper-minibuffer-overlay)
834        (viper-move-overlay        (viper-move-overlay
# Line 846  Line 849 
849  (defsubst viper-is-in-minibuffer ()  (defsubst viper-is-in-minibuffer ()
850    (save-match-data    (save-match-data
851      (string-match "\*Minibuf-" (buffer-name))))      (string-match "\*Minibuf-" (buffer-name))))
852      
853    
854    
855  ;;; XEmacs compatibility  ;;; XEmacs compatibility
# Line 858  Line 861 
861     ;; emacs     ;; emacs
862     (abbreviate-file-name file)     (abbreviate-file-name file)
863     ))     ))
864        
865  ;; Sit for VAL milliseconds.  XEmacs doesn't support the millisecond arg  ;; Sit for VAL milliseconds.  XEmacs doesn't support the millisecond arg
866  ;; in sit-for, so this function smoothes out the differences.  ;; in sit-for, so this function smoothes out the differences.
867  (defsubst viper-sit-for-short (val &optional nodisp)  (defsubst viper-sit-for-short (val &optional nodisp)
868    (if viper-xemacs-p    (if viper-xemacs-p
# Line 880  Line 883 
883          (save-excursion          (save-excursion
884            (set-buffer buf)            (set-buffer buf)
885            (and (<= pos (point-max)) (<= (point-min) pos))))))            (and (<= pos (point-max)) (<= (point-min) pos))))))
886      
887  (defsubst viper-mark-marker ()  (defsubst viper-mark-marker ()
888    (viper-cond-compile-for-xemacs-or-emacs    (viper-cond-compile-for-xemacs-or-emacs
889     (mark-marker t) ; xemacs     (mark-marker t) ; xemacs
# Line 893  Line 896 
896    (setq mark-ring (delete (viper-mark-marker) mark-ring))    (setq mark-ring (delete (viper-mark-marker) mark-ring))
897    (set-mark-command nil)    (set-mark-command nil)
898    (setq viper-saved-mark (point)))    (setq viper-saved-mark (point)))
899          
900  ;; In transient mark mode (zmacs mode), it is annoying when regions become  ;; In transient mark mode (zmacs mode), it is annoying when regions become
901  ;; highlighted due to Viper's pushing marks.  So, we deactivate marks, unless  ;; highlighted due to Viper's pushing marks.  So, we deactivate marks, unless
902  ;; the user explicitly wants highlighting, e.g., by hitting '' or ``  ;; the user explicitly wants highlighting, e.g., by hitting '' or ``
# Line 924  Line 927 
927            (and (<= ?A reg) (<= reg ?Z)))            (and (<= ?A reg) (<= reg ?Z)))
928        ))        ))
929    
930        
931        
932  ;; it is suggested that an event must be copied before it is assigned to  ;; it is suggested that an event must be copied before it is assigned to
933  ;; last-command-event in XEmacs  ;; last-command-event in XEmacs
934  (defun viper-copy-event (event)  (defun viper-copy-event (event)
# Line 933  Line 936 
936     (copy-event event) ; xemacs     (copy-event event) ; xemacs
937     event ; emacs     event ; emacs
938     ))     ))
939        
940  ;; Uses different timeouts for ESC-sequences and others  ;; Uses different timeouts for ESC-sequences and others
941  (defsubst viper-fast-keysequence-p ()  (defsubst viper-fast-keysequence-p ()
942    (not (viper-sit-for-short    (not (viper-sit-for-short
943          (if (viper-ESC-event-p last-input-event)          (if (viper-ESC-event-p last-input-event)
944              viper-ESC-keyseq-timeout              viper-ESC-keyseq-timeout
945            viper-fast-keyseq-timeout)            viper-fast-keyseq-timeout)
946          t)))          t)))
947        
948  ;; like read-event, but in XEmacs also try to convert to char, if possible  ;; like read-event, but in XEmacs also try to convert to char, if possible
949  (defun viper-read-event-convert-to-char ()  (defun viper-read-event-convert-to-char ()
950    (let (event)    (let (event)
# Line 975  Line 978 
978                  ;; keysequence. Otherwise, viper-fast-keysequence-p will be                  ;; keysequence. Otherwise, viper-fast-keysequence-p will be
979                  ;; always t -- whether there is anything after ESC or not                  ;; always t -- whether there is anything after ESC or not
980                  (viper-set-unread-command-events keyseq)                  (viper-set-unread-command-events keyseq)
981                  (setq keyseq (read-key-sequence nil)))                  (setq keyseq (read-key-sequence nil)))
982              (viper-set-unread-command-events keyseq)              (viper-set-unread-command-events keyseq)
983              (setq keyseq (read-key-sequence nil)))))              (setq keyseq (read-key-sequence nil)))))
984      keyseq))      keyseq))
# Line 986  Line 989 
989  ;; macros, since it enables certain macros to be shared between X and TTY modes  ;; macros, since it enables certain macros to be shared between X and TTY modes
990  ;; by correctly mapping key sequences for Left/Right/... (one an ascii  ;; by correctly mapping key sequences for Left/Right/... (one an ascii
991  ;; terminal) into logical keys left, right, etc.  ;; terminal) into logical keys left, right, etc.
992  (defun viper-read-key ()  (defun viper-read-key ()
993    (let ((overriding-local-map viper-overriding-map)    (let ((overriding-local-map viper-overriding-map)
994          (inhibit-quit t)          (inhibit-quit t)
995          help-char key)          help-char key)
996      (use-global-map viper-overriding-map)      (use-global-map viper-overriding-map)
997      (unwind-protect      (unwind-protect
998          (setq key (elt (viper-read-key-sequence nil) 0))          (setq key (elt (viper-read-key-sequence nil) 0))
999        (use-global-map global-map))        (use-global-map global-map))
1000      key))      key))
1001    
# Line 1016  Line 1019 
1019                      (event-key event))                      (event-key event))
1020                     ((button-event-p event)                     ((button-event-p event)
1021                      (concat "mouse-" (prin1-to-string (event-button event))))                      (concat "mouse-" (prin1-to-string (event-button event))))
1022                     (t                     (t
1023                      (error "viper-event-key: Unknown event, %S" event)))                      (error "viper-event-key: Unknown event, %S" event)))
1024               ;; Emacs doesn't handle capital letters correctly, since               ;; Emacs doesn't handle capital letters correctly, since
1025               ;; \S-a isn't considered the same as A (it behaves as               ;; \S-a isn't considered the same as A (it behaves as
# Line 1050  Line 1053 
1053        (if mod        (if mod
1054            (append mod (list basis))            (append mod (list basis))
1055          basis))))          basis))))
1056        
1057  (defun viper-key-to-emacs-key (key)  (defun viper-key-to-emacs-key (key)
1058    (let (key-name char-p modifiers mod-char-list base-key base-key-name)    (let (key-name char-p modifiers mod-char-list base-key base-key-name)
1059      (cond (viper-xemacs-p key)      (cond (viper-xemacs-p key)
# Line 1106  Line 1109 
1109                 "viper-eventify-list-xemacs: can't convert to event, %S"                 "viper-eventify-list-xemacs: can't convert to event, %S"
1110                 elt))))                 elt))))
1111     lis))     lis))
1112      
1113    
1114  ;; Smoothes out the difference between Emacs' unread-command-events  ;; Smoothes out the difference between Emacs' unread-command-events
1115  ;; and XEmacs unread-command-event.  Arg is a character, an event, a list of  ;; and XEmacs unread-command-event.  Arg is a character, an event, a list of
# Line 1151  Line 1154 
1154    (and (vectorp vec)    (and (vectorp vec)
1155         (eval (cons 'and (mapcar '(lambda (elt) (if (eventp elt) t)) vec)))))         (eval (cons 'and (mapcar '(lambda (elt) (if (eventp elt) t)) vec)))))
1156    
1157                            
1158  ;; check if vec is a vector of character symbols  ;; check if vec is a vector of character symbols
1159  (defun viper-char-symbol-sequence-p (vec)  (defun viper-char-symbol-sequence-p (vec)
1160    (and    (and
# Line 1161  Line 1164 
1164            (mapcar (lambda (elt)            (mapcar (lambda (elt)
1165                      (and (symbolp elt) (= (length (symbol-name elt)) 1)))                      (and (symbolp elt) (= (length (symbol-name elt)) 1)))
1166                    vec)))))                    vec)))))
1167        
1168      
1169  (defun viper-char-array-p (array)  (defun viper-char-array-p (array)
1170    (eval (cons 'and (mapcar 'viper-characterp array))))    (eval (cons 'and (mapcar 'viper-characterp array))))
1171    
# Line 1185  Line 1188 
1188                    (t (prin1-to-string (vconcat temp)))))                    (t (prin1-to-string (vconcat temp)))))
1189            ((viper-char-symbol-sequence-p event-seq)            ((viper-char-symbol-sequence-p event-seq)
1190             (mapconcat 'symbol-name event-seq ""))             (mapconcat 'symbol-name event-seq ""))
1191            ((and (vectorp event-seq)            ((and (vectorp event-seq)
1192                  (viper-char-array-p                  (viper-char-array-p
1193                   (setq temp (mapcar 'viper-key-to-character event-seq))))                   (setq temp (mapcar 'viper-key-to-character event-seq))))
1194             (mapconcat 'char-to-string temp ""))             (mapconcat 'char-to-string temp ""))
# Line 1198  Line 1201 
1201                )                )
1202               events               events
1203               ""))               ""))
1204              
1205        
1206  (defun viper-read-char-exclusive ()  (defun viper-read-char-exclusive ()
1207    (let (char    (let (char
1208          (echo-keystrokes 1))          (echo-keystrokes 1))
# Line 1227  Line 1230 
1230                (= 1 (length (symbol-name (nth 1 key)))))                (= 1 (length (symbol-name (nth 1 key)))))
1231           (read (format "?\\C-%s" (symbol-name (nth 1 key)))))           (read (format "?\\C-%s" (symbol-name (nth 1 key)))))
1232          (t key)))          (t key)))
1233        
1234          
1235  (defun viper-setup-master-buffer (&rest other-files-or-buffers)  (defun viper-setup-master-buffer (&rest other-files-or-buffers)
1236    "Set up the current buffer as a master buffer.    "Set up the current buffer as a master buffer.
1237  Arguments become related buffers.  This function should normally be used in  Arguments become related buffers.  This function should normally be used in
1238  the `Local variables' section of a file."  the `Local variables' section of a file."
1239    (setq viper-related-files-and-buffers-ring    (setq viper-related-files-and-buffers-ring
1240          (make-ring (1+ (length other-files-or-buffers))))          (make-ring (1+ (length other-files-or-buffers))))
1241    (mapcar '(lambda (elt)    (mapcar '(lambda (elt)
1242               (viper-ring-insert viper-related-files-and-buffers-ring elt))               (viper-ring-insert viper-related-files-and-buffers-ring elt))
# Line 1274  Usually contains ` ', linefeed, TAB or f Line 1277  Usually contains ` ', linefeed, TAB or f
1277    
1278    
1279  ;; Set Viper syntax classes and related variables according to  ;; Set Viper syntax classes and related variables according to
1280  ;; `viper-syntax-preference'.    ;; `viper-syntax-preference'.
1281  (defun viper-update-syntax-classes (&optional set-default)  (defun viper-update-syntax-classes (&optional set-default)
1282    (let ((preference (cond ((eq viper-syntax-preference 'emacs)    (let ((preference (cond ((eq viper-syntax-preference 'emacs)
1283                             "w")   ; Viper words have only Emacs word chars                             "w")   ; Viper words have only Emacs word chars
# Line 1335  This is most appropriate for major modes Line 1338  This is most appropriate for major modes
1338  `emacs' means Viper words are the same as Emacs words as specified by Emacs  `emacs' means Viper words are the same as Emacs words as specified by Emacs
1339  syntax tables.  syntax tables.
1340  This option is appropriate if you like Emacs-style words."  This option is appropriate if you like Emacs-style words."
1341    :type '(radio (const strict-vi) (const reformed-vi)    :type '(radio (const strict-vi) (const reformed-vi)
1342                   (const extended) (const emacs))                   (const extended) (const emacs))
1343    :set 'viper-set-syntax-preference    :set 'viper-set-syntax-preference
1344    :group 'viper)    :group 'viper)
# Line 1379  This option is appropriate if you like E Line 1382  This option is appropriate if you like E
1382  (defun viper-skip-alpha-forward (&optional addl-chars)  (defun viper-skip-alpha-forward (&optional addl-chars)
1383    (or (stringp addl-chars) (setq addl-chars ""))    (or (stringp addl-chars) (setq addl-chars ""))
1384    (viper-skip-syntax    (viper-skip-syntax
1385     'forward     'forward
1386     (cond ((eq viper-syntax-preference 'strict-vi)     (cond ((eq viper-syntax-preference 'strict-vi)
1387            "")            "")
1388           (t viper-ALPHA-char-class))           (t viper-ALPHA-char-class))
# Line 1390  This option is appropriate if you like E Line 1393  This option is appropriate if you like E
1393  (defun viper-skip-alpha-backward (&optional addl-chars)  (defun viper-skip-alpha-backward (&optional addl-chars)
1394    (or (stringp addl-chars) (setq addl-chars ""))    (or (stringp addl-chars) (setq addl-chars ""))
1395    (viper-skip-syntax    (viper-skip-syntax
1396     'backward     'backward
1397     (cond ((eq viper-syntax-preference 'strict-vi)     (cond ((eq viper-syntax-preference 'strict-vi)
1398            "")            "")
1399           (t viper-ALPHA-char-class))           (t viper-ALPHA-char-class))
# Line 1401  This option is appropriate if you like E Line 1404  This option is appropriate if you like E
1404  ;; weird syntax tables may confuse strict-vi style  ;; weird syntax tables may confuse strict-vi style
1405  (defsubst viper-skip-all-separators-forward (&optional within-line)  (defsubst viper-skip-all-separators-forward (&optional within-line)
1406    (if (eq viper-syntax-preference 'strict-vi)    (if (eq viper-syntax-preference 'strict-vi)
1407        (if within-line        (if within-line
1408            (skip-chars-forward viper-strict-SEP-chars-sans-newline)            (skip-chars-forward viper-strict-SEP-chars-sans-newline)
1409          (skip-chars-forward viper-strict-SEP-chars))          (skip-chars-forward viper-strict-SEP-chars))
1410      (viper-skip-syntax 'forward      (viper-skip-syntax 'forward
# Line 1410  This option is appropriate if you like E Line 1413  This option is appropriate if you like E
1413                         (if within-line (viper-line-pos 'end)))))                         (if within-line (viper-line-pos 'end)))))
1414  (defsubst viper-skip-all-separators-backward (&optional within-line)  (defsubst viper-skip-all-separators-backward (&optional within-line)
1415    (if (eq viper-syntax-preference 'strict-vi)    (if (eq viper-syntax-preference 'strict-vi)
1416        (if within-line        (if within-line
1417            (skip-chars-backward viper-strict-SEP-chars-sans-newline)            (skip-chars-backward viper-strict-SEP-chars-sans-newline)
1418          (skip-chars-backward viper-strict-SEP-chars))          (skip-chars-backward viper-strict-SEP-chars))
1419      (viper-skip-syntax 'backward      (viper-skip-syntax 'backward
# Line 1434  This option is appropriate if you like E Line 1437  This option is appropriate if you like E
1437       'forward       'forward
1438       (concat "^" viper-ALPHA-char-class viper-SEP-char-class)       (concat "^" viper-ALPHA-char-class viper-SEP-char-class)
1439       ;; Emacs may consider some of these as words, but we don't want them       ;; Emacs may consider some of these as words, but we don't want them
1440       viper-non-word-characters       viper-non-word-characters
1441       (viper-line-pos 'end))))       (viper-line-pos 'end))))
1442  (defun viper-skip-nonalphasep-backward ()  (defun viper-skip-nonalphasep-backward ()
1443    (if (eq viper-syntax-preference 'strict-vi)    (if (eq viper-syntax-preference 'strict-vi)
# Line 1472  This option is appropriate if you like E Line 1475  This option is appropriate if you like E
1475                  (t nil)))                  (t nil)))
1476      (if (memq ?^ syntax) (setq negated-syntax t))      (if (memq ?^ syntax) (setq negated-syntax t))
1477    
1478      (while (and (not (= local 0))      (while (and (not (= local 0))
1479                  (cond ((eq direction 'forward)                  (cond ((eq direction 'forward)
1480                         (not (eobp)))                         (not (eobp)))
1481                        (t (not (bobp)))))                        (t (not (bobp)))))
1482        (setq char-looked-at (viper-char-at-pos direction)        (setq char-looked-at (viper-char-at-pos direction)
# Line 1504  This option is appropriate if you like E Line 1507  This option is appropriate if you like E
1507        (setq total (+ total local)))        (setq total (+ total local)))
1508      total      total
1509      ))      ))
     
1510    
1511      
1512    
1513  (provide 'viper-util)  (provide 'viper-util)
1514      
1515    
1516  ;;; Local Variables:  ;;; Local Variables:
1517  ;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)  ;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)

Legend:
Removed from v.1.47  
changed lines
  Added in v.1.47.4.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26