540 lines
17 KiB
Plaintext
540 lines
17 KiB
Plaintext
;;;;
|
|
;;;; Entries bindings and procs
|
|
;;;;
|
|
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; This software is a derivative work of other copyrighted softwares; the
|
|
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
|
|
;;;;
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 17-May-1993 12:35
|
|
;;;; Last file update: 3-Sep-1999 19:50 (eg)
|
|
;;;;
|
|
|
|
(select-module Tk)
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Class bindings for entry widgets.
|
|
;; ----------------------------------------------------------------------
|
|
;;
|
|
;; Elements used in this file:
|
|
;;
|
|
;; after-id - If non-null, it means that auto-scanning is underway
|
|
;; and it gives the "after" id for the next auto-scan
|
|
;; command to be executed.
|
|
;; mouse-moved - Non-zero means the mouse has moved a significant
|
|
;; amount since the button went down (so, for example,
|
|
;; start dragging out a selection).
|
|
;; press-x - X-coordinate at which the mouse button was pressed.
|
|
;; select-mode - The style of selection currently underway:
|
|
;; char, word, or line.
|
|
;; x, y - Last known mouse coordinates for scanning
|
|
;; and auto-scanning.
|
|
;;-------------------------------------------------------------------------
|
|
|
|
|
|
;;
|
|
;; Utilities
|
|
;;
|
|
(define (Tk:word-character c)
|
|
(or (char-alphabetic? c)
|
|
(char-numeric? c)
|
|
(char=? c #\-)
|
|
(char=? c #\*)))
|
|
|
|
(define (Tk:word-separator c)
|
|
(not (Tk:word-character c)))
|
|
|
|
(define (Tk:end-of-word str index . separator)
|
|
(let ((len (string-length str))
|
|
(sep (if (null? separator) Tk:word-separator separator)))
|
|
(let loop ((i index))
|
|
(cond
|
|
((= len 0) 0)
|
|
((>= i len) len)
|
|
((sep (string-ref str i)) (if (= index i) (+ i 1) i))
|
|
(ELSE (loop (+ i 1)))))))
|
|
|
|
(define (Tk:beginning-of-word str index . separator)
|
|
(let ((len (string-length str))
|
|
(sep (if (null? separator) Tk:word-separator separator)))
|
|
(let loop ((i index))
|
|
(cond
|
|
((= len 0) 0)
|
|
((= i -1) 0)
|
|
((>= i len) (loop (- len 1)))
|
|
((sep (string-ref str i)) (if (= index i) i (+ i 1)))
|
|
(ELSE (loop (- i 1)))))))
|
|
|
|
;=============================================================================
|
|
|
|
;; Tk:entry-button-1 --
|
|
;; This procedure is invoked to handle button-1 presses in "Entry"
|
|
;; widgets. It moves the insertion cursor, sets the selection anchor,
|
|
;; and claims the input focus.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window in which the button was pressed.
|
|
;; x - The x-coordinate of the button press.
|
|
|
|
(define (Tk:entry-button-1 w x)
|
|
(let ((pos (format #f "@~A" x)))
|
|
(set! tk::select-mode "char")
|
|
(set! tk::mouse-moved #f)
|
|
(set! tk::press-x x)
|
|
(w 'icursor (Tk:entry-closest-gap w x))
|
|
(w 'selection 'from 'insert)
|
|
(if (equal? (tk-get w :state) "normal")
|
|
(focus w))))
|
|
|
|
;; Tk:entry-mouse-select --
|
|
;; This procedure is invoked when dragging out a selection with
|
|
;; the mouse. Depending on the selection mode (character, word,
|
|
;; line) it selects in different-sized units. This procedure
|
|
;; ignores mouse motions initially until the mouse has moved from
|
|
;; one character to another or until there have been multiple clicks.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window in which the button was pressed.
|
|
;; x - The x-coordinate of the mouse.
|
|
|
|
(define (Tk:entry-mouse-select w x)
|
|
(let* ((cur (Tk:entry-closest-gap w x))
|
|
(anchor (w 'index 'anchor)))
|
|
|
|
(if (or (equal? cur anchor)
|
|
(>= (abs (- tk::press-x x)) 3))
|
|
(set! tk::mouse-moved #t))
|
|
|
|
(cond
|
|
((string=? tk::select-mode "char")
|
|
(if tk::mouse-moved
|
|
(cond
|
|
((< cur anchor) (w 'selection 'range cur anchor))
|
|
((> cur anchor) (w 'selection 'range anchor cur))
|
|
(ELSE (w 'selection 'clear)))))
|
|
((string=? tk::select-mode "word")
|
|
(if (< cur (w 'index 'anchor))
|
|
(w 'selection 'range
|
|
(Tk:beginning-of-word (w 'get) cur)
|
|
(Tk:end-of-word (w 'get) (- anchor 1)))
|
|
(w 'selection 'range
|
|
(Tk:beginning-of-word (w 'get) anchor)
|
|
(Tk:end-of-word (w 'get) (- cur 1)))))
|
|
((string=? tk::select-mode "line")
|
|
(w 'selection 'range 0 'end)))
|
|
|
|
(update 'idletasks)))
|
|
|
|
|
|
;; Tk:entry-auto-scan --
|
|
;; This procedure is invoked when the mouse leaves an "Entry" window
|
|
;; with button 1 down. It scrolls the window left or right,
|
|
;; depending on where the mouse is, and reschedules itself as an
|
|
;; "after" command so that the window continues to scroll until the
|
|
;; mouse moves back into the window or the mouse button is released.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window.
|
|
|
|
(define (Tk:entry-auto-scan w)
|
|
(when (winfo 'exists w)
|
|
(let ((x tk::x))
|
|
(if (>= x (winfo 'width w))
|
|
(begin
|
|
(w 'xview 'scroll 2 'units)
|
|
(Tk:entry-mouse-select w x))
|
|
(if (< x 0)
|
|
(w 'xview 'scroll -2 'units)
|
|
(Tk:entry-mouse-select w x)))
|
|
|
|
(set! tk::after-id (after 50 (lambda ()
|
|
(Tk:entry-auto-scan w)))))))
|
|
|
|
;; Tk:entry-key-select --
|
|
;; This procedure is invoked when stroking out selections using the
|
|
;; keyboard. It moves the cursor to a new position, then extends
|
|
;; the selection to that position.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window.
|
|
;; new - A new position for the insertion cursor (the cursor hasn't
|
|
;; actually been moved to this position yet).
|
|
|
|
(define (Tk:entry-key-select w new)
|
|
(if (w 'selection 'present)
|
|
(w 'selection 'adjust new)
|
|
(begin
|
|
(w 'selection 'from 'insert)
|
|
(w 'selection 'to new)))
|
|
(w 'icursor new))
|
|
|
|
;; Tk:entry-Insert --
|
|
;; Insert a string into an "Entry" at the point of the insertion cursor.
|
|
;; If there is a selection in the "Entry", and it covers the point of the
|
|
;; insertion cursor, then delete the selection before inserting.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window in which to insert the string
|
|
;; s - The string to insert (usually just a single character)
|
|
|
|
(define (Tk:entry-insert w s)
|
|
(unless (equal? s "")
|
|
(let ((insert (w 'index 'insert)))
|
|
(catch
|
|
(if (and (<= (w 'index 'sel.first) insert)
|
|
(>= (w 'index 'sel.last) insert))
|
|
(w 'delete 'sel.first 'sel.last))))
|
|
(w 'insert 'insert s)
|
|
(Tk:entry-see-insert w)))
|
|
|
|
;; Tk:entry-backspace --
|
|
;; Backspace over the character just before the insertion cursor.
|
|
;; If backspacing would move the cursor off the left edge of the
|
|
;; window, reposition the cursor at about the middle of the window.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window in which to backspace.
|
|
|
|
(define (Tk:entry-backspace w)
|
|
(if (w 'selection 'present)
|
|
(w 'delete 'sel.first 'sel.last)
|
|
(let ((x (- (w 'index 'insert) 1)))
|
|
(if (>= x 0) (w 'delete x))
|
|
(when (>= (w 'index "@0")
|
|
(w 'index 'insert))
|
|
(let* ((range (w 'xview))
|
|
(left (car range))
|
|
(right (cadr range)))
|
|
(w 'xview 'moveto (- left (/ (- right left) 2.0))))))))
|
|
|
|
;; Tk:entry-see-insert --
|
|
;; Make sure that the insertion cursor is visible in the "Entry" window.
|
|
;; If not, adjust the view so that it is.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window.
|
|
|
|
(define (Tk:entry-see-insert w)
|
|
(let ((c (w 'index 'insert))
|
|
(left (w 'index "@0")))
|
|
|
|
(if (> left c)
|
|
(w 'xview c)
|
|
(let ((x (winfo 'width w)))
|
|
(while (and (<= (w 'index (format #f "@~A" x)) c)
|
|
(< left c))
|
|
(set! left (+ left 1))
|
|
(w 'xview left))))))
|
|
|
|
;; Tk:entry-set-cursor -
|
|
;; Move the insertion cursor to a given position in an "Entry". Also
|
|
;; clears the selection, if there is one in the "Entry", and makes sure
|
|
;; that the insertion cursor is visible.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The "Entry" window.
|
|
;; pos - The desired new position for the cursor in the window.
|
|
|
|
(define (Tk:entry-set-cursor w pos)
|
|
(w 'icursor pos)
|
|
(w 'selection 'clear)
|
|
(Tk:entry-see-insert w))
|
|
|
|
;; Tk:entry-Transpose -
|
|
;; This procedure implements the "transpose" function for "Entry" widgets.
|
|
;; It tranposes the characters on either side of the insertion cursor,
|
|
;; unless the cursor is at the end of the line. In this case it
|
|
;; transposes the two characters to the left of the cursor. In either
|
|
;; case, the cursor ends up to the right of the transposed characters.
|
|
;;
|
|
;; w - The "Entry" window.
|
|
|
|
(define (Tk:entry-transpose w)
|
|
(let ((i (w 'index 'insert)))
|
|
(if (< i (w 'index 'end))
|
|
(set! i (+ i 1)))
|
|
(let ((first (- i 2)))
|
|
(if (>= first 0)
|
|
(let* ((str (w 'get))
|
|
(new (string (string-ref str (- i 1)) (string-ref str first))))
|
|
(w 'delete first i)
|
|
(w 'insert 'insert new)
|
|
(Tk:entry-see-insert w))))))
|
|
|
|
;; Tk:entry-closest-gap --
|
|
;; Given x and y coordinates, this procedure finds the closest boundary
|
|
;; between characters to the given coordinates and returns the index
|
|
;; of the character just after the boundary.
|
|
;;
|
|
;; w - The entry window.
|
|
;; x - X-coordinate within the window.
|
|
|
|
(define (Tk:entry-closest-gap w x)
|
|
(let* ((pos (w 'index (format #f "@~A" x)))
|
|
(bbox (w 'bbox pos)))
|
|
(if (< [- x (list-ref bbox 0)] (/ (list-ref bbox 2) 2))
|
|
pos
|
|
(+ pos 1))))
|
|
|
|
|
|
;; Tk:entry-paste --
|
|
;; This procedure sets the insertion cursor to the current mouse position,
|
|
;; pastes the selection there, and sets the focus to the window.
|
|
;;
|
|
;; w - The entry window.
|
|
;; x - X position of the mouse.
|
|
|
|
(define (Tk:entry-paste w x)
|
|
(w 'icursor (Tk:entry-closest-gap w x))
|
|
(catch (w 'insert 'insert (selection 'get :displayof w)))
|
|
(if (string=? (tk-get w :state) "normal")
|
|
(focus w)))
|
|
|
|
|
|
;;-------------------------------------------------------------------------
|
|
;; The code below creates the default class bindings for entries.
|
|
;;-------------------------------------------------------------------------
|
|
|
|
(define-binding "Entry" "<<Cut>>" (|W|)
|
|
(clipboard 'clear :displayof |W|)
|
|
(catch
|
|
(clipboard 'append :displayof |W|
|
|
(substring (|W| 'get)
|
|
(|W| 'index 'sel.first)
|
|
(|W| 'index 'sel.last)))
|
|
(|W| 'delete 'sel.first 'sel.last)))
|
|
|
|
(define-binding "Entry" "<<Copy>>" (|W|)
|
|
(clipboard 'clear :displayof |W|)
|
|
(catch
|
|
(clipboard 'append :displayof |W|
|
|
(substring (|W| 'get)
|
|
(|W| 'index 'sel.first)
|
|
(|W| 'index 'sel.last)))))
|
|
|
|
|
|
(define-binding "Entry" "<<Paste>>" (|W|)
|
|
(catch
|
|
(when (eqv? (os-kind) 'Unix)
|
|
(catch (|W| 'delete 'sel.first 'sel.last)))
|
|
(|W| 'insert 'insert (selection 'get :displayof |W|
|
|
:selection "CLIPBOARD"))
|
|
(Tk:entry-see-insert |W|)))
|
|
|
|
(define-binding "Entry" "<<Clear>>" (|W|)
|
|
(|W| 'delete 'sel.first 'sel.last))
|
|
|
|
(define-binding "Entry" "<<PasteSelection>>" (|W| x)
|
|
(when (or *tk-strict-Motif* (not tk::mouse-moved))
|
|
(Tk:entry-paste |W| x)))
|
|
|
|
(define-binding "Entry" "<1>" (|W| x)
|
|
(Tk:entry-button-1 |W| x)
|
|
(|W| 'selection 'clear))
|
|
|
|
(define-binding "Entry" "<B1-Motion>" (|W| x)
|
|
(set! tk::x x)
|
|
(Tk:entry-mouse-select |W| x))
|
|
|
|
(define-binding "Entry" "<Double-1>" (|W| x)
|
|
(set! tk::select-mode "word")
|
|
(Tk:entry-mouse-select |W| x)
|
|
(catch
|
|
(|W| 'icursor 'sel.first)))
|
|
|
|
(define-binding "Entry" "<Triple-1>" (|W| x)
|
|
(set! tk::select-mode "line")
|
|
(Tk:entry-mouse-select |W| x)
|
|
(|W| 'icursor 0))
|
|
|
|
(define-binding "Entry" "<Shift-1>" (|W| x)
|
|
(set! tk::select-mode "char")
|
|
(|W| 'selection 'adjust (format #f "@~A" x)))
|
|
|
|
(define-binding "Entry" "<Double-Shift-1>" (|W| x)
|
|
(set! tk::select-mode "word")
|
|
(Tk:entry-mouse-select |W| x))
|
|
|
|
(define-binding "Entry" "<Triple-Shift-1>" (|W| x)
|
|
(set! tk::select-mode "line")
|
|
(Tk:entry-mouse-select |W| x))
|
|
|
|
(define-binding "Entry" "<B1-Leave>" (|W| x)
|
|
(set! tk::x x)
|
|
(Tk:entry-auto-scan |W|))
|
|
|
|
(define-binding "Entry" "<B1-Enter>" ()
|
|
(Tk:cancel-repeat))
|
|
|
|
(define-binding "Entry" "<ButtonRelease-1>" ()
|
|
(Tk:cancel-repeat))
|
|
|
|
(define-binding "Entry" "<Control-1>" (|W| x)
|
|
(|W| 'icursor (format #f "@~A" x)))
|
|
|
|
|
|
(define-binding "Entry" "<Left>" (|W|)
|
|
(Tk:entry-set-cursor |W| (- (|W| 'index 'insert) 1)))
|
|
|
|
(define-binding "Entry" "<Right>" (|W|)
|
|
(Tk:entry-set-cursor |W| (+ (|W| 'index 'insert) 1)))
|
|
|
|
(define-binding "Entry" "<Shift-Left>" (|W|)
|
|
(Tk:entry-key-select |W| (- (|W| 'index 'insert) 1))
|
|
(Tk:entry-see-insert |W|))
|
|
|
|
(define-binding "Entry" "<Shift-Right>" (|W|)
|
|
(Tk:entry-key-select |W| (+ (|W| 'index 'insert) 1))
|
|
(Tk:entry-see-insert |W|))
|
|
|
|
(define-binding "Entry" "<Control-Left>" (|W|)
|
|
(Tk:entry-set-cursor |W|
|
|
(Tk:beginning-of-word (|W| 'get)
|
|
(- (|W| 'index 'insert) 1))))
|
|
|
|
(define-binding "Entry" "<Control-Right>" (|W|)
|
|
(Tk:entry-set-cursor |W| (Tk:end-of-word (|W| 'get) (|W| 'index 'insert))))
|
|
|
|
(define-binding "Entry" "<Shift-Control-Left>" (|W|)
|
|
(Tk:entry-key-select |W|
|
|
(Tk:beginning-of-word (|W| 'get)
|
|
(- (|W| 'index 'insert) 1)))
|
|
(Tk:entry-see-insert |W|))
|
|
|
|
(define-binding "Entry" "<Shift-Control-Right>" (|W|)
|
|
(Tk:entry-key-select |W| (Tk:end-of-word (|W| 'get) (|W| 'index 'insert)))
|
|
(Tk:entry-see-insert |W|))
|
|
|
|
(define-binding "Entry" "<Home>" (|W|)
|
|
(Tk:entry-set-cursor |W| 0))
|
|
|
|
(define-binding "Entry" "<Shift-Home>" (|W|)
|
|
(Tk:entry-key-select |W| 0)
|
|
(Tk:entry-see-insert |W|))
|
|
|
|
(define-binding "Entry" "<End>" (|W|)
|
|
(Tk:entry-set-cursor |W| 'end))
|
|
|
|
(define-binding "Entry" "<Shift-End>" (|W|)
|
|
(Tk:entry-key-select |W| 'end)
|
|
(Tk:entry-see-insert |W|))
|
|
|
|
(define-binding "Entry" "<Delete>" (|W|)
|
|
(if (|W| 'selection 'present)
|
|
(|W| 'delete 'sel.first 'sel.last)
|
|
(|W| 'delete 'insert)))
|
|
|
|
(define-binding "Entry" "<BackSpace>" (|W|)
|
|
(Tk:entry-backspace |W|))
|
|
|
|
(define-binding "Entry" "<Control-space>" (|W|)
|
|
(|W| 'selection 'from 'insert))
|
|
|
|
(define-binding "Entry" "<Select>" (|W|)
|
|
(|W| 'selection 'from 'insert))
|
|
|
|
(define-binding "Entry" "<Control-Shift-space>" (|W|)
|
|
(|W| 'selection 'adjust 'insert))
|
|
|
|
(define-binding "Entry" "<Shift-Select>" (|W|)
|
|
(|W| 'selection 'adjust 'insert))
|
|
|
|
(define-binding "Entry" "<Control-slash>" (|W|)
|
|
(|W| 'selection 'range 0 'end))
|
|
|
|
(define-binding "Entry" "<Control-backslash>" (|W|)
|
|
(|W| 'selection 'clear))
|
|
|
|
(define-binding "Entry" "<KeyPress>" (|W| |A|)
|
|
(Tk:entry-Insert |W| |A|))
|
|
|
|
|
|
;; Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
|
|
;; Otherwise, if a widget binding for one of these is defined, the
|
|
;; <KeyPress> class binding will also fire and insert the character,
|
|
;; which is wrong. Ditto for Escape, Return, and Tab.
|
|
(let ((nop (lambda () '())))
|
|
(bind "Entry" "<Alt-KeyPress>" nop)
|
|
(bind "Entry" "<Meta-KeyPress>" nop)
|
|
(bind "Entry" "<Control-KeyPress>" nop)
|
|
(bind "Entry" "<Escape>" nop)
|
|
(bind "Entry" "<Return>" nop)
|
|
(bind "Entry" "<KP_Enter>" nop)
|
|
(bind "Entry" "<Tab>" nop))
|
|
|
|
;; On Windows, paste is done using Shift-Insert. Shift-Insert already
|
|
;; generates the <<Paste>> event, so we don't need to do anything here.
|
|
(if (eqv? (os-kind) 'Unix)
|
|
(define-binding "Entry" "<Insert>" (|W|)
|
|
(catch
|
|
(Tk:entry-insert |W| (selection 'get :displayof |W|)))))
|
|
|
|
;; Additional emacs-like bindings:
|
|
|
|
(define-binding "Entry" "<Control-a>" (|W|)
|
|
(Tk:entry-set-cursor |W| 0))
|
|
|
|
(define-binding "Entry" "<Control-b>" (|W|)
|
|
(Tk:entry-set-cursor |W| (- (|W| 'index 'insert) 1)))
|
|
|
|
(define-binding "Entry" "<Control-d>" (|W|)
|
|
(|W| 'delete 'insert))
|
|
|
|
(define-binding "Entry" "<Control-e>" (|W|)
|
|
(Tk:entry-set-cursor |W| 'end))
|
|
|
|
(define-binding "Entry" "<Control-f>" (|W|)
|
|
(Tk:entry-set-cursor |W| (+ (|W| 'index 'insert) 1)))
|
|
|
|
(define-binding "Entry" "<Control-h>" (|W|)
|
|
(Tk:entry-backspace |W|))
|
|
|
|
(define-binding "Entry" "<Control-k>" (|W|)
|
|
(|W| 'delete 'insert 'end))
|
|
|
|
(define-binding "Entry" "<Control-t>" (|W|)
|
|
(Tk:entry-transpose |W|))
|
|
|
|
(define-binding "Entry" "<Meta-b>" (|W|)
|
|
(Tk:entry-set-cursor |W|
|
|
(Tk:beginning-of-word (|W| 'get)
|
|
(- (|W| 'index 'insert) 1))))
|
|
|
|
(define-binding "Entry" "<Meta-d>" (|W|)
|
|
(|W| 'delete 'insert (Tk:end-of-word (|W| 'get) (|W| 'index 'insert))))
|
|
|
|
(define-binding "Entry" "<Meta-f>" (|W|)
|
|
(Tk:entry-set-cursor |W| (Tk:end-of-word (|W| 'get) (|W| 'index 'insert))))
|
|
|
|
(define-binding "Entry" "<Meta-BackSpace>" (|W|)
|
|
(|W| 'delete (Tk:beginning-of-word (|W| 'get) (- (|W| 'index 'insert) 1))
|
|
'insert))
|
|
|
|
(define-binding "Entry" "<Meta-Delete>" (|W|)
|
|
(|W| 'delete (Tk:beginning-of-word (|W| 'get) (- (|W| 'index 'insert) 1))
|
|
'insert))
|
|
|
|
;; A few additional bindings of my own.
|
|
|
|
(define-binding "Entry" "<Shift-2>" (|W| x)
|
|
(|W| 'scan 'mark x)
|
|
(set! tk::x x)
|
|
(set! tk::mouse-moved #f))
|
|
|
|
(define-binding "Entry" "<Shift-B2-Motion>" (|W| x)
|
|
(if (> (abs (- x tk::x)) 2)
|
|
(set! tk::mouse-moved #t))
|
|
(|W| 'scan 'dragto x))
|
|
|