537 lines
17 KiB
Plaintext
537 lines
17 KiB
Plaintext
;;;;
|
|
;;;; B a s i c s . s t k -- Basic object class definition
|
|
;;;;
|
|
;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; 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.
|
|
;;;;
|
|
;;;; $Id: Basics.stklos 1.13 Wed, 23 Dec 1998 23:41:27 +0100 eg $
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 30-Mar-1993 15:39
|
|
;;;; Last file update: 19-Dec-1998 19:05
|
|
|
|
(require "Tk-meta")
|
|
|
|
(select-module STklos+Tk)
|
|
|
|
(export <Tk-object> ; The base class of all STklos widgets
|
|
<destroyed-object> ; Class in which destroyed objects are mapped
|
|
Id->instance ; really necessary?
|
|
parent ; Parent of a widget
|
|
Id ; Tk Id of a widget
|
|
Eid ; External Id of widget
|
|
tk-widget? ; a predicate
|
|
initialize-composite-widget ; must be overloaded for composite widgets
|
|
get-Tk-default-value ; Find the default value of a given Tk option
|
|
tk-constructor ; Returns the Tk-command associated to a class
|
|
destroy ; A redefinition of the Tk destroy
|
|
focus ; A redefinition of the Tk focus
|
|
bind ; A redefinition of the Tk bind
|
|
unpack) ; to avoid the (pack 'unpack ...) construction
|
|
|
|
;;;;
|
|
;;;; Utilities
|
|
;;;;
|
|
|
|
;;
|
|
;; Stuff for generating Tcl variable names
|
|
;;
|
|
(define (Tk::make-tk-name parent subname)
|
|
(format #f "~A.~A"
|
|
[if (or (eq? parent *root*) (eq? parent *top-root*))
|
|
""
|
|
(widget->string (slot-ref parent 'Id))]
|
|
[or subname (gensym "v")]))
|
|
;;
|
|
;; Setter for read-only slots
|
|
;;
|
|
(define (Tk:slot-is-read-only object slot)
|
|
(error "Value of the slot ``~S'' in ~S cannot be changed." slot object))
|
|
|
|
|
|
;;
|
|
;; Initialize the virtual "value" slot independently of the state of the object
|
|
;; (Tk forbid to give a value to a "disabled" object)
|
|
;;
|
|
(define (initialize-value-slot obj value)
|
|
(let ((s (slot-ref obj 'state)))
|
|
(unless (equal? s "normal")
|
|
(slot-set! obj 'state "normal")
|
|
(slot-set! obj 'value value)
|
|
(slot-set! obj 'state s))))
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-object>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-object> ()
|
|
((Id :getter Id) ;; Widget Id
|
|
(Eid :getter Eid) ;; External widget Id
|
|
(parent :getter parent :init-keyword :parent))) ;; Parent widget
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-widget>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-widget> (<Tk-object>)
|
|
()
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
;;;
|
|
;;; Utility method Id->instance
|
|
;;;
|
|
|
|
(define-method Id->instance ((id <widget>))
|
|
(let ((plist (get-widget-data id)))
|
|
(and plist (get-keyword :instance plist #f))))
|
|
|
|
(define-method Id->instance ((id <symbol>))
|
|
(let ((env (module-environment (find-module 'Tk))))
|
|
(and (symbol-bound? id env) (Id->instance (eval id env)))))
|
|
|
|
(define-method Id->instance ((id <string>))
|
|
(Id->instance (string->symbol id)))
|
|
|
|
(define-method Id ((self <widget>))
|
|
self)
|
|
|
|
;;;
|
|
;;; A kind of predicate to determine if an object is a Tk-widget descendant
|
|
;;;
|
|
(define-method tk-widget? ((self <Tk-widget>)) #t)
|
|
(define-method tk-widget? ((self <top>)) #f)
|
|
|
|
;;;
|
|
;;; Tk-write-object is called when a STklos object is passed to a Tk-command.
|
|
;;; By default, we do the same job as write; but if an object is a <Tk-widget>
|
|
;;; we will pass it its Eid. This method does this job.
|
|
;;;
|
|
(define-method Tk-write-object((self <Tk-widget>) port)
|
|
(write (widget-name (slot-ref self 'Eid)) port))
|
|
|
|
|
|
;;;
|
|
;;; get-Tk-default-value (find the default value of a given Tk option)
|
|
;;;
|
|
(define-method get-Tk-default-value ((self <Tk-widget>) slot)
|
|
(list-ref ((slot-ref self 'Id) 'configure (make-keyword slot)) 3))
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-simple-widget>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-simple-widget> (<Tk-widget>)
|
|
((background :accessor background
|
|
:init-keyword :background
|
|
:allocation :tk-virtual)
|
|
(border-width :accessor border-width
|
|
:init-keyword :border-width
|
|
:tk-name bd
|
|
:allocation :tk-virtual)
|
|
(cursor :accessor cursor
|
|
:init-keyword :cursor
|
|
:allocation :tk-virtual)
|
|
(highlight-background :accessor highlight-background
|
|
:init-keyword :highlight-background
|
|
:tk-name highlightback
|
|
:allocation :tk-virtual)
|
|
(highlight-color :accessor highlight-color
|
|
:init-keyword :highlight-color
|
|
:tk-name highlightcolor
|
|
:allocation :tk-virtual)
|
|
(highlight-thickness :accessor highlight-thickness
|
|
:init-keyword :highlight-thickness
|
|
:tk-name highlightthick
|
|
:allocation :tk-virtual)
|
|
(relief :accessor relief
|
|
:init-keyword :relief
|
|
:allocation :tk-virtual)
|
|
(take-focus :accessor take-focus
|
|
:init-keyword :take-focus
|
|
:tk-name takefocus
|
|
:allocation :tk-virtual)))
|
|
|
|
(define-method initialize ((self <Tk-simple-widget>) initargs)
|
|
(unless (get-keyword :Eid initargs #f)
|
|
;; This is not a composite widget. Initialize it
|
|
(let* ((parent (get-keyword :parent initargs *top-root*))
|
|
(Id (get-keyword :Id initargs #f))
|
|
(tk-options (get-keyword :tk-options initargs '()))
|
|
(Eid (apply (tk-constructor self)
|
|
(Tk::make-tk-name parent Id)
|
|
tk-options)))
|
|
(slot-set! self 'Id Eid) ; retain Tk command which implement this object
|
|
(slot-set! self 'Eid Eid) ; Eid an Id are the same for non composite
|
|
(slot-set! self 'parent parent)
|
|
|
|
;; Store the information <self> in the Tk command to allow widget->instance
|
|
;; conversion
|
|
(set-widget-data! Eid (list :instance self))))
|
|
|
|
;; Continue initializing
|
|
(next-method))
|
|
|
|
(define-method tk-constructor ((self <Tk-simple-widget>))
|
|
;; Returns the Tk function that makes an object of this kind.
|
|
(error "tk-constructor: method must be overridden for ~S"
|
|
(class-name (class-of self))))
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-composite-widget>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-composite-widget> (<Tk-widget>)
|
|
((frame :accessor frame-of)
|
|
(class :accessor class
|
|
:init-form "Composite"
|
|
:init-keyword :class))
|
|
:metaclass <Tk-composite-metaclass>)
|
|
|
|
(define-method initialize ((self <Tk-composite-widget>) initargs)
|
|
;; Initialize the class resource name of the object.
|
|
;; The code below is a little bit tricky because
|
|
;; 1. We don't use a clean object approach for composites (i.e
|
|
;; we use inheritance to avoid a lot of redefinitions).
|
|
;; 2. The class of a Tk frame or toplevel must be defined before
|
|
;; the object is created.
|
|
;;
|
|
(let* ((kwd (slot-definition-init-keyword
|
|
(class-slot-definition (class-of self) 'class)))
|
|
(class (and kwd (get-keyword kwd initargs #f))))
|
|
(if class
|
|
(slot-set! self 'class class)
|
|
(let ((init (slot-init-function (class-of self) 'class)))
|
|
(if init
|
|
(slot-set! self 'class (init))))))
|
|
|
|
;; To work properly, the parent slot must be set before anything
|
|
(let* ((parent (get-keyword :parent initargs *top-root*))
|
|
(Id (get-keyword :Id initargs #f))
|
|
(frame (make-composite-container self parent Id (slot-ref self 'class)))
|
|
(Eid (slot-ref frame 'Id)))
|
|
|
|
(slot-set! self 'parent parent)
|
|
(slot-set! self 'Eid Eid)
|
|
(slot-set! self 'frame frame)
|
|
|
|
;; Now call initialize-composite-widget
|
|
(initialize-composite-widget self initargs frame)
|
|
|
|
;; Continue to initialize with value passed to "make" (and signal that
|
|
;; Eid is already initialized)
|
|
(next-method self `(:Eid #t ,@initargs))
|
|
;; Store the information <self> in the Tk command to allow widget->instance
|
|
;; conversion
|
|
(set-widget-data! (slot-ref frame 'Id) (list :instance self))))
|
|
|
|
|
|
(define-method make-composite-container((self <Tk-composite-widget>)parent Id class)
|
|
(make <Frame> :parent parent :Id Id :border-width 0
|
|
:highlight-thickness 0 :class class))
|
|
|
|
(define-method initialize-composite-widget ((c <Tk-composite-widget>) args parent)
|
|
; Just fall thru when a composite inherit from a composite
|
|
(next-method))
|
|
|
|
(define-method initialize-composite-widget (c args parent)
|
|
;; We are here if no initialize-composite-widget method is provided for c
|
|
#f)
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-composite-toplevel>
|
|
;
|
|
; (as <Tk-composite-widget>, but in a separate window)
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-composite-toplevel> (<Tk-composite-widget>)
|
|
((title :initform ""
|
|
:accessor title
|
|
:init-keyword :title
|
|
:allocation :propagated
|
|
:propagate-to (frame))))
|
|
|
|
|
|
(define-method make-composite-container((self <Tk-composite-toplevel>) parent
|
|
Id class)
|
|
(make <Toplevel> :Id Id :border-width 0 :highlight-thickness 0 :class class))
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-sizeable>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-sizeable> ()
|
|
((width :accessor width :init-keyword :width :allocation :tk-virtual)
|
|
(height :accessor height :init-keyword :height :allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-simple-text>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-simple-text> ()
|
|
((anchor :accessor anchor
|
|
:init-keyword :anchor
|
|
:allocation :tk-virtual)
|
|
(environment :accessor environment
|
|
:init-keyword :environment
|
|
:allocation :tk-virtual)
|
|
(font :accessor font
|
|
:init-keyword :font
|
|
:allocation :tk-virtual)
|
|
(foreground :accessor foreground
|
|
:init-keyword :foreground
|
|
:allocation :tk-virtual)
|
|
(image :accessor image-of
|
|
:init-keyword :image
|
|
:allocation :tk-virtual)
|
|
(justify :accessor justify
|
|
:init-keyword :justify
|
|
:allocation :tk-virtual)
|
|
(pad-x :accessor pad-x
|
|
:init-keyword :pad-x
|
|
:allocation :tk-virtual
|
|
:tk-name padx)
|
|
(pad-y :accessor pad-y
|
|
:init-keyword :pad-y
|
|
:allocation :tk-virtual
|
|
:tk-name pady)
|
|
(text :accessor text-of
|
|
:init-keyword :text
|
|
:allocation :tk-virtual)
|
|
(text-variable :accessor text-variable
|
|
:init-keyword :text-variable
|
|
:allocation :tk-virtual
|
|
:tk-name textvar)
|
|
(underline :accessor underline
|
|
:init-keyword :underline
|
|
:allocation :tk-virtual)
|
|
(wrap-length :accessor wrap-length
|
|
:init-keyword :wrap-length
|
|
:tk-name wraplength
|
|
:allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-bitmap>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-bitmap> ()
|
|
((bitmap :accessor bitmap :init-keyword :bitmap :allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-reactive>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-reactive> ()
|
|
((active-background :accessor active-background
|
|
:init-keyword :active-background
|
|
:allocation :tk-virtual
|
|
:tk-name activebackground)
|
|
(active-foreground :accessor active-foreground
|
|
:init-keyword :active-foreground
|
|
:allocation :tk-virtual
|
|
:tk-name activeforeground)
|
|
(command :accessor command
|
|
:init-keyword :command
|
|
:allocation :tk-virtual)
|
|
(disabled-foreground :accessor disabled-foreground
|
|
:init-keyword :disabled-foreground
|
|
:allocation :tk-virtual
|
|
:tk-name disabledf)
|
|
(state :accessor state
|
|
:init-keyword :state
|
|
:allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-xyscrollable>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-xyscrollable> ()
|
|
((x-scroll-command :init-keyword :x-scroll-command
|
|
:accessor x-scroll-command
|
|
:tk-name xscrollcommand
|
|
:allocation :tk-virtual)
|
|
(y-scroll-command :init-keyword :y-scroll-command
|
|
:accessor y-scroll-command
|
|
:tk-name yscrollcommand
|
|
:allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-editable>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-editable> ()
|
|
((insert-background :init-keyword :insert-background
|
|
:accessor insert-background
|
|
:tk-name insertbackground
|
|
:allocation :tk-virtual)
|
|
(insert-border-width :init-keyword :insert-border-width
|
|
:accessor insert-border-width
|
|
:tk-name insertborderwidth
|
|
:allocation :tk-virtual)
|
|
(insert-off-time :init-keyword :insert-off-time
|
|
:accessor insert-off-time
|
|
:tk-name insertofftime
|
|
:allocation :tk-virtual)
|
|
(insert-on-time :init-keyword :insert-on-time
|
|
:accessor insert-on-time
|
|
:tk-name insertontime
|
|
:allocation :tk-virtual)
|
|
(insert-width :init-keyword :insert-width
|
|
:accessor insert-width
|
|
:tk-name insertwidth
|
|
:allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-selectable>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-selectable> ()
|
|
((select-background :init-keyword :select-background
|
|
:accessor select-background
|
|
:tk-name selectbackground
|
|
:allocation :tk-virtual)
|
|
(select-foreground :init-keyword :select-foreground
|
|
:accessor select-foreground
|
|
:tk-name selectforeground
|
|
:allocation :tk-virtual)
|
|
(select-border-width :init-keyword :select-border-width
|
|
:accessor select-border-width
|
|
:tk-name selectborderwidth
|
|
:allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Tk-text-selectable>
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Tk-text-selectable> ()
|
|
((export-selection :init-keyword :export-selection
|
|
:accessor export-selection
|
|
:tk-name exportselection
|
|
:allocation :tk-virtual)
|
|
(font :init-keyword :font
|
|
:accessor font
|
|
:allocation :tk-virtual)
|
|
(foreground :init-keyword :foreground
|
|
:accessor foreground
|
|
:allocation :tk-virtual))
|
|
:metaclass <Tk-metaclass>)
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Destroyed-object>
|
|
;
|
|
;
|
|
; This class serves only for destroyed objects (i.e. when a widget or
|
|
; a canvas item is destroyed, its class is changed to <destroyed-object>
|
|
;=============================================================================
|
|
|
|
(define-class <Destroyed-object> () ())
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; Redefine some Tk-commands as generics
|
|
;
|
|
;=============================================================================
|
|
|
|
;;;
|
|
;;; A general destroy
|
|
;;;
|
|
|
|
(define-method destroy ((self <Tk-widget>))
|
|
(let ((Eid (slot-ref self 'Eid))
|
|
(Tk:destroy (with-module Tk destroy)))
|
|
;; Destroy all the sons of this widget
|
|
(apply destroy (map (lambda (x) (or (Id->instance x) x))
|
|
(winfo 'children Eid)))
|
|
;; Suicide
|
|
(Tk:destroy Eid)
|
|
(change-class self <Destroyed-object>)))
|
|
|
|
(define-method destroy (obj)
|
|
;; Method called when not using objects (e.g. [destroy .b])
|
|
(let ((Tk:destroy (with-module Tk destroy))
|
|
(inst (Id->instance obj)))
|
|
;; Destroy all the sons of this widget
|
|
(for-each destroy (winfo 'children obj))
|
|
|
|
;; Suicide
|
|
(when inst (change-class inst <Destroyed-object>))
|
|
(Tk:destroy obj)))
|
|
|
|
(define-method destroy l ;; Destroy a list of widgets
|
|
(for-each destroy l))
|
|
|
|
;;;
|
|
;;; A general focus
|
|
;;;
|
|
(define-method focus ()
|
|
(let ((w (Tk:focus)))
|
|
(and w (Id->instance w))))
|
|
|
|
(define-method focus l (apply Tk:focus l))
|
|
|
|
|
|
;;;
|
|
;;; A general bind
|
|
;;;
|
|
(define-method bind ((self <Tk-widget>) . l)
|
|
;; Use the Id slot of a widget (instead of its Eid) for bind
|
|
(apply Tk:bind (slot-ref self 'Id) l))
|
|
|
|
|
|
;;;
|
|
;;; A general unpack (to avoid [pack 'forget ...] which is ugly
|
|
;;;
|
|
(define (unpack . l)
|
|
(apply pack 'forget l))
|
|
|
|
|
|
(provide "Basics")
|