206 lines
7.1 KiB
Plaintext
206 lines
7.1 KiB
Plaintext
;;;;
|
|
;;;; T k - m e t a . s t k -- Metaclasses definitions
|
|
;;;;
|
|
;;;; 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.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 24-Feb-1994 15:08
|
|
;;;; Last file update: 3-Sep-1999 20:11 (eg)
|
|
;;;;
|
|
;;;;
|
|
;;;; Compatibility:
|
|
;;;; - the :pseudo allocation is now replaced by :tk-virtual (Rob DeLine
|
|
;;;; proposition). However both name are accepted. Avoid to use :pseudo
|
|
;;;; since it will disappear in the future.
|
|
;;;;
|
|
;;;; - the :special allocation is now replaced by :propagated (Rob DeLine
|
|
;;;; proposition). However both name are accepted. Avoid to use :special
|
|
;;;; since it will disappear in the future.
|
|
;;;;
|
|
;;;; - the :propagate option for propagated slots is now replaced by
|
|
;;;; :propagate-to. Avoid to use :propagate since it will disappear in
|
|
;;;; the future.
|
|
|
|
(require "stklos")
|
|
|
|
;;;;
|
|
;;;; Stuff for declaring the new module STklos+Tk and import it in STk
|
|
;;;; Note that the module Tk, is also defined here. This is useless, except
|
|
;;;; when making images (i.e. probably the -no-window option has been used,
|
|
;;;; avoiding the Tk initialization, and hence the Tk module definition)
|
|
|
|
(define-module Tk) ; See comment above
|
|
(define-module STklos+Tk (import STklos Tk)) ; Define module STklos+Tk
|
|
(with-module STk (import STklos+Tk)) ; Import STklos+Tk in STk
|
|
(select-module STklos+Tk) ; Rest of this file belongs
|
|
; to STklos+Tk module
|
|
|
|
;;;;
|
|
;;;; Exports
|
|
;;;;
|
|
(export
|
|
;; Metaclases exported by this file
|
|
<With-Tk-virtual-slots-metaclass> <Tk-metaclass> <Tk-item-metaclass>
|
|
<Tk-tag-metaclass> <Tk-text-window-metaclass> <Tk-composite-metaclass>
|
|
<Tk-composite-item-metaclass>
|
|
;; generic functions exported by this file
|
|
compute-tk-virtual-get-n-set)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <With-Tk-virtual-slots-metaclass> class
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Define Tk slots getters and setters. In fact this metaclass permits
|
|
;; a direct mapping of STklos slots to the Tk-library widget options.
|
|
;; For instance, a <Label> has a slot called "text". Accessing this slot
|
|
;; will call a Tk (C) library function
|
|
;; (xxxx 'cget 'text) for reading
|
|
;; or
|
|
;; (xxxx 'configure 'text value) for writing
|
|
;; where xxxx is an internal name generated during instance creation).
|
|
;;
|
|
;; Furthermore, Tk widgets define a lot of accessors and exporting
|
|
;; them individually can be boring. Consequently, when such a class is
|
|
;; initiaized, we export it and all its direct accessor methods
|
|
|
|
|
|
(define-class <With-Tk-virtual-slots-metaclass> (<class>)
|
|
())
|
|
|
|
(define-method initialize ((class <With-Tk-virtual-slots-metaclass>) initargs)
|
|
(next-method)
|
|
(let ((module (%get-module (class-environment class))))
|
|
;; export the class
|
|
(export-symbol (class-name class) module)
|
|
;; export its accessors
|
|
(for-each (lambda (method)
|
|
(if (is-a? method <accessor-method>)
|
|
(export-symbol (generic-function-name
|
|
(method-generic-function method))
|
|
module)))
|
|
(class-direct-methods class))))
|
|
|
|
(define-method compute-get-n-set ((class <With-Tk-virtual-slots-metaclass>) slot)
|
|
(if (memv (slot-definition-allocation slot) '(:tk-virtual :pseudo))
|
|
[let ((tk-name (make-keyword (get-keyword :tk-name (cdr slot) (car slot)))))
|
|
(compute-tk-virtual-get-n-set class tk-name)]
|
|
[next-method]))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Tk-metaclass> metaclass
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Tk-metaclass> (<With-Tk-virtual-slots-metaclass>)
|
|
())
|
|
|
|
(define-method compute-tk-virtual-get-n-set ((class <Tk-metaclass>) tk-name)
|
|
(list
|
|
(lambda (o) ((slot-ref o 'Id) 'cget tk-name))
|
|
(lambda (o v) ([slot-ref o 'Id] 'configure tk-name v))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Tk-item-metaclass> metaclass
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Tk-item-metaclass> (<With-Tk-virtual-slots-metaclass>)
|
|
())
|
|
|
|
(define-method compute-tk-virtual-get-n-set ((class <Tk-item-metaclass>) tk-name)
|
|
(list
|
|
(lambda (o)
|
|
((slot-ref o 'Id) 'itemcget (slot-ref o 'Cid) tk-name))
|
|
(lambda (o v)
|
|
((slot-ref o 'Id) 'itemconf (slot-ref o 'Cid) tk-name v))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Tk-tag-metaclass> metaclass
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Tk-tag-metaclass> (<With-Tk-virtual-slots-metaclass>)
|
|
())
|
|
|
|
(define-method compute-tk-virtual-get-n-set ((class <Tk-tag-metaclass>) tk-name)
|
|
(list
|
|
(lambda (o)
|
|
((slot-ref o 'Id) 'tag 'cget (slot-ref o 'Tid) tk-name))
|
|
(lambda (o v)
|
|
((slot-ref o 'Id) 'tag 'configure (slot-ref o 'Tid) tk-name v))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Tk-text-inset-metaclass> metaclass
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Tk-text-inset-metaclass> (<With-Tk-virtual-slots-metaclass>)
|
|
())
|
|
|
|
(define-method compute-tk-virtual-get-n-set ((class <Tk-text-inset-metaclass>)
|
|
tk-name)
|
|
(list
|
|
(lambda (o)
|
|
(if (slot-bound? o 'Iid)
|
|
((slot-ref o 'Id) (slot-ref o 'kind) 'cget (slot-ref o 'Iid) tk-name)
|
|
(make-unbound)))
|
|
(lambda (o v)
|
|
(if (slot-bound? o 'Iid)
|
|
((slot-ref o 'Id) (slot-ref o 'kind) 'configure (slot-ref o 'Iid)
|
|
tk-name v)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Tk-font-metaclass> metaclass
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Tk-font-metaclass> (<With-Tk-virtual-slots-metaclass>)
|
|
())
|
|
|
|
(define-method compute-tk-virtual-get-n-set ((class <Tk-font-metaclass>) tk-name)
|
|
(list
|
|
(lambda (o) (font 'configure (slot-ref o 'Id) tk-name))
|
|
(lambda (o v) (font 'configure (slot-ref o 'Id) tk-name v))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Tk-composite-metaclass> metaclass
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Tk-composite-metaclass> (<Tk-metaclass> <Composite-metaclass>)
|
|
())
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Tk-composite-item-metaclass> metaclass
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Tk-composite-item-metaclass> (<Tk-item-metaclass>
|
|
<Composite-metaclass>)
|
|
())
|
|
|
|
|
|
(provide "Tk-meta")
|