#------------------------------------------------------------------------ # Compagny : 4Js # Developper : PM # Program : $PROJET/objects/widget.res # Date : 03.07.1995 # Last modif. : 13.10.1995 # Title : Description des classes de base #------------------------------------------------------------------------ # Explication : # Widget is the default class, from witch all the graphical object # descends. He has defined all the functions (methodes) witch are common # to every objects, like the move, or the display methode. There are NO # entities of class Widget. But all objects herites from it. # Displaying is assumed by the methode Display_Widget, called by # the display event of the widget. The Pack_Widget (and eventually the # Place_Widget- ) -methodes can display it on screen. So Display_Widget # is tk-independant. The define event is not defined in this class, because # it defers from one graphical object to antoher. But it is called in the # Display_... methode. # The display event is called with optionnaly root parameter (in this case, # the actually widget root is lost and replaced with this new), but the # pack_it, place_it are without root parameter, because it is # assumed that the root is already known. #====================================================================== Class Widget { global Default #vars : public int_parent "" ;# Object that is the parent public int_owner "" ;# Object proprietary public int_moveable "N" public int_show_attr "N" ;# Y, N, or H for herited public int_wattr_meth "" public int_wattr_geo "" public int_wattr_int "" public int_name "" public int_geoman "place_it" public int_prefixes "int geo meth" public int_bindings "" public geo_root . public geo_widget "" public geo_x 0 public geo_y 0 public geo_width 0 public geo_height 0 public geo_padx $Default(Widget,PadX) public geo_pady $Default(Widget,PadY) public geo_borderwidth $Default(Widget,BorderWidth) ;# 2 public geo_relief $Default(Widget,Relief) public geo_bg $Default(Widget,Bg) public geo_fg $Default(Widget,Fg) public geo_active_fg $Default(Widget,ActiveFg) public geo_attach "left" public geo_fill "none" public geo_expand 0 ;# Tk default;in this object constructor {config} { set int_name $this ; # try not to use $int_name, but $this } method config {config} {} #----------------------------------------------------------------------- # Destroy_Widget : # This function deletes an object's widget, and the full abstract # structure of the object too. # Parameters: just the name of object. #....................................................................... destructor { # puts "Destroy_Widget: on y entre pour destroyer $this" foreach i "$int_prefixes " { if { [set int_wattr_[set i]] != "" } { # puts "Destroy_Widget: au passage, destroyer $name(int,wattr,$i)" virtual show_attr_done $i } } # puts "Widget::destructor, destroying $geo_widget" if { $geo_widget != "" } { ::destroy $geo_widget } if {[winfo exist $geo_widget] == 1} { # puts "Widget:destructor, destruction failed" } else { # puts "Widget:destructor, $geo_widget destroyed" } if { $int_parent != "" } { $int_parent supp_soon $this } # puts "Destroy_Widget: on en sort pour $this" } #----------------------------------------------------------------------- # Destroy_Widget : # Temporare, please use the destructor method with the call # of delete standard event. #....................................................................... method destroy { } { virtual delete } method show { what } { puts stdout "$what is >[eval $$what]<" } method widget { } { return $geo_widget } #----------------------------------------------------------------------- # Display_Widget : # Used by the most class witch herites from. It defines graphically # the object, and then puts it on screen, in a specified container. This # function calls 2 particular methodes : the first defines under X the # object (button, label,...). This is why this methode can only be defined # in a class for witch a Tk-widget is assigned, and not here. The # Display_Widget methode can only be called for such an object. So there # are no risks for this methode to be called without a corresponding # define methode. In the other case, there is one or more BUG! # Parameters : # name of object # root of graphical object, eventually if redefined, # or not defined yet # Returns : nothing #....................................................................... method display { {root .} } { # puts "Display_Widget: comming in" if {$root != ""} { set geo_root $root } # puts "Display_Widget: making $this" # First define this object in graphical, if it isn't already done yet # puts "Display_Widget: define or refresh ?" if {$geo_widget == ""} { #puts "Display_Widget: $this geo_widget = $geo_widget" virtual init_res # rWidget particularity virtual define } else { #puts "Display_Widget: $this refresh " virtual refresh } # Is this widget moveable on screen? #puts "Display_Widget: $this moveable ?" if {$int_moveable != "N" } { virtual init_move } else { virtual remove_move } # Is this object authorized of show his attributs ? #puts "Display_Widget: $this show attributs ?" if {$int_show_attr != "N"} { set_binding " $this init_show_attr " virtual init_resize } # It is possible, that bindings has been set, befor widget has been defined. foreach cmd $int_bindings { #puts "Widget::display: for $this, evaluating >$cmd<" # puts "Display_Widget: concerned value is >[lindex $cmd 1]<" eval $cmd } # And then, show it on screen with the appropriate geometry manager if { $int_geoman != "" } { # puts "Display_Widget: call geoman for $_name" virtual $int_geoman ;# !!! place_it or pack_it } #puts "Widget::display: going out" } #----------------------------------------------------------------------- # Place_Widget : # Used as standard for a sort of geometry manager. Puts graphical # object on screen on x,y coordinates. This methode is herited by most # of the other objects. In opposite of a Define_... methode, the methodes # Place_Widget and Pack_Widget are (sensibly) the same for all the widgets. # But they can be redefined in sub-classes if needed. # Parameters : name of object # Returns : nothing #....................................................................... method place_it { } { # puts "For $this, geo_x is $geo_x, and geo_y is $geo_y" if {$geo_widget != ""} { place configure $geo_widget \ -x $geo_x \ -y $geo_y } # puts "la commande executee sera $cmd" } #----------------------------------------------------------------------- # Pack_Widget : # Used as standard for a sort of geometry manager. Puts graphical # object on screen and pack it with other objects on the same container # This methode is herited by most of the other objects. Please read the # comments of the Place_Widget methode. # Parameters : name of object # Returns : nothing #....................................................................... method pack_it { } { # puts "mode de FILLING pour $name is $name(geo,fill)" if { $geo_padx < 0 } { set geo_padx 0 } if { $geo_pady < 0 } { set geo_pady 0 } # puts stderr "in pack_it for $this, geo_attach is $geo_attach"; flush stderr #puts stderr "pack $geo_widget -side [$this getPub geo_attach ] \ -fill [$this getPub -geo_fill ] \ -expand [$this getPub -geo_expand ] \ -padx [$this getPub -geo_padx ] \ -pady [$this getPub -geo_pady ]" pack $geo_widget -side [$this getPub -geo_attach ] \ -fill [$this getPub -geo_fill ] \ -expand [$this getPub -geo_expand ] \ -padx [$this getPub -geo_padx ] \ -pady [$this getPub -geo_pady ] #puts stderr "ok"; flush stderr } #------------------------------------------------------------------------ # Init_Move : # Defines the bindings necessary to move dynamically objects on screen. # Is specially used for forms objects. That's why, it was tested if the # object is moveable ( if ${name}(int,moveable) == "Y" ) # Parameters : name of objects # Return : nothing, only moves object. # Global variables used : curX, curY # Data changed : ${name}(geo,x) ${name}(geo,y) of each object #........................................................................ method init_move { {wid_to_bind ""} } { global curX, curY if {$wid_to_bind == ""} {set wid_to_bind [$this getPub -geo_widget]} if { $int_moveable == "H" } { $int_parent init_move $wid_to_bind return 0 } else { set l_wid $this set obj_path $geo_widget } set curX -1000 bind $wid_to_bind " set curX %X set curY %Y set oldcurX \[ $l_wid getPub -geo_x \] set oldcurY \[ $l_wid getPub -geo_y \] " bind $wid_to_bind " set oldcurX \[expr \$oldcurX + %X - \$curX\] set oldcurY \[expr \$oldcurY + %Y - \$curY\] place $obj_path -x \$oldcurX -y \$oldcurY set curX %X set curY %Y " bind $wid_to_bind " $l_wid config -geo_x \$oldcurX $l_wid config -geo_y \$oldcurY " } method __init_move { } { global curX, curY bind $geo_widget " set curX %X set curY %Y " bind $geo_widget " set X \[expr %X - \$curX \] set Y \[expr %Y - \$curY \] $this config -geo_x \[expr \[ $this getPub -geo_x \] + \$X\] $this config -geo_y \[expr \[ $this getPub -geo_y \] + \$Y\] $this place_it set curX %X set curY %Y " bind $geo_widget " " } #------------------------------------------------------------------------ # Init_Resize : # Defines the bindings necessary to resize dynamically objects # on screen. Is specially used for forms objects. That's why, it was # tested if the object is being designed : # ( if ${name}(int,being_designed) == "Y" ) # It is possible, that not all objects can be resize on height. For those # objects, it is necessary to redefine the appropriate function. # Parameters : name of objects # Return : nothing, only resize object. # Global variables used : curX, curY # Data changed : attribut geo_width and geo_height of object #........................................................................ method init_resize { } { global curX, curY bind ${geo_widget} " set curX %X set curY %Y " bind ${geo_widget} " set X \[expr %X - \$curX \] set Y \[expr %Y - \$curY \] $this config -geo_width \[expr \[ $this getPub -geo_width \] + \$X\] $this config -geo_height \[expr \[ $this getPub -geo_height \] + \$Y\] if { \[$this getPub -geo_width \] < 0 } { $this config -geo_width 0 } if { \[$this getPub -geo_height \] < 0 } { $this config -geo_height 0 } $this refresh set curX %X set curY %Y " # $this config -geo_x \[expr \[ $this getPub -geo_x \] + \$X\] bind ${geo_widget} " " } #----------------------------------------------------------------------- # Raise : 03.04.97 # Sometimes, it is usefull. # Returns: nothing, just work well. #....................................................................... #method raise { } { # if {$geo_widget != ""} { # raise $geo_widget # } else { # # puts stderr "Calling of raise for <$this> since there is no widget" # } # } #----------------------------------------------------------------------- # Clear_Widget : # Is used to delete the physical widget of the object # ( .desi.form.tagada ), but conserve his object structur variable. # Parameter: name of object # Returns: nothing, just work well. #....................................................................... method clear { } { # puts "Clear_Widget: on y entre pour destroyer $name(geo,widget)" if {$geo_widget != ""} { ::destroy $geo_widget set geo_widget "" } #foreach entity $name(int,soons) { # foreach soon $name(int,$entity) { # global $soon # puts "Clear_Widget: clear of soon $soon, with root $name(geo,widget)" # set ${soon}(geo,widget) "" # call $soon clear # } # } } #------------------------------------------------------------------------ # Remove_Move # Suppression of the bindings, define for the move capacity, in the # case of a refresh after setting the show_attr attribut of an objet on "N" #........................................................................ method remove_move { } { bind $geo_widget {} bind $geo_widget {} bind $geo_widget {} } #------------------------------------------------------------------------ # SetBg : # This function sets recursivelly the background for the # specifyed object, and all those, contained in it. # Becarefull, there is a Tk-command included. # Parameters: name of object, and the wanted color. # Returns: nothing #........................................................................ method set_bg { color } { foreach entity $int_soons { foreach soon $int_$entity { $soon setbg $color # puts stderr "SetBg: set bg $color for $soon" } } $name(geo,widget) configure -bg $color } #------------------------------------------------------------------------ # SetBinding: # Used to define for example a mouse event on the thing. Events # can be defined befor the physicall widget itself. They will be then # defined when the widget will be created. # Parameters: name of object, name of event, and instruction set. # Return: nothing at all #........................................................................ method set_binding { event instructions } { if { $geo_widget != "" } { bind $geo_widget $event $instructions } else { lappend int_bindings \ "$this set_binding $event { $instructions }" } } #----------------------------------------------------------------------- # Reset_Geo : # Very usefull in some case, to recompose frame contains # Entry : name : Entity name of object # Returns : nothing. #....................................................................... method reset_geo { } { pack forget $geo_widget } #------------------------------------------------------------------------ # Copy_Widget_Entity : # This function copies the object given in parameters, with the same # attribut values, for all class of objects. # Parameters : name of original object, and the name of the copy # Returns: the new object made. #........................................................................ method copy_to { newobj } { set clas [$this info inherit] # puts stderr "The copied class is $clas" $class $newobj foreach entity [array names obj] { regsub -all "$_obj" "$obj($entity)" "$newobj" newobj($entity) } set newobj(geo,widget) "" return $newobj(int,name) } #------------------------------------------------------------------------ # Init_Show_Attributs : # This function is called, when an attribut list is invoked. It # display a menu for choosing the specification of the object attributs # that are wanted. # Parameters : name of objects # Return : nothing. #........................................................................ method init_show_attr { } { if { $int_show_attr == "H" } { ;# 'H' for herited $int_parent init_show_attr } else { # global a_menu_$_name if {[info commands a_menu_$this] == "a_menu_$this"} { if {a_menu_$this getPub -geo_widget != ""} { # puts stderr "This menu (a_menu_$this) is already existing" a_menu_$this raise } else { # puts stderr "This menu (a_menu_$this) has lost its widget" a_menu_$this display } return -1 } else { Rmenu a_menu_$this \ -int_lifetype "temporar" \ -int_geoman "place_it" \ -geo_orientation "vertical" \ -geo_x 50 \ -geo_y 30 \ -geo_int_padx 2 \ -geo_int_pady 2 # -geo_title "Witch attribut for <$this>" foreach prefix $int_prefixes { ;# for each sort of attribut prefix... switch $prefix { "var" {set libel "Variables"} "meth" {set libel "Methodes"} "geo" {set libel "Geometry"} "int" {set libel "Internal"} } a_menu_$this add_member \ ${this}_$prefix $libel "$this swap_wattr $prefix" # puts "Widget: libel is $libel" } a_menu_$this add_member ${this}_b_esc " Done " "" a_menu_$this add_member ${this}_b_del " Delete " "$this destroy" a_menu_$this display } } } #------------------------------------------------------------------------ # Swap_Show_Attributs : called by event to the class "WIDGET" # This function is called by a Rmenu button, when an attribut list # has been invoked, on the widget class level, and with a attribut specification. # This function has been written to swap, when an attributlist # is called more than once. # Parameters : name of object from witch the attributs must be shown, # search specification, or what sort of attributs are wanted. # Returns: nothing yet #........................................................................ method swap_wattr { specif} { # puts "Swap_Show_Attributs for $this" if { [set int_wattr_[set specif]] == ""} { show_me_attr $specif } else { show_attr_done $specif } } #------------------------------------------------------------------------ # Show_Attributs : called by event # Display a new window on screen, with a list of all # possible attributs for this object. # Parameters : name of object # Returns: nothing yet #........................................................................ method show_me_attr { specif } { Attributlist ${this}_attr_${specif} \ -int_specif $specif \ -int_owner $this \ -geo_title "Attributs of type <$specif> for >$this<" #puts "Show_Attributs: Ouverture de la fenetre d\'ATTRIBUT pour $_name" #puts "Show_Attributs: Appel fonction f'affichage: $name(meth,display)" set int_wattr_${specif} ${this}_attr_${specif} ${this}_attr_${specif} display } #------------------------------------------------------------------------ # Show_Attributs_Done : called by the event # Hide again the window, or destroy it,... # Parameters : name of object # Returns: nothing yet #........................................................................ method show_attr_done { specif } { # puts "Show_Attributs_Done: on y entre" catch "[set int_wattr_[set specif]] destroy" set int_wattr_${specif} "" virtual display # puts "Show_Attributs_Done for $_name: on en sort" } #------------------------------------------------------------------------ # Show_Attributs_Cancel : called by the event # Hide again the window, or destroy it,... # Parameters : name of object # Returns: nothing yet #........................................................................ method show_attr_cancel { _name specif } { # puts "Show_Attributs_Cancel: on y entre" catch "[set int_wattr_[set specif]] destroy" set int_wattr_${specif} "" # puts "Show_Attributs_Cancel for $_name: on en sort" } #----------------------------------------------------------------------- # init_res : dummy function. Should never have a body in this module. #....................................................................... method init_res { args } { } } ;# end of CLASS #----------------------------------------------------------------------- # Init_W_Chg_NbLines : # This function is the redefinition of the Init_Chg_NbLines function, # corresponding to the event, first defined in the # Container class. The original function is recursiv to all class of # type Container. But the last one of the hierarchical tree must be # redefined: this is the case here. #....................................................................... METHODE Init_W_Chg_NbLines { _name } { global $_name upvar #0 $_name name global $name(int,parent) # puts "Init_W_Chg_NbLines: initialising $_name (end of tree)" # call name set_binding "puts \"Increment lines\" " call $_name set_binding "call $name(int,parent) incr_lines" # call name set_binding "puts \"Decrement lines\" " call $_name set_binding "call $name(int,parent) decr_lines" } #======================================================================