#========================================================================= # ( ${CFGDESI}/objects/rlist.tko ) : # ---------------------------------- # # Date : 20.10.1995 # Last modif.: xx.08.1996 # #------------------------------------------------------------------------- # Explications: # If there exists an internal option database named # "int_config", it uses it. #========================================================================= Class Resource { public geo_text "Resource" public int_value "" ;# effectiv value to use, consult,... public int_value_changed 0 ;# flat, = 1 if value was changed (PhM-19.03.97) public int_host_class "" ;# designed for the host class protected int_hosts_list "" ;# designed to hold all the objects # which references the resource common int_occurs "" ;# references all the allocated resources # common int_res_name "---" ;# used to build the effectiv name common int_not_known "" constructor {config} { # puts "Resource::constructor ; appenning of -$this-" lappend int_occurs $this } destructor { set idx [lsearch $int_occurs $this] if {$idx != -1} { set int_occurs [lreplace $int_occurs $idx $idx] } } method config {config} { } #========================================================================= # get : # returns the value of objects #------------------------------------------------------------------------- method get { } { return $int_value } method get_class { } { return $int_host_class } proc get_int_res_name { } { return $int_res_name } method take { val } { set int_value $val } proc show { } { foreach entity [ Resource :: get_occurs ] { # puts "$entity's value has host_class [$entity info int_host_class -value] and value [ $entity info int_value -value]" } } proc reset_all { } { foreach entity [ Resource :: get_occurs ] { if { [ Resource :: have_you $entity ] == 0} { $entity delete } else { } } set int_occurs "" } #------------------------------------------------------- # get_occurs : # Returns the list of all the Resource entities # that are allocated. That's why it is a procedure. #....................................................... proc get_occurs { } { return $int_occurs } proc have_you { {e ""} } { if { $e == "" } { return 1; # false } foreach one $int_occurs { if { $e == $one } { return 0; # true } } return 1; } #------------------------------------------------------- # save_it : # this common class procedure saves all allocated # resource entities in a given file #....................................................... proc save_it { file } { global Default if {[catch {set fp [open $file w]}] == 1} { # puts stderr "Sorry, could not write the file ( permission ?)" return -1 } foreach entity [Resource :: get_occurs] { # if {[$entity get] != ""} { } ;# old version ICI if {[$entity getPub -int_value_changed] == "1"} { # puts stderr "ligne => $Default(o,[$entity get_class]) $Default([$entity info class])" if { $Default(o,[$entity get_class]) == "FglEntry." \ && $Default([$entity info class]) == "entryActiveBg" } { puts $fp "*entryActiveBg: [$entity get]" } elseif {$Default(o,[$entity get_class]) == "FglFrameTask." \ && $Default([$entity info class]) == "background" } { puts $fp "*defaultBg: [$entity get]" } else { $entity save_me $entity $fp #ICI } } { # puts stderr " ### The entity get is NULL, has no value" } } foreach entity [Resource :: info common int_not_known -value] { puts $fp $entity } close $fp } #------------------------------------------------------- # save_me : # This method make each resource notice itself in the # data file (locals.tcl or .fgl2crc # me : the Resource, # fp the file pointer #....................................................... method save_me { me fp } { global Default #puts stderr "Resource::save_me***: pass in with me = $me" puts $fp \ "*$Default(o,[$me get_class])$Default([$me info class]): [$me get]" } #------------------------------------------------------- # load_it : # this common class procedure loads all known # resource entities from a given #....................................................... proc load_it { file } { global Default set line "" ;# read line # puts "hitting $file" if {[catch {set f [open $file r]}] == 1} { # puts stderr "file not readable" return -1 } while { [gets $f line] != -1 } { # puts stderr "befor work $line" set name "" set line_bak $line regsub -all "\\*" $line " " line regsub -all "\\." $line " " line regsub -all "\\+" $line " " line regsub -all "\\:" $line " " line if { [llength $line] == 0 || [lindex $line 0] == "#" } { lappend int_not_known $line_bak continue } if { [llength $line] != 3} { # set host_class "Fgl" set host_class "Fgl" set class [lindex $line 0] set value [lindex $line 1] # puts stderr "class = $class; value = $value" if { $class == "entryActiveBg" } { # puts stderr "in entryActiveBg" set host_class "FglEntry" set class "entryActiveBg" ;# ici } elseif { $class == "defaultBg"} { set host_class "FglFrameTask" set class "background" } elseif { [string match color* $class ] } { set host_class "FglColor[string range $class 5 end]" set class "foreground" } elseif { [string match bgcolor* $class ] } { set host_class "FglbgColor[string range $class 7 end]" set class "background" } } else { set host_class [lindex $line 0] set class [lindex $line 1] set value [lindex $line 2] } # puts stderr "***=> value found : class=$class , host_class=$host_class , value=$value" if { ! [info exists Default($class)] || ![info exists Default(i,$host_class)]} { # puts stderr "*** unknown line => $line_bak" lappend int_not_known $line_bak continue } # puts stderr "*=> $Default($class) $Default(i,$host_class)_[$Default($class) :: info common int_res_name -value] \ -int_value $value -int_host_class $Default(i,$host_class) " if { $host_class == "FglFrame" && $class == "background" } { # this line must be ignored, because FglFrame.background will be # regerated with the FglbgColorWhite background ( it must be the same) continue } # obj will be the to be created object. set obj $Default(i,$host_class)_[$Default($class) :: info common int_res_name -value] if {[catch "$Default($class) $obj \ -int_value $value -int_host_class $Default(i,$host_class) "] == 1} \ { $Default(i,$host_class)_[$Default($class) :: info common int_res_name -value] \ config -int_value $value } # obj must be considerated as changed, to be resaved at the end of the process. $obj setPub -int_value_changed 1 } form display update close $f } proc change_status { } { foreach i [Resource :: get_occurs] { # puts stderr "$i has change status [$i getPub -int_value_changed]" } } #------------------------------------------------------- # Select a value from a predefined list. # Arguments : # target : Widget to configure; it is a 4Js- Class # class : Resource #....................................................... method select { target attr args } { global ${this}_qq ${this}_old_qq if {[catch {Frame ${this}_f -geo_orientation "vertical" \ -geo_relief "ridge" \ -geo_x [expr [$target getPub -geo_x] + 30] \ -geo_y [expr [$target getPub -geo_y] + 10] \ -int_moveable "Y" \ -int_geoman "place_it" }] == 1} { ${this}_f display return 0 } ${this}_f add_member [Label ${this}_f_l -geo_text "-- $geo_text --" \ -int_geoman "pack_it" \ -geo_relief "raised" \ -geo_fill "x" \ -int_moveable "H"] Lradio ${this}_lr \ -int_moveable "H" \ -geo_relief raised \ -geo_int_padx 5 \ -geo_int_pady 1 \ -geo_borderwidth 1 \ -int_geoman "pack_it" \ -int_command "$this config -int_value \$${this}_qq ; $target display" #puts stderr "int_values is : $int_values" foreach entity $int_values { # add_member