home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / wif_regen.tcl < prev    next >
Encoding:
Text File  |  1996-12-12  |  9.4 KB  |  374 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1995 by Westmount Technology B.V., Delft, The Netherlands.
  4. #
  5. # This software is furnished under a license and may be used only in
  6. # accordance with the terms of such license and with the inclusion of
  7. # the above copyright notice. This software or any other copies thereof
  8. # may not be provided or otherwise made available to any other person.
  9. # No title to and ownership of the software is hereby transferred.
  10. #
  11. # The information in this software is subject to change without notice
  12. # and should not be construed as a commitment by Westmount Technology B.V.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #    File        : @(#)wif_regen.tcl    /main/titanic/1
  17. #    Original date    : 10-02-1995
  18. #    Description    : 
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22. # @(#)wif_regen.tcl    /main/titanic/1    12 Dec 1996 Copyright 1995 Westmount Technology B.V.
  23. #
  24. #---------------------------------------------------------------------------
  25.  
  26. # Array with valid Visual Class Names that can be used in wif file
  27. global VCN
  28. set VCN(ixBox) 1
  29. set VCN(ixButton) 1
  30. set VCN(ixCheckBox) 1
  31. set VCN(ixEditListBox) 1
  32. set VCN(ixFrame) 1
  33. set VCN(ixLabel) 1
  34. set VCN(ixLine) 1
  35. set VCN(ixListBox) 1
  36. set VCN(ixMenu) 1
  37. set VCN(ixPictureButton) 1
  38. set VCN(ixRadioButton) 1
  39. set VCN(ixSuperField) 1
  40. set VCN(ixSuperTable) 1
  41. set VCN(ixTextBox) 1
  42. set VCN(ixWindow) 1
  43.  
  44. # global reg exp string for 'start/end of object' detection
  45. global exp_wif_begin 
  46. set exp_wif_begin {^[     ]*BEGIN[ ]+(ix[a-zA-Z]+)[ ]+([_0-9a-zA-Z]+)$}
  47. global exp_wif_end
  48. set exp_wif_end {^[     ]*END$}
  49. # global reg exp string for 'start/end handler' detection
  50. global exp_wif_handler
  51. set exp_wif_handler {^[     ]*[@]?handler}
  52. global exp_wif_end_handler
  53. set exp_wif_end_handler {^[     ]*end handler$}
  54.  
  55.  
  56. proc prepare_wif_regeneration {class} {
  57.     class2wiftgtfile $class wif_file
  58.     if {![fstorage::exists $wif_file]} {
  59.         return
  60.     }
  61.     if [catch {set fd [fstorage::open $wif_file r]}] {
  62.         return
  63.     }
  64.  
  65.     check_wif $class $fd
  66.     seek $fd 0
  67.  
  68.     process_wif_file $fd
  69.     fstorage::close $fd
  70. }
  71.  
  72. # Perform some simple checks on wif file
  73. # - root object must be a window
  74. # - multiple object names
  75. # - matching BEGIN/END
  76. # - valid object name after BEGIN
  77. # - matching handler/end handler
  78. #
  79. proc check_wif {class fd} {
  80.     global VCN
  81.     global exp_wif_begin
  82.     global exp_wif_end
  83.     global exp_wif_handler
  84.     global exp_wif_end_handler
  85.  
  86.     set indent_level 0
  87.     set in_handler 0
  88.  
  89.     set line [gets $fd]
  90.     if {[eof $fd]} {
  91.         return
  92.     }
  93.     set has_version 0
  94.     if {[string match "VERSION *" $line]} {
  95.         set line [gets $fd]
  96.         if {[eof $fd]} {
  97.             return
  98.         }
  99.         set has_version 1
  100.     }
  101.     if {![string match "BEGIN ixWindow *" $line]} {
  102.         error [no_root_window $class] "" ERR_REGEN
  103.         return
  104.     }
  105.     while {![eof $fd]} {
  106.         if {[regexp $exp_wif_begin $line dummy visual_class_name \
  107.                 object_name]} {
  108.             if {[info exist wif_objs($object_name)]} {
  109.                 error [multiple_object_names $class \
  110.                     $object_name] "" ERR_REGEN
  111.             } else {
  112.                 set wif_objs($object_name) 1
  113.             }
  114.             if !$in_handler {
  115.                 incr indent_level
  116.                 if {![info exist VCN($visual_class_name)]} {
  117.                     error [invalid_visual_class_name \
  118.                         $class $visual_class_name]\
  119.                         "" ERR_REGEN
  120.                 }
  121.                     
  122.             }
  123.             set line [gets $fd]
  124.             continue
  125.         }
  126.         if {[regexp $exp_wif_end $line]} {
  127.             if !$in_handler {
  128.                 incr indent_level -1
  129.             }
  130.             set line [gets $fd]
  131.             continue
  132.         }
  133.         if {[regexp $exp_wif_handler $line]} {
  134.             if $in_handler {
  135.                 error [handler_no_match $class] "" ERR_REGEN
  136.             }
  137.             set in_handler 1
  138.             set line [gets $fd]
  139.             continue
  140.         }
  141.         if {[regexp $exp_wif_end_handler $line]} {
  142.             if !$in_handler {
  143.                 error [handler_no_match $class] "" ERR_REGEN
  144.             }
  145.             set in_handler 0
  146.             set line [gets $fd]
  147.             continue
  148.         }
  149.         set line [gets $fd]
  150.     }
  151.     if $in_handler {
  152.         error [handler_no_match $class] "" ERR_REGEN
  153.     }
  154.     if {$indent_level != 0} {
  155.         error [begin_end_no_match $class] "" ERR_REGEN
  156.     }
  157. }
  158.  
  159. proc process_wif_file {fd} {
  160.     global wif_regen
  161.     global exp_wif_begin
  162.  
  163.     set line [gets $fd]
  164.     if {[eof $fd]} {
  165.         return
  166.     }
  167. #puts "1 $line"
  168.     if {[regexp {VERSION (.*)} $line dmy version]} {
  169.         set wif_regen(VERSION) $version
  170.         set line [gets $fd]
  171. #puts "2 $line"
  172.     }
  173.     if {![regexp $exp_wif_begin $line dmy class_name object_name]} {
  174.         return
  175.     }
  176.     set wif_obj ${class_name}${object_name}
  177.     set wif_regen(OBJECTS) $wif_obj
  178.     process_wif_object $wif_obj $line $fd
  179. }
  180.  
  181.  
  182. proc process_wif_object {wif_obj line fd} {
  183.     global exp_wif_begin
  184.     global exp_wif_end
  185.     global exp_wif_handler
  186.     global exp_wif_end_handler
  187.  
  188.     global ${wif_obj}
  189.     set ${wif_obj}(BEGIN) $line
  190.     set line [gets $fd]
  191. #puts "3 $line"
  192.  
  193.     while {![eof $fd]} {
  194.         if {[regexp $exp_wif_begin $line dmy class_name object_name]} {
  195.             set new_wif_obj ${class_name}${object_name}
  196.             lappend ${wif_obj}(OBJECTS) $new_wif_obj
  197.             process_wif_object $new_wif_obj $line $fd
  198.             set line [gets $fd]
  199. #puts "4 $line"
  200.             continue
  201.         }
  202.         if {[regexp $exp_wif_end $line]} {
  203.             set ${wif_obj}(END) $line
  204.             return
  205.         }
  206.         if {[regexp $exp_wif_handler $line]} {
  207.             set hdlr $line
  208.             set line [gets $fd]
  209. #puts "5 $line"
  210.             while {![regexp $exp_wif_end_handler $line]} {
  211.                 append hdlr "\n$line"
  212.                 set line [gets $fd]
  213. #puts "6 $line"
  214.             }
  215.             append hdlr "\n$line"
  216.             lappend ${wif_obj}(HANDLERS) $hdlr
  217.             set line [gets $fd]
  218. #puts "7 $line"
  219.             continue
  220.         }
  221.         lappend ${wif_obj}(PROPS) $line
  222.         set line [gets $fd]
  223. #puts "8 $line"
  224.     }
  225. }
  226.  
  227. proc print_wif_regen {} {
  228.     global wif_regen
  229.  
  230.     if ![info exists wif_regen] {
  231.         puts "Empty wif file"
  232.         return
  233.     }
  234.     if {[info exist wif_regen(VERSION)]} {
  235.         puts "VERSION $wif_regen(VERSION)"
  236.     }
  237.     if {[info exist wif_regen(OBJECTS)]} {
  238.         print_wif_object $wif_regen(OBJECTS)
  239.     }
  240. }
  241.  
  242. proc print_wif_object {wif_obj} {
  243.     global ${wif_obj}
  244.     puts [set ${wif_obj}(BEGIN)]
  245.  
  246.     if [info exists ${wif_obj}(PROPS)] {
  247.         foreach p [set ${wif_obj}(PROPS)] {
  248.             puts $p
  249.         }
  250.     }
  251.     
  252.     if [info exists ${wif_obj}(OBJECTS)] {
  253.         foreach o [set ${wif_obj}(OBJECTS)] {
  254.             print_wif_object $o
  255.         }
  256.     }
  257.  
  258.     if [info exists ${wif_obj}(HANDLERS)] {
  259.         foreach h [set ${wif_obj}(HANDLERS)] {
  260.             puts $h
  261.         }
  262.     }
  263.  
  264.     puts [set ${wif_obj}(END)]
  265. }
  266.  
  267. proc wif_regen::get_prop_value {wif_obj_type wif_obj_name prop_name} {
  268.     set wif_obj ${wif_obj_type}${wif_obj_name}
  269.     global $wif_obj
  270.     if {![info exist ${wif_obj}(PROPS)]} {
  271.         return ""
  272.     }
  273.     set exp_prop {^[    ]*}
  274.     append exp_prop $prop_name
  275.     append exp_prop { (\*=|@=|=) (.*)?}
  276.     set index [lsearch -regexp [set ${wif_obj}(PROPS)] $exp_prop]
  277.     if {$index == -1} {
  278.         return ""
  279.     }
  280.     set prop [lindex [set ${wif_obj}(PROPS)] $index]
  281.     regexp $exp_prop $prop dummy1 dummy2 value
  282.     return $value
  283. }
  284.  
  285. proc wif_regen::update_prop_value {wif_obj_type wif_obj_name prop_name value} {
  286.     set wif_obj ${wif_obj_type}${wif_obj_name}
  287.     global $wif_obj
  288.     if {![info exist ${wif_obj}(PROPS)]} {
  289.         return
  290.     }
  291.     set exp_prop {^[    ]*}
  292.     append exp_prop $prop_name
  293.     append exp_prop { (\*=|@=|=)}
  294.     set index [lsearch -regexp [set ${wif_obj}(PROPS)] $exp_prop]
  295.     if {$index == -1} {
  296.         return
  297.     }
  298.     set prop "$prop_name = $value"
  299.     set ${wif_obj}(PROPS) \
  300.         [lreplace [set ${wif_obj}(PROPS)] $index $index $prop]
  301. }
  302.  
  303. proc wif_regen::get_contained_wif_objs {wif_containobj_type \
  304.         wif_containobj_name {wif_obj_type NULL}} {
  305.     set wif_containobj ${wif_containobj_type}${wif_containobj_name}
  306.     global $wif_containobj
  307.  
  308.     if {![info exist ${wif_containobj}(OBJECTS)]} {
  309.         return ""
  310.     }
  311.     set wif_objs ""
  312.     foreach o [set ${wif_containobj}(OBJECTS)] {
  313.         if {$wif_obj_type != "NULL"} {
  314.             set pattern ${wif_obj_type}*
  315.             if {![string match $pattern $o]} {
  316.                 continue
  317.             }
  318.         }
  319.         lappend wif_objs $o
  320.     }
  321.     return $wif_objs
  322. }
  323.  
  324. proc wif_regen::get_contained_wif_obj_names {wif_containobj_type \
  325.         wif_containobj_name {wif_obj_type NULL}} {
  326.     set wif_objs [wif_regen::get_contained_wif_objs $wif_containobj_type \
  327.         $wif_containobj_name $wif_obj_type]
  328.     set wif_obj_names ""
  329.     foreach o $wif_objs {
  330.         regsub $wif_obj_type $o "" nm
  331.         lappend wif_obj_names $nm
  332.     }
  333.     return $wif_obj_names
  334. }
  335.  
  336. proc no_root_window {class} {
  337.     class2wiftgtfile $class wif_file
  338.     set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
  339.     append msg "       file '$wif_file' contains no root window object"
  340.     return $msg
  341. }
  342.  
  343. proc multiple_object_names {class object_name} {
  344.     class2wiftgtfile $class wif_file
  345.     set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
  346.     append msg "       file '$wif_file' contains multiple wif objects\
  347.         named '$object_name'"
  348.     return $msg
  349. }
  350.  
  351. proc invalid_visual_class_name {class visual_class_name} {
  352.     class2wiftgtfile $class wif_file
  353.     set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
  354.     append msg "       file '$wif_file' contains invalid class name\
  355.         '${visual_class_name}'"
  356.     return $msg
  357. }
  358.  
  359. proc handler_no_match {class} {
  360.     class2wiftgtfile $class wif_file
  361.     set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
  362.     append msg "       file '$wif_file' contains unmatched 'handler' or\n"
  363.     append msg "       'end handler' statement"
  364.     return $msg
  365. }
  366.  
  367. proc begin_end_no_match {class} {
  368.     class2wiftgtfile $class wif_file
  369.     set msg "ERROR: Wif generation for class '[$class getName]' failed:\n"
  370.     append msg "       file '$wif_file' contains unmatched 'BEGIN' or
  371.     append msg "       'END' statement"
  372.     return $msg
  373. }
  374.