;;;; ;;;; Initialization file for Tk ;;;; ;;;; This script is executed for each STk-based application. It arranges class ;;;; bindings for widgets. ;;;; ;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; Permission to use, copy, and/or distribute this software and its ;;;; documentation for any purpose and without fee is hereby granted, provided ;;;; that both the above copyright notice and this permission notice appear in ;;;; all copies and derived works. Fees for distribution or use of this ;;;; software or derived works may only be charged with express written ;;;; permission of the copyright holder. ;;;; 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 ;;;; ;;;; $Id: tk-init.stk 1.11 Fri, 10 Apr 1998 07:13:18 +0000 eg $ ;;;; ;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Creation date: 17-May-1993 12:35 ;;;; Last file update: 28-Mar-1998 16:56 ;;;; (unless (equal? *tk-version* "8.0") (error "wrong version of Tk loaded: need 8.0 (this version is ~A)" *tk-version*)) (select-module Tk) ;; The rest of this file belongs to the Tk module (import Scheme) ;; Prefer the Scheme bindings rather than the STk ones. (export-all-symbols) ;; Export all the symbols ;; Special user variables (define-variable *tk-strict-Motif* #f) ;; Turn off strict Motif look and feel (define-variable *image-path* #f) ;; Path for images (define-variable *help-path* #f) ;; Path for HTML help pages (define-variable *start-withdrawn* #t) ;; Start with *root* unmapped ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Utilities ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-macro (tk-get w option) `(,w 'cget ,option)) (define-macro (tk-set! w option . value) `(,w 'configure ,option ,@value)) (define (Tk-screen-changed screen) ;; This function is called when the screen is changed. Since I own only ;; one screen, I don't know what I must do here. screen) (define-macro (define-binding class event args . body) (if (null? body) `(bind ,class ,event "") `(bind ,class ,event (lambda ,args ,@body)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Following vars are used everywhere. So define them here (define tk::window #f) (define tk::button-window '()) (define tk::relief "sunken") (define tk::select-mode "char") (define tk::mouse-moved #f) (define tk::press-x 0) (define tk::press-y 0) (define tk::x 0) (define tk::y 0) (define tk::after-id "") (define tk::active-bg "") (define tk::active-fg "") (define tk::dragging #f) (define tk::buttons 0) (define tk::focus '()) (define tk::grab "") (define tk::inMenuButton '()) (define tk::posted #f) (define tk::selectMode '()) (define tk::cursor "") (define tk::kill-buffer "") ;; One kill buffer shared between all texts. ;; add-binding -- ;; This procedure adds a binding to a widget. It replaces the Tcl "+" mechanism ;; which is meaningless with closures. Furthermore, this mechanism permits ;; to add the binding BEFORE the old binding ;; (define (add-binding widget event binding before?) (let ((old (bind widget event))) (if (null? old) (bind widget event binding) ;;; We must find the parameters of the old and given bindings ;;; The new binding is a new closure with the union of these ;;; parameters. ;;; if: ;;; old binding is (lambda (x y) ....) ;;; given binding is (lambda (x t a) ...) ;;; We must construct the binding of the form ;;; (lambda (x y t a) ;;; ((lambda (x y) ....) x y) ;;; ((lambda (x t a) ....) x t a)) (let ((body-old (procedure-body (car old))) (body-new (procedure-body binding))) (if (and body-old body-new) (let ((p-old (cadr body-old)) (p-new (cadr body-new))) (bind widget event (if before? (eval `(lambda ,(set-union p-old p-new) (,binding ,@(cadr body-new)) ,old)) (eval `(lambda ,(set-union p-old p-new) ,old (,binding ,@(cadr body-new))))))) ;; (Error "add-binding: Incorrect binding ~S" binding)))))) ;; Tk:cancel-repeat -- ;; This procedure is invoked to cancel an auto-repeat action described ;; by tk::after-id. It's used by several widgets to auto-scroll ;; the widget when the mouse is dragged out of the widget with a ;; button pressed. (define (Tk:cancel-repeat) (after 'cancel tk::after-id) (set! tk::after-id "")) ;; Tk:tab-to-window -- ;; This procedure moves the focus to the given widget. If the widget ;; is an entry, it selects the entire contents of the widget. (define (Tk:tab-to-window w) (when (string=? (winfo 'class w) "Entry") (w 'select 'range 0 'end) (w 'icur 'end)) (focus w)) ;;;; ;;;; A procedure to forbid remote executution via the send Tk command ;;;; (define (inhibit-send) ;; Redefine send sommand (set! send (make-unbound)) ;; Issue a GC so that command is effectively deleted from Tk tables NOW (gc)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Withdraw the root window ;;;; ;;;; A lot of people dislike the fact that the root window is mapped ;;;; on screen when Tk is started, The code below, unmaps the *root* ;;;; window and make it appearing as soon as the first sub-window is ;;;; packed or some action is asked to the window manager for ;;;; *root*. With this code, the the behaviour is identical to the Tk ;;;; original one except that the empty squared window don't appears ;;;; on screen. The original behaviour can be recovered by setting ;;;; *start-withdrawn* to #f ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (when *start-withdrawn* ;; Start without mapping the root window. (wm 'withdraw ".") (let ((old-pack pack) (old-wm wm)) (set! pack (lambda l (let ((res (apply old-pack l))) (for-each (lambda (x) (when (and *start-withdrawn* (eq? (winfo 'toplevel x) *root*) (winfo 'manager x)) (wm 'deiconify *root*))) (winfo 'children *root*)) res))) (set! wm (lambda l (let ((res (apply old-wm l))) (unless (eq? (old-wm 'state *root*) 'withdrawn) ;; Previous wm call makes the *root* window no more withdrawn ;; Replace the pack and wm command by the original Tk ones (set! pack old-pack) (set! Tk:pack old-pack) (set! wm old-wm) (set! Tk:wm old-wm) (set! *start-withdrawn* #f)) res))))) ;;;; ;;;; Define widget which require a lot of initialization as a kind of autoload ;;;; This allows a faster loading for small programs which use only a few widgets ;;;; and decreases memory usage ;;;; (define-macro (%redefine-Tk-command widget file) (let ((synonym (string->symbol (format #f "tk:~A" widget)))) `(set! ,widget (let ((tk-cmd ,widget)) (lambda l ;; Load the library file (load ,(string-append *STk-library* "/STk/" file ".stk")) ;; Test here that old value is a true closure because when ;; using STklos some Tk commands are already defined as generic. ;; Reloading the file and setting widget and Tk:widget breaks ;; the generic function. Weak but it seems to work (if (closure? ,widget) (set! ,widget tk-cmd)) (if (closure? ,synonym) (set! ,synonym tk-cmd)) ;; Do the job (apply tk-cmd l)))))) (%redefine-Tk-command button "button") (%redefine-Tk-command checkbutton "button") (%redefine-Tk-command radiobutton "button") (%redefine-Tk-command entry "entry") (%redefine-Tk-command focus "focus") (%redefine-Tk-command listbox "listbox") (%redefine-Tk-command menu "menu") (%redefine-Tk-command menubutton "menu") (%redefine-Tk-command scale "scale") (%redefine-Tk-command scrollbar "scrollbar") (%redefine-Tk-command text "text") ;; ;; Make synonyms for all Tk-commands to "protect" them against redefinition. ;; This is no more necessary now with modules but some user code could rely on it. ;; (define Tk:button button) (define Tk:checkbutton checkbutton) (define Tk:canvas canvas) (define Tk:entry entry) (define Tk:frame frame) (define Tk:image image) (define Tk:label label) (define Tk:listbox listbox) (define Tk:menu menu) (define Tk:menubutton menubutton) (define Tk:message message) (define Tk:scale scale) (define Tk:scrollbar scrollbar) (define Tk:radiobutton radiobutton) (define Tk:text text) (define Tk:toplevel toplevel) (define Tk:after after) (define Tk:bind bind) (define Tk:bindtags bindtags) (define Tk:bell bell) (define Tk:clipboard clipboard) (define Tk:destroy destroy) (define Tk:focus focus) (define Tk:grab grab) (define Tk:lower lower) (define Tk:option option) (define Tk:pack pack) (define Tk:place place) (define Tk:raise raise) (define Tk:selection selection) (define Tk:tk tk) (define Tk:tkwait tkwait) (define Tk:update update) (define Tk:winfo winfo) (define Tk:wm wm) ;;;; ;;;; Default bindings ;;;; ;; Keyboard traversal (bind "all" "" (lambda (|W|) (Tk:tab-to-window (Tk:focus-next |W|)))) (bind "all" "" (lambda (|W|) (Tk:tab-to-window (Tk:focus-prev |W|)))) ;; Cut/Copy/Paste virtual events (case (os-kind) ((Windows) (event 'add "<>" "" "") (event 'add "<>" "" "") (event 'add "<>" "" "")) ((Unix) (event 'add "<>" "" "") (event 'add "<>" "" "") (event 'add "<>" "" "") ;; Add a trace to set and unset Motif bindings when the ;; *tk-strict-Motif* variable is changed (let ((trace (lambda () (let ((op (if *tk-strict-Motif* 'delete 'add))) (event op "<>" "") (event op "<>" "") (event op "<>" ""))))) (trace-var '*tk-strict-Motif* trace) (trace)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Initialisation of *image-path* and *help-path* ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set! *image-path* (append (list "" ".") (build-path-from-shell-variable "STK_IMAGE_PATH") (list (string-append *STk-library* "/Images")))) (set! *help-path* (append (list "" ".") (build-path-from-shell-variable "STK_HELP_PATH") (list (string-append *STk-library* "/Help")))) ;;;; ;;;; Some autoloads ;;;; (autoload "dialog" STk:make-dialog STk:center-window) (autoload "editor" ed) ; Editor must be changed (autoload "error" STk:report-error bgerror) (autoload "focus" Tk:focus-next Tk:focus-prev) (autoload "listener" listener) (autoload "palette" Tk:set-palette! Tk:bisque) (autoload "help" help STk:show-help-file) (autoload "menu" Tk:option-menu) (autoload "inspect-main" inspect view detail) (autoload "fileevent" Tk:fileevent fileevent) ; for backward compatibility (autoload "sterm" sterm) (autoload "www-browser" WWW:browser) ;============================================================================= ; ; Module STklos+Tk definition ; ; This module serves to define all the STklos classes and methods for ; working with Tk. It is defined here, even if you don't use STklos ; (you really must use it :) so that it can be imported before Tk. So, ; if functions are redefined in STklos for Tk they will be seen before ; the Tk ones. If the STklos is not used (it's a pity!), the module is ; just passed thru since it contains nothing. ; ;============================================================================= (define-module STklos+Tk (import STklos Tk)) (with-module STk ;; Make all Tk public symbols available to STk (import STklos+Tk Tk) ;; report-error as a kind of autoload (must be a closure, rather than an ;; autoload since C error function tests explicitely it is a closure before ;; applying its arguments (define (report-error . args) (apply STk:report-error args))) ;;;; ;;;; Retain now that Tk is now fully initialized ;;;; (set! Tk:initialized? #t)