#!/bin/sh # the next line restarts using wish\ exec wish "$0" "$@" if {![info exists vTcl(sourcing)]} { package require Tk switch $tcl_platform(platform) { windows { option add *Button.padY 0 } default { option add *Scrollbar.width 10 option add *Scrollbar.highlightThickness 0 option add *Scrollbar.elementBorderWidth 2 option add *Scrollbar.borderWidth 2 } } } ############################################################################# # Visual Tcl v1.60 Project # ################################# # VTCL LIBRARY PROCEDURES # if {![info exists vTcl(sourcing)]} { ############################################################################# ## Library Procedure: Window proc ::Window {args} { ## This procedure may be used free of restrictions. ## Exception added by Christian Gavin on 08/08/02. ## Other packages and widget toolkits have different licensing requirements. ## Please read their license agreements for details. global vTcl foreach {cmd name newname} [lrange $args 0 2] {} set rest [lrange $args 3 end] if {$name == "" || $cmd == ""} { return } if {$newname == ""} { set newname $name } if {$name == "."} { wm withdraw $name; return } set exists [winfo exists $newname] switch $cmd { show { if {$exists} { wm deiconify $newname } elseif {[info procs vTclWindow$name] != ""} { eval "vTclWindow$name $newname $rest" } if {[winfo exists $newname] && [wm state $newname] == "normal"} { vTcl:FireEvent $newname <> } } hide { if {$exists} { wm withdraw $newname vTcl:FireEvent $newname <> return} } iconify { if $exists {wm iconify $newname; return} } destroy { if $exists {destroy $newname; return} } } } ############################################################################# ## Library Procedure: vTcl:DefineAlias proc ::vTcl:DefineAlias {target alias widgetProc top_or_alias cmdalias} { ## This procedure may be used free of restrictions. ## Exception added by Christian Gavin on 08/08/02. ## Other packages and widget toolkits have different licensing requirements. ## Please read their license agreements for details. global widget set widget($alias) $target set widget(rev,$target) $alias if {$cmdalias} { interp alias {} $alias {} $widgetProc $target } if {$top_or_alias != ""} { set widget($top_or_alias,$alias) $target if {$cmdalias} { interp alias {} $top_or_alias.$alias {} $widgetProc $target } } } ############################################################################# ## Library Procedure: vTcl:DoCmdOption proc ::vTcl:DoCmdOption {target cmd} { ## This procedure may be used free of restrictions. ## Exception added by Christian Gavin on 08/08/02. ## Other packages and widget toolkits have different licensing requirements. ## Please read their license agreements for details. ## menus are considered toplevel windows set parent $target while {[winfo class $parent] == "Menu"} { set parent [winfo parent $parent] } regsub -all {\%widget} $cmd $target cmd regsub -all {\%top} $cmd [winfo toplevel $parent] cmd uplevel #0 [list eval $cmd] } ############################################################################# ## Library Procedure: vTcl:FireEvent proc ::vTcl:FireEvent {target event {params {}}} { ## This procedure may be used free of restrictions. ## Exception added by Christian Gavin on 08/08/02. ## Other packages and widget toolkits have different licensing requirements. ## Please read their license agreements for details. ## The window may have disappeared if {![winfo exists $target]} return ## Process each binding tag, looking for the event foreach bindtag [bindtags $target] { set tag_events [bind $bindtag] set stop_processing 0 foreach tag_event $tag_events { if {$tag_event == $event} { set bind_code [bind $bindtag $tag_event] foreach rep "\{%W $target\} $params" { regsub -all [lindex $rep 0] $bind_code [lindex $rep 1] bind_code } set result [catch {uplevel #0 $bind_code} errortext] if {$result == 3} { ## break exception, stop processing set stop_processing 1 } elseif {$result != 0} { bgerror $errortext } break } } if {$stop_processing} {break} } } ############################################################################# ## Library Procedure: vTcl:Toplevel:WidgetProc proc ::vTcl:Toplevel:WidgetProc {w args} { ## This procedure may be used free of restrictions. ## Exception added by Christian Gavin on 08/08/02. ## Other packages and widget toolkits have different licensing requirements. ## Please read their license agreements for details. if {[llength $args] == 0} { ## If no arguments, returns the path the alias points to return $w } set command [lindex $args 0] set args [lrange $args 1 end] switch -- [string tolower $command] { "setvar" { foreach {varname value} $args {} if {$value == ""} { return [set ::${w}::${varname}] } else { return [set ::${w}::${varname} $value] } } "hide" - "show" { Window [string tolower $command] $w } "showmodal" { ## modal dialog ends when window is destroyed Window show $w; raise $w grab $w; tkwait window $w; grab release $w } "startmodal" { ## ends when endmodal called Window show $w; raise $w set ::${w}::_modal 1 grab $w; tkwait variable ::${w}::_modal; grab release $w } "endmodal" { ## ends modal dialog started with startmodal, argument is var name set ::${w}::_modal 0 Window hide $w } default { uplevel $w $command $args } } } ############################################################################# ## Library Procedure: vTcl:WidgetProc proc ::vTcl:WidgetProc {w args} { ## This procedure may be used free of restrictions. ## Exception added by Christian Gavin on 08/08/02. ## Other packages and widget toolkits have different licensing requirements. ## Please read their license agreements for details. if {[llength $args] == 0} { ## If no arguments, returns the path the alias points to return $w } set command [lindex $args 0] set args [lrange $args 1 end] uplevel $w $command $args } ############################################################################# ## Library Procedure: vTcl:toplevel proc ::vTcl:toplevel {args} { ## This procedure may be used free of restrictions. ## Exception added by Christian Gavin on 08/08/02. ## Other packages and widget toolkits have different licensing requirements. ## Please read their license agreements for details. uplevel #0 eval toplevel $args set target [lindex $args 0] namespace eval ::$target {set _modal 0} } } if {[info exists vTcl(sourcing)]} { proc vTcl:project:info {} { set base .top43 namespace eval ::widgets::$base { set set,origin 1 set set,size 1 set runvisible 1 } namespace eval ::widgets::$base.lab44 { array set save {-disabledforeground 1 -font 1 -text 1} } namespace eval ::widgets::$base.cpd45 { array set save {-disabledforeground 1 -font 1 -text 1} } namespace eval ::widgets::$base.cpd46 { array set save {-disabledforeground 1 -font 1 -text 1} } namespace eval ::widgets::$base.che47 { array set save {-disabledforeground 1 -font 1 -text 1 -variable 1} } namespace eval ::widgets::$base.but48 { array set save {-command 1 -disabledforeground 1 -font 1 -text 1} } namespace eval ::widgets::$base.ent49 { array set save {-background 1 -insertbackground 1 -textvariable 1} } namespace eval ::widgets::$base.cpd50 { array set save {-background 1 -insertbackground 1 -textvariable 1} } namespace eval ::widgets::$base.cpd51 { array set save {-background 1 -insertbackground 1 -textvariable 1} } namespace eval ::widgets::$base.lis43 { array set save {-background 1 -listvariable 1} } namespace eval ::widgets::$base.lab45 { array set save {-disabledforeground 1 -font 1 -text 1} } namespace eval ::widgets_bindings { set tagslist _TopLevel } namespace eval ::vTcl::modules::main { set procs { init main cobol_update } set compounds { } set projectType single } } } ################################# # USER DEFINED PROCEDURES # ############################################################################# ## Procedure: main proc ::main {argc argv} { global cobol_fields widget set cobol_fields { name 40 address 50 phone 15 endpgm 1 } global nomes_anteriores set nomes_anteriores {} bind all do_exit } ############################################################################# ## Procedure: cobol_update proc ::cobol_update {} { global widget global nomes_anteriores name puts "tcl-TC LOG: lappend nomes_anteriores $name" lappend nomes_anteriores $name focus $widget(nome_entry) } ############################################################################# ## Initialization Procedure: init proc ::init {argc argv} { } init $argc $argv ################################# # VTCL GENERATED GUI PROCEDURES # proc vTclWindow. {base} { if {$base == ""} { set base . } ################### # CREATING WIDGETS ################### wm focusmodel $top passive wm geometry $top 1x1+0+0; update wm maxsize $top 1265 994 wm minsize $top 1 1 wm overrideredirect $top 0 wm resizable $top 1 1 wm withdraw $top wm title $top "vtcl.tcl" bindtags $top "$top Vtcl.tcl all" vTcl:FireEvent $top <> wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <>" ################### # SETTING GEOMETRY ################### vTcl:FireEvent $base <> } proc vTclWindow.top43 {base} { if {$base == ""} { set base .top43 } if {[winfo exists $base]} { wm deiconify $base; return } set top $base ################### # CREATING WIDGETS ################### vTcl:toplevel $top -class Toplevel \ -highlightcolor black wm focusmodel $top passive wm geometry $top 570x523+327+247; update wm maxsize $top 1265 994 wm minsize $top 1 1 wm overrideredirect $top 0 wm resizable $top 1 1 wm deiconify $top wm title $top "New Toplevel 1" vTcl:DefineAlias "$top" "Toplevel1" vTcl:Toplevel:WidgetProc "" 1 bindtags $top "$top Toplevel all _TopLevel" vTcl:FireEvent $top <> wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <>" label $top.lab44 \ -disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Nome: vTcl:DefineAlias "$top.lab44" "Label1" vTcl:WidgetProc "Toplevel1" 1 label $top.cpd45 \ -disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Endereço: vTcl:DefineAlias "$top.cpd45" "Label2" vTcl:WidgetProc "Toplevel1" 1 label $top.cpd46 \ -disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Telefone: vTcl:DefineAlias "$top.cpd46" "Label3" vTcl:WidgetProc "Toplevel1" 1 checkbutton $top.che47 \ -disabledforeground #a1a4a1 -font {helvetica 10} -text concluido \ -variable endpgm vTcl:DefineAlias "$top.che47" "Checkbutton1" vTcl:WidgetProc "Toplevel1" 1 button $top.but48 \ -command do_exit -disabledforeground #a1a4a1 \ -font {helvetica 10 bold} -text entra vTcl:DefineAlias "$top.but48" "Button1" vTcl:WidgetProc "Toplevel1" 1 entry $top.ent49 \ -background white -insertbackground black -textvariable name vTcl:DefineAlias "$top.ent49" "nome_entry" vTcl:WidgetProc "Toplevel1" 1 entry $top.cpd50 \ -background white -insertbackground black -textvariable address vTcl:DefineAlias "$top.cpd50" "Entry2" vTcl:WidgetProc "Toplevel1" 1 entry $top.cpd51 \ -background white -insertbackground black -textvariable phone vTcl:DefineAlias "$top.cpd51" "Entry3" vTcl:WidgetProc "Toplevel1" 1 listbox $top.lis43 \ -background white -listvariable nomes_anteriores vTcl:DefineAlias "$top.lis43" "Listbox1" vTcl:WidgetProc "Toplevel1" 1 label $top.lab45 \ -disabledforeground #a1a4a1 -font {verdana -11} \ -text {nomes anteriores} vTcl:DefineAlias "$top.lab45" "Label4" vTcl:WidgetProc "Toplevel1" 1 ################### # SETTING GEOMETRY ################### place $top.lab44 \ -x 25 -y 35 -anchor nw -bordermode ignore place $top.cpd45 \ -x 25 -y 100 -anchor nw place $top.cpd46 \ -x 25 -y 170 -anchor nw place $top.che47 \ -x 30 -y 440 -anchor nw -bordermode ignore place $top.but48 \ -x 240 -y 430 -anchor nw -bordermode ignore place $top.ent49 \ -x 140 -y 40 -width 403 -height 27 -anchor nw -bordermode ignore place $top.cpd50 \ -x 175 -y 100 -width 368 -height 27 -anchor nw place $top.cpd51 \ -x 175 -y 175 -width 273 -height 27 -anchor nw place $top.lis43 \ -x 155 -y 245 -width 383 -height 156 -anchor nw -bordermode ignore place $top.lab45 \ -x 35 -y 250 -anchor nw -bordermode ignore vTcl:FireEvent $base <> } ############################################################################# ## Binding tag: _TopLevel bind "_TopLevel" <> { if {![info exists _topcount]} {set _topcount 0}; incr _topcount } bind "_TopLevel" <> { if {[set ::%W::_modal]} { vTcl:Toplevel:WidgetProc %W endmodal } else { destroy %W; if {$_topcount == 0} {exit} } } bind "_TopLevel" { if {[winfo toplevel %W] == "%W"} {incr _topcount -1} } Window show . Window show .top43 main $argc $argv