home *** CD-ROM | disk | FTP | other *** search
- #---------------------------------------------------------------------------
- #
- # Copyright (c) 1995 by Westmount Technology B.V., Delft, The Netherlands.
- #
- # This software is furnished under a license and may be used only in
- # accordance with the terms of such license and with the inclusion of
- # the above copyright notice. This software or any other copies thereof
- # may not be provided or otherwise made available to any other person.
- # No title to and ownership of the software is hereby transferred.
- #
- # The information in this software is subject to change without notice
- # and should not be construed as a commitment by Westmount Technology B.V.
- #
- #---------------------------------------------------------------------------
- #
- # File : @(#)wif_regen.tcl /main/titanic/1
- # Original date : 10-02-1995
- # Description :
- #
- #---------------------------------------------------------------------------
- #
- # @(#)wif_regen.tcl /main/titanic/1 12 Dec 1996 Copyright 1995 Westmount Technology B.V.
- #
- #---------------------------------------------------------------------------
-
- # Array with valid Visual Class Names that can be used in wif file
- global VCN
- set VCN(ixBox) 1
- set VCN(ixButton) 1
- set VCN(ixCheckBox) 1
- set VCN(ixEditListBox) 1
- set VCN(ixFrame) 1
- set VCN(ixLabel) 1
- set VCN(ixLine) 1
- set VCN(ixListBox) 1
- set VCN(ixMenu) 1
- set VCN(ixPictureButton) 1
- set VCN(ixRadioButton) 1
- set VCN(ixSuperField) 1
- set VCN(ixSuperTable) 1
- set VCN(ixTextBox) 1
- set VCN(ixWindow) 1
-
- # global reg exp string for 'start/end of object' detection
- global exp_wif_begin
- set exp_wif_begin {^[ ]*BEGIN[ ]+(ix[a-zA-Z]+)[ ]+([_0-9a-zA-Z]+)$}
- global exp_wif_end
- set exp_wif_end {^[ ]*END$}
- # global reg exp string for 'start/end handler' detection
- global exp_wif_handler
- set exp_wif_handler {^[ ]*[@]?handler}
- global exp_wif_end_handler
- set exp_wif_end_handler {^[ ]*end handler$}
-
-
- proc prepare_wif_regeneration {class} {
- class2wiftgtfile $class wif_file
- if {![fstorage::exists $wif_file]} {
- return
- }
- if [catch {set fd [fstorage::open $wif_file r]}] {
- return
- }
-
- check_wif $class $fd
- seek $fd 0
-
- process_wif_file $fd
- fstorage::close $fd
- }
-
- # Perform some simple checks on wif file
- # - root object must be a window
- # - multiple object names
- # - matching BEGIN/END
- # - valid object name after BEGIN
- # - matching handler/end handler
- #
- proc check_wif {class fd} {
- global VCN
- global exp_wif_begin
- global exp_wif_end
- global exp_wif_handler
- global exp_wif_end_handler
-
- set indent_level 0
- set in_handler 0
-
- set line [gets $fd]
- if {[eof $fd]} {
- return
- }
- set has_version 0
- if {[string match "VERSION *" $line]} {
- set line [gets $fd]
- if {[eof $fd]} {
- return
- }
- set has_version 1
- }
- if {![string match "BEGIN ixWindow *" $line]} {
- error [no_root_window $class] "" ERR_REGEN
- return
- }
- while {![eof $fd]} {
- if {[regexp $exp_wif_begin $line dummy visual_class_name \
- object_name]} {
- if {[info exist wif_objs($object_name)]} {
- error [multiple_object_names $class \
- $object_name] "" ERR_REGEN
- } else {
- set wif_objs($object_name) 1
- }
- if !$in_handler {
- incr indent_level
- if {![info exist VCN($visual_class_name)]} {
- error [invalid_visual_class_name \
- $class $visual_class_name]\
- "" ERR_REGEN
- }
-
- }
- set line [gets $fd]
- continue
- }
- if {[regexp $exp_wif_end $line]} {
- if !$in_handler {
- incr indent_level -1
- }
- set line [gets $fd]
- continue
- }
- if {[regexp $exp_wif_handler $line]} {
- if $in_handler {
- error [handler_no_match $class] "" ERR_REGEN
- }
- set in_handler 1
- set line [gets $fd]
- continue
- }
- if {[regexp $exp_wif_end_handler $line]} {
- if !$in_handler {
- error [handler_no_match $class] "" ERR_REGEN
- }
- set in_handler 0
- set line [gets $fd]
- continue
- }
- set line [gets $fd]
- }
- if $in_handler {
- error [handler_no_match $class] "" ERR_REGEN
- }
- if {$indent_level != 0} {
- error [begin_end_no_match $class] "" ERR_REGEN
- }
- }
-
- proc process_wif_file {fd} {
- global wif_regen
- global exp_wif_begin
-
- set line [gets $fd]
- if {[eof $fd]} {
- return
- }
- #puts "1 $line"
- if {[regexp {VERSION (.*)} $line dmy version]} {
- set wif_regen(VERSION) $version
- set line [gets $fd]
- #puts "2 $line"
- }
- if {![regexp $exp_wif_begin $line dmy class_name object_name]} {
- return
- }
- set wif_obj ${class_name}${object_name}
- set wif_regen(OBJECTS) $wif_obj
- process_wif_object $wif_obj $line $fd
- }
-
-
- proc process_wif_object {wif_obj line fd} {
- global exp_wif_begin
- global exp_wif_end
- global exp_wif_handler
- global exp_wif_end_handler
-
- global ${wif_obj}
- set ${wif_obj}(BEGIN) $line
- set line [gets $fd]
- #puts "3 $line"
-
- while {![eof $fd]} {
- if {[regexp $exp_wif_begin $line dmy class_name object_name]} {
- set new_wif_obj ${class_name}${object_name}
- lappend ${wif_obj}(OBJECTS) $new_wif_obj
- process_wif_object $new_wif_obj $line $fd
- set line [gets $fd]
- #puts "4 $line"
- continue
- }
- if {[regexp $exp_wif_end $line]} {
- set ${wif_obj}(END) $line
- return
- }
- if {[regexp $exp_wif_handler $line]} {
- set hdlr $line
- set line [gets $fd]
- #puts "5 $line"
- while {![regexp $exp_wif_end_handler $line]} {
- append hdlr "\n$line"
- set line [gets $fd]
- #puts "6 $line"
- }
- append hdlr "\n$line"
- lappend ${wif_obj}(HANDLERS) $hdlr
- set line [gets $fd]
- #puts "7 $line"
- continue
- }
- lappend ${wif_obj}(PROPS) $line
- set line [gets $fd]
- #puts "8 $line"
- }
- }
-
- proc print_wif_regen {} {
- global wif_regen
-
- if ![info exists wif_regen] {
- puts "Empty wif file"
- return
- }
- if {[info exist wif_regen(VERSION)]} {
- puts "VERSION $wif_regen(VERSION)"
- }
- if {[info exist wif_regen(OBJECTS)]} {
- print_wif_object $wif_regen(OBJECTS)
- }
- }
-
- proc print_wif_object {wif_obj} {
- global ${wif_obj}
- puts [set ${wif_obj}(BEGIN)]
-
- if [info exists ${wif_obj}(PROPS)] {
- foreach p [set ${wif_obj}(PROPS)] {
- puts $p
- }
- }
-
- if [info exists ${wif_obj}(OBJECTS)] {
- foreach o [set ${wif_obj}(OBJECTS)] {
- print_wif_object $o
- }
- }
-
- if [info exists ${wif_obj}(HANDLERS)] {
- foreach h [set ${wif_obj}(HANDLERS)] {
- puts $h
- }
- }
-
- puts [set ${wif_obj}(END)]
- }
-
- proc wif_regen::get_prop_value {wif_obj_type wif_obj_name prop_name} {
- set wif_obj ${wif_obj_type}${wif_obj_name}
- global $wif_obj
- if {![info exist ${wif_obj}(PROPS)]} {
- return ""
- }
- set exp_prop {^[ ]*}
- append exp_prop $prop_name
- append exp_prop { (\*=|@=|=) (.*)?}
- set index [lsearch -regexp [set ${wif_obj}(PROPS)] $exp_prop]
- if {$index == -1} {
- return ""
- }
- set prop [lindex [set ${wif_obj}(PROPS)] $index]
- regexp $exp_prop $prop dummy1 dummy2 value
- return $value
- }
-
- proc wif_regen::update_prop_value {wif_obj_type wif_obj_name prop_name value} {
- set wif_obj ${wif_obj_type}${wif_obj_name}
- global $wif_obj
- if {![info exist ${wif_obj}(PROPS)]} {
- return
- }
- set exp_prop {^[ ]*}
- append exp_prop $prop_name
- append exp_prop { (\*=|@=|=)}
- set index [lsearch -regexp [set ${wif_obj}(PROPS)] $exp_prop]
- if {$index == -1} {
- return
- }
- set prop "$prop_name = $value"
- set ${wif_obj}(PROPS) \
- [lreplace [set ${wif_obj}(PROPS)] $index $index $prop]
- }
-
- proc wif_regen::get_contained_wif_objs {wif_containobj_type \
- wif_containobj_name {wif_obj_type NULL}} {
- set wif_containobj ${wif_containobj_type}${wif_containobj_name}
- global $wif_containobj
-
- if {![info exist ${wif_containobj}(OBJECTS)]} {
- return ""
- }
- set wif_objs ""
- foreach o [set ${wif_containobj}(OBJECTS)] {
- if {$wif_obj_type != "NULL"} {
- set pattern ${wif_obj_type}*
- if {![string match $pattern $o]} {
- continue
- }
- }
- lappend wif_objs $o
- }
- return $wif_objs
- }
-
- proc wif_regen::get_contained_wif_obj_names {wif_containobj_type \
- wif_containobj_name {wif_obj_type NULL}} {
- set wif_objs [wif_regen::get_contained_wif_objs $wif_containobj_type \
- $wif_containobj_name $wif_obj_type]
- set wif_obj_names ""
- foreach o $wif_objs {
- regsub $wif_obj_type $o "" nm
- lappend wif_obj_names $nm
- }
- return $wif_obj_names
- }
-
- proc no_root_window {class} {
- class2wiftgtfile $class wif_file
- set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
- append msg " file '$wif_file' contains no root window object"
- return $msg
- }
-
- proc multiple_object_names {class object_name} {
- class2wiftgtfile $class wif_file
- set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
- append msg " file '$wif_file' contains multiple wif objects\
- named '$object_name'"
- return $msg
- }
-
- proc invalid_visual_class_name {class visual_class_name} {
- class2wiftgtfile $class wif_file
- set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
- append msg " file '$wif_file' contains invalid class name\
- '${visual_class_name}'"
- return $msg
- }
-
- proc handler_no_match {class} {
- class2wiftgtfile $class wif_file
- set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
- append msg " file '$wif_file' contains unmatched 'handler' or\n"
- append msg " 'end handler' statement"
- return $msg
- }
-
- proc begin_end_no_match {class} {
- class2wiftgtfile $class wif_file
- set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
- append msg " file '$wif_file' contains unmatched 'BEGIN' or
- append msg " 'END' statement"
- return $msg
- }
-