128 lines
3.9 KiB
Plaintext
128 lines
3.9 KiB
Plaintext
;;;;
|
|
;;;; Focus management
|
|
;;;;
|
|
;;;; 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: 27-Jul-1995 14:10
|
|
;;;; Last file update: 3-Sep-1999 19:51 (eg)
|
|
;;;;
|
|
|
|
(select-module Tk)
|
|
|
|
;; tk_focusNext --
|
|
;; This procedure returns the name of the next window after "w" in
|
|
;; "focus order" (the window that should receive the focus next if
|
|
;; Tab is typed in w). "Next" is defined by a pre-order search
|
|
;; of a top-level and its non-top-level descendants, with the stacking
|
|
;; order determining the order of siblings. The "-takefocus" options
|
|
;; on windows determine whether or not they should be skipped.
|
|
|
|
(define Tk:focus-on (lambda (w) #t))
|
|
(define Tk:focus-off (lambda (w) #f))
|
|
|
|
(define Tk:focus-next #f) ; will be redefined below
|
|
(define Tk:focus-prev #f) ; will be redefined below
|
|
|
|
(let ()
|
|
(define (all-children w)
|
|
(let ((res '()))
|
|
(for-each (lambda (x)
|
|
(unless (equal? x (winfo 'toplevel x))
|
|
;; x is not a toplevel
|
|
(set! res (append res (all-children x)))))
|
|
(winfo 'children w))
|
|
(cons w res)))
|
|
|
|
(define (focusable? w)
|
|
(let ((focus #t)
|
|
(value #f))
|
|
|
|
(if (winfo 'viewable w)
|
|
(begin
|
|
;; 1. See if this window tells something in its :takefocus option
|
|
(if (not (catch (set! value (tk-get w :takefocus))))
|
|
;; widget has :takefocus option
|
|
;; Remark: :takefocus option must be a closure. But original
|
|
;; Tcl/Tk code can define the focus action as "0" or "1".
|
|
;; Those values can be hard-coded in the Tk library. So take them
|
|
;; into account
|
|
(cond
|
|
((boolean? value) (set! focus value))
|
|
((closure? value) (set! focus (value w)))))
|
|
|
|
;; 2. See if the window is not disabled
|
|
(if focus
|
|
(if (not (catch (set! value (tk-get w :state))))
|
|
;; widget has a :state option
|
|
(set! focus (not (equal? value "disabled")))))
|
|
|
|
;; 3. Claim that the window is focuable inly if it exist some
|
|
;; keyboard binding associated to it
|
|
(if focus
|
|
(let ((p (open-output-string)))
|
|
(display (bind w) p)
|
|
(display (bind (winfo 'class w)) p)
|
|
(let ((s (get-output-string p)))
|
|
(set! focus (or (string-find? "Key" s)
|
|
(string-find? "Focus" s)))))))
|
|
;; w is not visible
|
|
(set! focus #f))
|
|
focus))
|
|
|
|
(define (find-next w l)
|
|
(let* ((len (length l))
|
|
(index (- len (length (member w l)))))
|
|
|
|
;; index is the position of the current widget in l
|
|
(let loop ((i (modulo (+ index 1) len)))
|
|
(if (= i index)
|
|
;; not found, return w
|
|
w
|
|
(let ((widget (list-ref l i)))
|
|
(if (focusable? widget)
|
|
widget
|
|
(loop (modulo (+ i 1) len))))))))
|
|
|
|
|
|
(set! Tk:focus-next
|
|
(lambda (w)
|
|
(let ((all (all-children (winfo 'toplevel w))))
|
|
(if (= (length all) 1)
|
|
(car all)
|
|
(find-next w all)))))
|
|
|
|
(set! Tk:focus-prev
|
|
(lambda (w)
|
|
(let ((all (all-children (winfo 'toplevel w))))
|
|
(if (= (length all) 1)
|
|
(car all)
|
|
(find-next w (reverse all)))))))
|
|
|
|
|
|
(define (Tk:focus-follows-mouse)
|
|
(let ((old (bind "all" "<Enter>"))
|
|
(script (lambda(|W| d)
|
|
(if (or (equal? d "NotifyAncestor")
|
|
(equal? d "NotifyNonlinear")
|
|
(equal? d "NotifyInferior"))
|
|
(focus |W|)))))
|
|
(add-binding "all" "<Enter>" script #f)))
|
|
|
|
|
|
|
|
|