395 lines
13 KiB
Plaintext
395 lines
13 KiB
Plaintext
;;;;
|
|
;;;; Initialization file for Tk
|
|
;;;;
|
|
;;;; This script is executed for each STk-based application. It arranges class
|
|
;;;; bindings for widgets.
|
|
;;;;
|
|
;;;; 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: 16-Sep-1999 16:48 (eg)
|
|
;;;;
|
|
|
|
(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))))
|
|
|
|
;;
|
|
;; Read and write access to the data associated to widget
|
|
;;
|
|
(define (set-widget-property! widget name value)
|
|
(let ((data (get-widget-data widget)))
|
|
(if (or (not data) (null? data))
|
|
(set-widget-data! widget (list name value))
|
|
(let ((prop (memv name data)))
|
|
(if prop
|
|
(set-cdr! prop (cons value (cddr prop)))
|
|
(set-widget-data! widget (append (list name value) data)))))))
|
|
|
|
|
|
(define (get-widget-property widget name . default)
|
|
(let ((data (get-widget-data widget)))
|
|
(if (or (not data) (null? data))
|
|
(if (null? default)
|
|
(error "get-widget-property: No property ~S in ~S" name widget)
|
|
(car default))
|
|
(apply get-keyword name data default))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; 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::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 (equal? (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" "<Tab>" (lambda (|W|) (Tk:tab-to-window (Tk:focus-next |W|))))
|
|
(bind "all" "<Shift-Tab>" (lambda (|W|) (Tk:tab-to-window (Tk:focus-prev |W|))))
|
|
|
|
;; Cut/Copy/Paste virtual events
|
|
(case (os-kind)
|
|
((Windows) (event 'add "<<Cut>>" "<Control-Key-x>" "<Shift-Key-Delete>")
|
|
(event 'add "<<Copy>>" "<Control-Key-c>" "<Control-Key-Insert>")
|
|
(event 'add "<<Paste>>" "<Control-Key-v>" "<Shift-Key-Insert>")
|
|
(event 'add "<<PasteSelection>>" "<ButtonRelease-2>" ))
|
|
((Unix) (event 'add "<<Cut>>" "<Control-Key-x>" "<Key-F20>")
|
|
(event 'add "<<Copy>>" "<Control-Key-c>" "<Key-F16>")
|
|
(event 'add "<<Paste>>" "<Control-Key-v>" "<Key-F18>")
|
|
(event 'add "<<PasteSelection>>" "<ButtonRelease-2>" )
|
|
;; 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 "<<Cut>>" "<Control-Key-w>")
|
|
(event op "<<Copy>>" "<Meta-Key-w>")
|
|
(event op "<<Paste>>" "<Control-Key-y>")))))
|
|
(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 "edit" ed)
|
|
(autoload "focus" Tk:focus-next Tk:focus-prev)
|
|
(autoload "listener" listener)
|
|
(autoload "palette" Tk:set-palette! Tk:bisque)
|
|
(autoload "menu" Tk:option-menu)
|
|
(autoload "inspect-main" inspect view detail)
|
|
(autoload "fileevent" Tk:fileevent fileevent) ; for backward compatibility
|
|
(autoload "sterm" sterm)
|
|
(autoload "image" find-image make-image change-image delete-image)
|
|
;(autoload "error" STk:report-error bgerror)))
|
|
(when (eq? (os-kind) 'Unix)
|
|
(autoload "tk-unix" Tk:choose-color Tk:message-box
|
|
Tk:get-open-file Tk:get-save-file Tk:get-file))
|
|
|
|
|
|
(define (tk-set-error-handler!)
|
|
(autoload "error" STk:report-error bgerror))
|
|
|
|
;=============================================================================
|
|
;
|
|
; 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 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))
|
|
|
|
;; Global help functions which are defined when Tk is loaded
|
|
(autoload "help" help STk:show-help-file)
|
|
(autoload "www-browser" WWW:browser WWW:mailto)
|
|
(autoload "class-browser" class-browser))
|
|
|
|
;;;;
|
|
;;;; Retain now that Tk is now fully initialized
|
|
;;;;
|
|
(set! Tk:initialized? #t)
|