diff --git a/src/generic/gencli.tcl b/src/generic/gencli.tcl old mode 100755 new mode 100644 index 08368b54..01570451 --- a/src/generic/gencli.tcl +++ b/src/generic/gencli.tcl @@ -45,7 +45,7 @@ namespace ensemble configure string -map [dict replace\ [namespace ensemble configure string -map]\ insert ::tcl::string::insert] proc {} { args } { ; } -proc canvas { args } { ; } +proc canvas { args } { ; } proc pack { args } { ; } proc .ed_mainFrame { args } { ; } proc .ed_mainFrame.notebook { args } { ; } @@ -78,7 +78,7 @@ proc bgerror {{message ""}} { } } -proc configtable {} { +proc configtable {} { global vustatus threadscreated virtual_users maxvuser table ntimes thvnum totrun AVUC set AVUC "idle" if { ![info exists vustatus] } { set vustatus {} } @@ -111,8 +111,8 @@ proc find_current_dict {} { set posswkl [ split [ dict get $dbdict $key workloads ]] set ind [lsearch $posswkl $bm] if { $ind != -1 } { set wkltoremove [lreplace $posswkl $ind $ind ] - if { [ llength $wkltoremove ] > 1 } { - putscli "Error printing dict format more than 2 workloads" + if { [ llength $wkltoremove ] > 1 } { + putscli "Error printing dict format more than 2 workloads" return } else { set bmdct [ string tolower [ join [ split $wkltoremove - ] "" ]] @@ -124,26 +124,26 @@ proc find_current_dict {} { } } -proc runninguser { threadid } { +proc runninguser { threadid } { global table threadscreated thvnum inrun AVUC vustatus jobid set AVUC "run" set message [ join " Vuser\ [ expr $thvnum($threadid) + 1]:RUNNING" ] - catch { putscli $message } + catch { putscli $message } hdbjobs eval {INSERT INTO JOBOUTPUT VALUES($jobid, 0, $message)} dict set vustatus [ expr $thvnum($threadid) + 1 ] "RUNNING" } -proc printresult { result threadid } { +proc printresult { result threadid } { global vustatus table threadscreated thvnum succ fail totrun totcount inrun AVUC jobid incr totcount if { $result == 0 } { set message [ join " Vuser\ [expr $thvnum($threadid) + 1]:FINISHED SUCCESS" ] - catch {putscli $message } + catch {putscli $message } hdbjobs eval {INSERT INTO JOBOUTPUT VALUES($jobid, 0, $message)} dict set vustatus [ expr $thvnum($threadid) + 1 ] "FINISH SUCCESS" } else { set message [ join " Vuser\ [expr $thvnum($threadid) + 1]:FINISHED FAILED" ] - catch {putscli $message } + catch {putscli $message } hdbjobs eval {INSERT INTO JOBOUTPUT VALUES($jobid, 0, $message)} dict set vustatus [ expr $thvnum($threadid) + 1 ] "FINISH FAILED" } @@ -157,10 +157,10 @@ proc printresult { result threadid } { } } -proc tk_messageBox { args } { +proc tk_messageBox { args } { global jobid set messind [ lsearch $args -message ] - if { $messind eq -1 } { + if { $messind eq -1 } { set message "tk_messageBox with unknown message" } else { set message [ lindex $args [expr $messind + 1] ] @@ -168,7 +168,7 @@ proc tk_messageBox { args } { hdbjobs eval {INSERT INTO JOBOUTPUT VALUES($jobid, 0, $message)} putscli $message set typeind [ lsearch $args yesno ] - if { $typeind eq -1 } { set yesno "false" + if { $typeind eq -1 } { set yesno "false" } else { set yesno "true" } @@ -179,9 +179,9 @@ proc tk_messageBox { args } { #Delete 2 lines above for interactive response gets stdin reply set yntoup [ string toupper $reply ] - if { [ string match NO $yntoup ] } { + if { [ string match NO $yntoup ] } { putscli "replied no" - return "no" } else { + return "no" } else { putscli "replied yes" return "yes" } } @@ -219,7 +219,7 @@ proc myerrorproc { id info } { rename Log _Log proc Log {id msg lastline} { global tids threadsbytid jobid - catch {putscli [ join " Vuser\ [expr $threadsbytid($id) + 1]:$lastline" ]} + catch {putscli [ join " Vuser\ [expr $threadsbytid($id) + 1]:$lastline" ]} set vuser [expr $threadsbytid($id) + 1] set lastline [ string trimright $lastline ] hdbjobs eval {INSERT INTO JOBOUTPUT VALUES($jobid, $vuser, $lastline)} @@ -246,9 +246,9 @@ proc .ed_mainFrame.mainwin.textFrame.left.text { args } { } else { switch $action { fastinsert { - if {[string is integer -strict [ lindex $args 1 ]]} { + if {[string is integer -strict [ lindex $args 1 ]]} { #Insert at the index given - set insertind [ lindex $args 1 ] + set insertind [ lindex $args 1 ] set offset 0 set substring [ lindex $args 2 ] set _ED(package) [ string insert $_ED(package) $insertind $substring ] @@ -323,7 +323,7 @@ proc .ed_mainFrame.mainwin.textFrame.left.text { args } { } } search { - set srchdirection [ lindex $args 1 ] + set srchdirection [ lindex $args 1 ] if { $srchdirection eq "-backwards" } { set stringtofind [lindex $args 2] set ind [ string last $stringtofind $_ED(package) ] @@ -336,7 +336,7 @@ proc .ed_mainFrame.mainwin.textFrame.left.text { args } { puts "Error: failed to match arguments for text search in script : [ lindex $args 0 ] [ lindex $args 1 ]" return } - } + } } } } @@ -423,12 +423,14 @@ proc vuset { args } { puts "Error: Virtual Users exist, destroy with vudestroy before changing settings" return } + set db "generic" + set dct "virtual_user_options" switch $option { - vu { + vu { set virtual_users $val - if { $virtual_users eq "vcpu" } { - set virtual_users [ numberOfCPUs ] - } + if { $virtual_users eq "vcpu" } { + set virtual_users [ numberOfCPUs ] + } if { ![string is integer -strict $virtual_users] } { tk_messageBox -message "The number of virtual users must be an integer" puts -nonewline "setting to value: " @@ -441,6 +443,7 @@ proc vuset { args } { return } } + SQLiteUpdateKeyValue $db $dct "virtual_users" $virtual_users remote_command [ concat vuset vu $val ] } delay { @@ -455,6 +458,7 @@ proc vuset { args } { set conpause 500 } } + SQLiteUpdateKeyValue $db $dct "user_delay" $conpause remote_command [ concat vuset delay $val ] } repeat { @@ -469,6 +473,7 @@ proc vuset { args } { set delayms 500 } } + SQLiteUpdateKeyValue $db $dct "repeat_delay" $delayms remote_command [ concat vuset repeat $val ] } iterations { @@ -483,9 +488,10 @@ proc vuset { args } { set ntimes 1 } } + SQLiteUpdateKeyValue $db $dct "iterations" $ntimes remote_command [ concat vuset iterations $val ] } - showoutput { + showoutput { set suppo $val if { ![string is integer -strict $suppo] } { tk_messageBox -message "Show Output must be 0 or 1" @@ -497,9 +503,10 @@ proc vuset { args } { set suppo 1 } } + SQLiteUpdateKeyValue $db $dct "show_output" $suppo remote_command [ concat vuset showoutput $val ] } - logtotemp { + logtotemp { set optlog $val if { ![string is integer -strict $optlog] } { tk_messageBox -message "Log Output must be 0 or 1" @@ -511,9 +518,10 @@ proc vuset { args } { set optlog 0 } } + SQLiteUpdateKeyValue $db $dct "log_to_temp" $optlog remote_command [ concat vuset logtotemp $val ] } - unique { + unique { set unique_log_name $val if { ![string is integer -strict $unique_log_name] } { tk_messageBox -message "Unique Log Name must be 0 or 1" @@ -525,9 +533,10 @@ proc vuset { args } { set unique_log_name 0 } } + SQLiteUpdateKeyValue $db $dct "unique_log_name" $unique_log_name remote_command [ concat vuset unique $val ] } - nobuff { + nobuff { set no_log_buffer $val if { ![string is integer -strict $no_log_buffer] } { tk_messageBox -message "No Log Buffer must be 0 or 1" @@ -539,9 +548,10 @@ proc vuset { args } { set no_log_buffer 0 } } + SQLiteUpdateKeyValue $db $dct "no_log_buffer" $no_log_buffer remote_command [ concat vuset nobuff $val ] } - timestamps { + timestamps { set log_timestamps $val if { ![string is integer -strict $log_timestamps] } { tk_messageBox -message "Log timestamps must be 0 or 1" @@ -553,6 +563,7 @@ proc vuset { args } { set log_timestamps 0 } } + SQLiteUpdateKeyValue $db $dct "log_timestamps" $log_timestamps remote_command [ concat vuset timestamps $val ] } default { @@ -562,27 +573,27 @@ proc vuset { args } { }}} proc findakey { key2find dictname } { - upvar #0 $dictname $dictname - foreach key [dict keys [ set $dictname]] { - dict for {k v} [dict get [ set $dictname ] $key] { - if { $k eq $key2find } { + upvar #0 $dictname $dictname + foreach key [dict keys [ set $dictname]] { + dict for {k v} [dict get [ set $dictname ] $key] { + if { $k eq $key2find } { return $key - } - } + } } -return {} + } + return {} } proc diset { args } { global rdbms opmode if {[ llength $args ] != 3} { putscli "Error: Invalid number of arguments\nUsage: diset dict key value" - putscli "Type \"print dict\" for valid dictionaries and keys for $rdbms" + putscli "Type \"print dict\" for valid dictionaries and keys for $rdbms" } else { set dct [ lindex $args 0 ] set key2 [ lindex $args 1 ] set val [ lindex $args 2 ] - if { [ string match *pass* [ lindex $args 1 ]] } { + if { [ string match *pass* [ lindex $args 1 ]] } { set val [ quotemeta [ lindex $args 2 ]] } else { set val [ lindex $args 2 ] @@ -602,28 +613,28 @@ proc diset { args } { if { [ string match *driver $key2 ] && ![ string match *odbc_driver $key2 ] } { putscli "Clearing Script, reload script to activate new setting" clearscript - if { $val != "test" && $val != "timed" } { + if { $val != "test" && $val != "timed" } { putscli "Error: Driver script must be either \"test\" or \"timed\"" return - } + } } if { [catch {dict set $dictname $dct $key2 [ concat $val ] } message]} { putscli "Failed to set Dictionary value: $message" } else { putscli "Changed $dct:$key2 from $previous to [ concat $val ] for $rdbms" - #Save new value to SQLite - SQLiteUpdateKeyValue $key $dct $key2 $val + #Save new value to SQLite + SQLiteUpdateKeyValue $key $dct $key2 $val remote_command [ concat diset $dct $key2 [ list \{$val\} ]] }} - } else { - set key2find [ findakey $key2 $dictname ] - if { [ string length $key2find ] > 0 } { - putscli "Dictionary \"$dct\" for $rdbms exists but key \"$key2\" doesn't, key \"$key2\" is in the \"$key2find\" dictionary" - } else { - putscli "Dictionary \"$dct\" for $rdbms exists but key \"$key2\" doesn't, key \"$key2\" cannot be found in any $rdbms dictionary" - } - putscli "Type \"print dict\" for valid dictionaries and keys for $rdbms" - } + } else { + set key2find [ findakey $key2 $dictname ] + if { [ string length $key2find ] > 0 } { + putscli "Dictionary \"$dct\" for $rdbms exists but key \"$key2\" doesn't, key \"$key2\" is in the \"$key2find\" dictionary" + } else { + putscli "Dictionary \"$dct\" for $rdbms exists but key \"$key2\" doesn't, key \"$key2\" cannot be found in any $rdbms dictionary" + } + putscli "Type \"print dict\" for valid dictionaries and keys for $rdbms" + } } else { putscli {Usage: diset dict key value} putscli "Dictionary \"$dct\" for $rdbms does not exist" @@ -635,36 +646,35 @@ proc giset { args } { global rdbms opmode if {[ llength $args ] != 3} { putscli "Error: Invalid number of arguments\nUsage: giset dict key value" - putscli "Type \"print generic\" for valid dictionaries and keys" + putscli "Type \"print generic\" for valid dictionaries and keys" } else { set dct [ lindex $args 0 ] set key2 [ lindex $args 1 ] set val [ lindex $args 2 ] - upvar #0 genericdict genericdict - if {[dict exists $genericdict $dct ]} { - if {[dict exists $genericdict $dct $key2 ]} { - set previous [ dict get $genericdict $dct $key2 ] - if { $previous eq [ concat $val ] } { - putscli "Value $val for $dct:$key2 is the same as existing value $previous, no change made" - } else { - if { [catch {dict set genericdict $dct $key2 [ concat $val ] } message]} { - putscli "Failed to set Dictionary value: $message" - } else { - putscli "Changed $dct:$key2 from $previous to [ concat $val ] for generic" - #Save new value to SQLite - SQLiteUpdateKeyValue "generic" $dct $key2 $val - remote_command [ concat giset $dct $key2 [ list \{$val\} ]] - }} - } else { - putscli "Dictionary \"$dct\" exists but key \"$key2\" doesn't" - putscli "Type \"print generic\" for valid dictionaries and keys" - } + upvar #0 genericdict genericdict + if {[dict exists $genericdict $dct ]} { + if {[dict exists $genericdict $dct $key2 ]} { + set previous [ dict get $genericdict $dct $key2 ] + if { $previous eq [ concat $val ] } { + putscli "Value $val for $dct:$key2 is the same as existing value $previous, no change made" } else { - putscli {Usage: giset dict key value} - putscli "Type \"print generic\" for valid dictionaries and keys" - } -}} + if { [catch {dict set genericdict $dct $key2 [ concat $val ] } message]} { + putscli "Failed to set Dictionary value: $message" + } else { + putscli "Changed $dct:$key2 from $previous to [ concat $val ] for generic" + #Save new value to SQLite + SQLiteUpdateKeyValue "generic" $dct $key2 $val + remote_command [ concat giset $dct $key2 [ list \{$val\} ]] + }} + } else { + putscli "Dictionary \"$dct\" exists but key \"$key2\" doesn't" + putscli "Type \"print generic\" for valid dictionaries and keys" + } + } else { + putscli {Usage: giset dict key value} + putscli "Type \"print generic\" for valid dictionaries and keys" +}}} proc librarycheck {} { upvar #0 dbdict dbdict @@ -677,15 +687,15 @@ proc librarycheck {} { } foreach db $dbl library $libl { puts "Checking database library for $db" - if { [ llength $library ] > 1 } { + if { [ llength $library ] > 1 } { set version [ lindex $library 1 ] set library [ lindex $library 0 ] set cmd "package require $library $version" } else { set cmd "package require $library" } - if [catch {eval $cmd} message] { - puts "Error: failed to load $library - $message" + if [catch {eval $cmd} message] { + puts "Error: failed to load $library - $message" if {[string match windows $::tcl_platform(platform)]} { puts "Ensure that $db client libraries are installed and the location in the PATH environment variable" } else { @@ -728,7 +738,7 @@ proc dbset { args } { putscli "Database set to $rdbms" SQLiteUpdateKeyValue "generic" "benchmark" "rdbms" $rdbms } - } + } bm { set toup [ string toupper $val ] if { [ string match ???-? $toup ] || [ string match ?????-? $toup ] } { set dashformat "true" } else { set dashformat "false" } @@ -804,7 +814,7 @@ proc print { args } { upvar #0 config$key config$key set posswkl [ split [ dict get $dbdict $key workloads ]] set ind [lsearch $posswkl $bm] - if { $ind != -1 } { set wkltoremove [lreplace $posswkl $ind $ind ] + if { $ind != -1 } { set wkltoremove [lreplace $posswkl $ind $ind ] if { [ llength $wkltoremove ] > 1 } { puts "Error printing dict format more than 2 workloads" } else { set bmdct [ string tolower [ join [ split $wkltoremove - ] "" ]] set tmpdictforpt [ dict remove [ subst \$config$key ] $bmdct ] @@ -814,11 +824,11 @@ proc print { args } { pdict 2 $tmpdictforpt }} } - generic { - puts "Generic Dictionary Settings" + generic { + puts "Generic Dictionary Settings" upvar #0 genericdict genericdict - pdict 2 $genericdict - } + pdict 2 $genericdict + } vuconf { foreach i { "Virtual Users" "User Delay(ms)" "Repeat Delay(ms)" "Iterations" "Show Output" "Log Output" "Unique Log Name" "No Log Buffer" "Log Timestamps" } j { virtual_users conpause delayms ntimes suppo optlog unique_log_name no_log_buffer log_timestamps } { puts "$i = [ set $j ]" @@ -912,12 +922,12 @@ proc vudestroy {} { unset -nocomplain AVUC unset -nocomplain vustatus } - if { $x eq 20 } { - set checkstop 1 + if { $x eq 20 } { + set checkstop 1 putscli "Virtual Users remain running in background or shutting down, retry" } } - } + } } else { if { $opmode eq "Replica" } { #In Primary Replica Mode ed_kill_vusers may have already been called from Primary so thread::names is 1 @@ -934,7 +944,7 @@ proc vustatus {} { global vustatus if { ![info exists vustatus] } { puts "No Virtual Users found" - } else { + } else { if { [ catch {[ set vuoput [ pdict 1 $vustatus ] ]}] } { puts "Error in finding VU status" } else { @@ -948,8 +958,8 @@ proc vucomplete {} { if { ![info exists AVUC] } { return false } else { - if { $AVUC eq "complete" } { - return true + if { $AVUC eq "complete" } { + return true } else { return false } @@ -958,7 +968,7 @@ proc vucomplete {} { proc loadscript {} { global bm _ED opmode if { $bm eq "TPC-H" } { loadtpch } else { loadtpcc } - if { [ string length $_ED(package) ] > 0 } { + if { [ string length $_ED(package) ] > 0 } { putscli "Script loaded, Type \"print script\" to view" } else { putscli "Error:script failed to load" @@ -980,7 +990,7 @@ proc loadscript {} { proc clearscript {} { global bm _ED opmode set _ED(package) "" - if { [ string length $_ED(package) ] eq 0 } { + if { [ string length $_ED(package) ] eq 0 } { putscli "Script cleared" } else { putscli "Error:script failed to clear" @@ -1034,55 +1044,55 @@ return } proc savescript { savefile } { - global _ED - if { [ string length $_ED(package) ] eq 0 } { - putscli "Error: No script loaded to save, use loadscript to load" - return - } - if { [ file extension $savefile ] != ".tcl" } { - #extension is not tcl - if { [ file extension $savefile ] eq "" } { - #There is no extension add one - set savefile [ concat $savefile.tcl ] - } else { - #There is an extension but its not tcl, change it - set savefile "[ file rootname $savefile ].tcl" - } - } - #filename has .tcl extension - if { [ file dirname $savefile ] eq "." } { - #only filename given save to temp - set save_directory [ findtempdir ] - set savefile [ file join $save_directory $savefile ] - } else { - #directory given, check its writable - set directory [ file dirname $savefile ] - if { [ file writable $directory ] } { - #directory is writable, save file - } else { - #directory given is not writable, show error - putscli "Error: directory $directory not writable to write $savefile for savescript" - return - } - } - #filename now in a writable format - if { [ catch {set fd [open $savefile w]} message ] } { - putscli "Error: Failed to open $savefile for writing" - return - } else { - if { [ catch {puts $fd $_ED(package)} message ] } { - putscli "Error: Failed to write to $savefile" - } else { - putscli "Success ... wrote script to $savefile" - catch {close $fd} - return - } - } + global _ED + if { [ string length $_ED(package) ] eq 0 } { + putscli "Error: No script loaded to save, use loadscript to load" + return + } + if { [ file extension $savefile ] != ".tcl" } { + #extension is not tcl + if { [ file extension $savefile ] eq "" } { + #There is no extension add one + set savefile [ concat $savefile.tcl ] + } else { + #There is an extension but its not tcl, change it + set savefile "[ file rootname $savefile ].tcl" + } + } + #filename has .tcl extension + if { [ file dirname $savefile ] eq "." } { + #only filename given save to temp + set save_directory [ findtempdir ] + set savefile [ file join $save_directory $savefile ] + } else { + #directory given, check its writable + set directory [ file dirname $savefile ] + if { [ file writable $directory ] } { + #directory is writable, save file + } else { + #directory given is not writable, show error + putscli "Error: directory $directory not writable to write $savefile for savescript" + return + } + } + #filename now in a writable format + if { [ catch {set fd [open $savefile w]} message ] } { + putscli "Error: Failed to open $savefile for writing" + return + } else { + if { [ catch {puts $fd $_ED(package)} message ] } { + putscli "Error: Failed to write to $savefile" + } else { + putscli "Success ... wrote script to $savefile" + catch {close $fd} + return + } + } } proc distributescript {} { global opmode masterlist - if { $opmode != "Primary" } { + if { $opmode != "Primary" } { puts "Error: Cannot distribute script if not in Primary mode" } else { if { [ llength $masterlist ] eq 0 } { @@ -1110,7 +1120,7 @@ proc build_schema {} { break } } - if { [ string length $_ED(package) ] > 0 } { + if { [ string length $_ED(package) ] > 0 } { #yes was pressed run_virtual } else { @@ -1207,7 +1217,7 @@ proc buildschema {} { if { [ info exists jobid ] && ![ job_disable_check ] } { return "Schema Build jobid=$jobid" } else { - unset -nocomplain jobid + unset -nocomplain jobid return "Schema Build (No jobid)" } } @@ -1222,7 +1232,7 @@ proc keepalive {} { upvar #0 genericdict genericdict if {[dict exists $genericdict commandline keepalive_margin]} { set ka_margin [ dict get $genericdict commandline keepalive_margin] - if {![string is entier $ka_margin]} { + if {![string is entier $ka_margin]} { set ka_margin 10 } } else { @@ -1270,7 +1280,7 @@ proc check_schema {} { break } } - if { [ string length $_ED(package) ] > 0 } { + if { [ string length $_ED(package) ] > 0 } { #yes was pressed run_virtual } else { @@ -1308,11 +1318,11 @@ proc checkschema {} { } #Add automated waittocomplete to deleteschema _waittocomplete - if { [ info exists jobid ] && ![ job_disable_check ] } { + if { [ info exists jobid ] && ![ job_disable_check ] } { return "Schema Check jobid=$jobid" } else { - unset -nocomplain jobid - return "Schema Check (No jobid)" + unset -nocomplain jobid + return "Schema Check (No jobid)" } } @@ -1333,7 +1343,7 @@ proc delete_schema {} { break } } - if { [ string length $_ED(package) ] > 0 } { + if { [ string length $_ED(package) ] > 0 } { #yes was pressed run_virtual } else { @@ -1371,20 +1381,20 @@ proc deleteschema {} { } #Add automated waittocomplete to deleteschema _waittocomplete - if { [ info exists jobid ] && ![ job_disable_check ] } { + if { [ info exists jobid ] && ![ job_disable_check ] } { return "Schema Delete jobid=$jobid" } else { - unset -nocomplain jobid - return "Schema Delete (No jobid)" + unset -nocomplain jobid + return "Schema Delete (No jobid)" } } proc vurun {} { -global threadscreated -if { ![ info exists threadscreated ] && [expr [ llength [ threadnames_without_tcthread ] ] - 1 ] > 0} { + global threadscreated + if { ![ info exists threadscreated ] && [expr [ llength [ threadnames_without_tcthread ] ] - 1 ] > 0} { putscli "Error: Cannot call vurun with Virtual Users already active" - return - } + return + } global _ED opmode jobid set jobid [guid] @@ -1392,13 +1402,13 @@ if { ![ info exists threadscreated ] && [expr [ llength [ threadnames_without_tc dict set jsondict error message "Jobid already exists or error in creating jobid in JOBMAIN table" #return } - + #If calling vurun and virtual users not created, create them now if {[expr [ llength [ threadnames_without_tcthread ] ] - 1 ] eq 0} { vucreate } #In turn if script is not already loaded vucreate should call loadscript meaning following should not return no workload to run - if { [ string length $_ED(package) ] > 0 } { + if { [ string length $_ED(package) ] > 0 } { remote_command [ concat vurun ] if { [ catch {run_virtual} message ] } { putscli "Error: $message" @@ -1414,7 +1424,7 @@ if { ![ info exists threadscreated ] && [expr [ llength [ threadnames_without_tc if { [ info exists jobid ] && ![ job_disable_check ] } { return "Benchmark Run jobid=$jobid" } else { - unset -nocomplain jobid + unset -nocomplain jobid return "Benchmark Run (No jobid)" } } @@ -1439,7 +1449,7 @@ proc datagenrun {} { if { [ catch {run_datagen} message ] } { puts "Error: $message" } - if { [ string length $_ED(package) ] > 0 } { + if { [ string length $_ED(package) ] > 0 } { #yes was pressed run_virtual } else { @@ -1470,13 +1480,13 @@ proc dgset { args } { vu { set gen_num_vu $val if { $bm eq "TPC-C" } { - if { ![string is integer -strict $gen_count_ware] || $gen_count_ware < 1 || $gen_count_ware > 100000 } { - tk_messageBox -message "The number of warehouses must be a positive integer less than or equal to 100000" + if { ![string is integer -strict $gen_count_ware] || $gen_count_ware < 1 || $gen_count_ware > 100000 } { + tk_messageBox -message "The number of warehouses must be a positive integer less than or equal to 100000" #puts -nonewline "setting to value: " set gen_num_vu 1 set virtual_users 1 return - } + } if { $gen_num_vu > $gen_count_ware } { puts "Error:Build virtual users must be less than or equal to number of warehouses" puts "You have $gen_num_vu virtual users building $gen_count_ware warehouses" @@ -1614,7 +1624,7 @@ proc switchmode {{assignmode "current"} {assignid 0} {assignhost "localhost"} ar if { [ info exists id ] } { ; } else { set id 0 } if { [ info exists masterlist ] } { ; } else { set masterlist "" } set oldmode $opmode - set modestring [ string tolower $assignmode ] + set modestring [ string tolower $assignmode ] switch $modestring { "current" { puts "Mode currently set to $opmode" @@ -1635,8 +1645,8 @@ proc switchmode {{assignmode "current"} {assignid 0} {assignhost "localhost"} ar puts "Error:Mode to switch to must be one of Local, Primary or Replica" return } - } - if { $oldmode eq $opmode } { tk_messageBox -title "Confirm Mode" -message "Already in $opmode mode" } else { + } + if { $oldmode eq $opmode } { tk_messageBox -title "Confirm Mode" -message "Already in $opmode mode" } else { if {[ tk_messageBox -icon question -title "Confirm Mode" -message "Switch from $oldmode\nto $opmode mode?" -type yesno ] == yes} { set opmode [ switch_mode $opmode $hostname $id $masterlist ] } else { set opmode $oldmode } } return } @@ -1658,15 +1668,15 @@ proc _waittocomplete {} { upvar timevar timevar upvar wcomplete wcomplete set wcomplete [vucomplete] - if {!$wcomplete} { catch {after 5000 wait_to_complete_loop} } else { - set timevar 1 + if {!$wcomplete} { catch {after 5000 wait_to_complete_loop} } else { + set timevar 1 } } set wcomplete "false" wait_to_complete_loop - if {![ info exists timevar ] || $timevar != 1 } { - vwait timevar - } + if {![ info exists timevar ] || $timevar != 1 } { + vwait timevar + } return } @@ -1698,9 +1708,9 @@ proc _runtimer { seconds } { set elapsed 0 set timevar 0 runtimer_loop $seconds - if {![ info exists timevar ] || $timevar != 1 } { - vwait timevar - } + if {![ info exists timevar ] || $timevar != 1 } { + vwait timevar + } return } @@ -1711,7 +1721,7 @@ proc tcstart {} { set idx [ lsearch $tclist $tc_threadID ] if { $idx != -1 } { tk_messageBox -icon warning -message "Transaction Counter thread already running with threadid:$tc_threadID" - return + return } else { tk_messageBox -icon warning -message "Transaction Counter thread already running" return @@ -1729,7 +1739,7 @@ proc tcstatus {} { set idx [ lsearch $tclist $tc_threadID ] if { $idx != -1 } { tk_messageBox -icon warning -message "Transaction Counter thread running with threadid:$tc_threadID" - return + return } else { tk_messageBox -icon warning -message "Transaction Counter thread running" return @@ -1746,10 +1756,10 @@ proc tcstop {} { set idx [ lsearch $tclist $tc_threadID ] if { $idx != -1 } { tk_messageBox -icon warning -message "Transaction Counter thread running with threadid:$tc_threadID" - ed_kill_transcount + ed_kill_transcount } else { tk_messageBox -icon warning -message "Transaction Counter thread running" - ed_kill_transcount + ed_kill_transcount } } else { putscli "Transaction Counter is not running" @@ -1774,9 +1784,9 @@ proc tcset {args} { if { $idx != -1 } { tk_messageBox -icon warning -message "Stop Transaction Counter before setting configuration" return - }} + }} switch $option { - refreshrate { + refreshrate { set refreshrate $val if { ![string is integer -strict $refreshrate] } { tk_messageBox -message "Refresh rate must be an integer more than 0 secs and less than 60 secs" @@ -1784,7 +1794,7 @@ proc tcset {args} { set refreshrate 10 } else { if { ($refreshrate >= 60) || ($refreshrate <= 0) } { tk_messageBox -message "Refresh rate must be more than 0 secs and less than 60 secs" - set refreshrate 10 + set refreshrate 10 } } if { [catch {dict set genericdict transaction_counter tc_refresh_rate $refreshrate}] } { @@ -1793,7 +1803,7 @@ proc tcset {args} { putscli "Transaction Counter refresh rate set to $refreshrate" } } - logtotemp { + logtotemp { set logtotemp $val if { ![string is integer -strict $logtotemp ] } { tk_messageBox -message "Log Output must be 0 or 1" @@ -1811,7 +1821,7 @@ proc tcset {args} { putscli "Transaction Counter log to temp set to $logtotemp" } } - unique { + unique { set unique_log_name $val if { ![string is integer -strict $unique_log_name] } { tk_messageBox -message "Unique Log Name must be 0 or 1" @@ -1829,7 +1839,7 @@ proc tcset {args} { putscli "Transaction Counter unique log name set to $unique_log_name" } } - timestamps { + timestamps { set log_timestamps $val if { ![string is integer -strict $log_timestamps] } { tk_messageBox -message "Log timestamps must be 0 or 1" @@ -1875,58 +1885,58 @@ proc strip_html { htmlText } { } proc wsport { args } { - global ws_port - if { ![info exists ws_port ] } { - set ws_port [ get_ws_port ] - } else { + global ws_port + if { ![info exists ws_port ] } { + set ws_port [ get_ws_port ] + } else { dict set genericdict "webservice" "ws_port" $ws_port Dict2SQLite "generic" $genericdict - } - switch [ llength $args ] { - 0 { - putscli "Web Service Port set to $ws_port" - } - 1 { - set tmp_port $args - if { ![string is integer -strict $tmp_port ] } { - putscli "Error: Web Service port should be an integer" - } else { - set ws_port $tmp_port - putscli "Setting Web Service port to $ws_port" - dict set genericdict "webservice" "ws_port" $ws_port - Dict2SQLite "generic" $genericdict - } - } - default { - putscli "Error :wsport accepts none or one integer argument" - } - } + } + switch [ llength $args ] { + 0 { + putscli "Web Service Port set to $ws_port" + } + 1 { + set tmp_port $args + if { ![string is integer -strict $tmp_port ] } { + putscli "Error: Web Service port should be an integer" + } else { + set ws_port $tmp_port + putscli "Setting Web Service port to $ws_port" + dict set genericdict "webservice" "ws_port" $ws_port + Dict2SQLite "generic" $genericdict + } + } + default { + putscli "Error :wsport accepts none or one integer argument" + } + } } proc wsstart {} { global ws_port if { ![info exists ws_port ] } { - set ws_port [ get_ws_port ] - } else { + set ws_port [ get_ws_port ] + } else { dict set genericdict "webservice" "ws_port" $ws_port Dict2SQLite "generic" $genericdict - } - exec [ auto_execok ./hammerdbws ] & - after 100 + } + exec [ auto_execok ./hammerdbws ] & + after 100 } proc wsstop {} { global ws_port if { ![info exists ws_port ] } { - set ws_port [ get_ws_port ] - } else { + set ws_port [ get_ws_port ] + } else { dict set genericdict "webservice" "ws_port" $ws_port Dict2SQLite "generic" $genericdict - } + } if [ catch {set tok [http::geturl http://localhost:$ws_port/quit]} message ] { - putscli "Web Service not running: $message" + putscli "Web Service not running: $message" } else { - putscli "Stopping HammerDB Web Service on port $ws_port" + putscli "Stopping HammerDB Web Service on port $ws_port" } if { [ info exists tok ] } { http::cleanup $tok } } @@ -1934,20 +1944,20 @@ proc wsstop {} { proc wsstatus {} { global ws_port if { ![info exists ws_port ] } { - set ws_port [ get_ws_port ] - } else { + set ws_port [ get_ws_port ] + } else { dict set genericdict "webservice" "ws_port" $ws_port Dict2SQLite "generic" $genericdict - } + } if [ catch {set tok [http::geturl http://localhost:$ws_port/env]} message ] { - putscli "Web Service not running: $message" + putscli "Web Service not running: $message" } else { - set wsenv [ strip_html [ http::data $tok ]] - if {[ lindex [ split $wsenv "\n" ] 0 ] eq "Service Environment"} { - putscli "Web Service running: $wsenv" - } else { - putscli "Web Service output error: $wsenv" - } + set wsenv [ strip_html [ http::data $tok ]] + if {[ lindex [ split $wsenv "\n" ] 0 ] eq "Service Environment"} { + putscli "Web Service running: $wsenv" + } else { + putscli "Web Service output error: $wsenv" + } } if { [ info exists tok ] } { http::cleanup $tok } } diff --git a/src/generic/gened.tcl b/src/generic/gened.tcl old mode 100755 new mode 100644 index a961cc62..87140fd6 --- a/src/generic/gened.tcl +++ b/src/generic/gened.tcl @@ -154,28 +154,28 @@ proc ed_start_gui { dbdict icons iconalt } { set Name $Parent.statusbar.l17 - ttk::label $Name -text "0.0" - pack $Name -anchor nw -side right -expand 0 -fill x + ttk::label $Name -text "0.0" + pack $Name -anchor nw -side right -expand 0 -fill x set Name $Parent.statusbar.l16 - ttk::label $Name -text " Row.Col: " - pack $Name -anchor nw -side right -expand 0 -fill x + ttk::label $Name -text " Row.Col: " + pack $Name -anchor nw -side right -expand 0 -fill x set Name $Parent.statusbar.l15 ttk::label $Name -text " Mode: $opmode" - pack $Name -anchor nw -side right -expand 0 -fill x + pack $Name -anchor nw -side right -expand 0 -fill x set Name $Parent.statusbar.l14 ttk::label $Name -text " File: $_ED(packagekeyname)" - pack $Name -anchor nw -side right -expand 0 -fill x + pack $Name -anchor nw -side right -expand 0 -fill x set Name $Parent.buttons - ttk::frame $Name + ttk::frame $Name pack $Name -anchor nw -side top -expand 0 -fill x -ipadx 0 -ipady 0 \ - -padx 0 -pady 0 + -padx 0 -pady 0 set Name $Parent.editbuttons - ttk::frame $Name + ttk::frame $Name construct_button $Parent.editbuttons.console edit ctext console.gif "convert_to_oratcl" "Convert Trace to Oratcl" construct_button $Parent.editbuttons.distribute edit distribute distribute.ppm "distribute" "Primary Distribution" @@ -207,9 +207,9 @@ proc ed_start_gui { dbdict icons iconalt } { construct_button $Parent.buttons.results bar results results.ppm "run_job_browser" "Browse Jobs Data" upvar #0 genericdict genericdict if {[dict exists $genericdict commandline jobs_disable ]} { - if { [ dict get $genericdict commandline jobs_disable ] eq 1 } { - .ed_mainFrame.buttons.results configure -state disabled - } + if { [ dict get $genericdict commandline jobs_disable ] eq 1 } { + .ed_mainFrame.buttons.results configure -state disabled + } } #bindtags to call to prevent highlighting of buttons when status changed bind BreakTag {break} @@ -306,7 +306,7 @@ proc ed_start_gui { dbdict icons iconalt } { } } # Turn a tab into a toplevel (must be a tk::frame) - proc Detach {notebook index} { + proc Detach {notebook index} { global tabix tabiy set tabindex [lindex [$notebook tabs] $index] set tabname [ lindex [ split [ $notebook select ] "." ] end ] @@ -319,7 +319,7 @@ proc ed_start_gui { dbdict icons iconalt } { wm title $tabindex $title wm geometry $tabindex ${tabix}x${tabiy}+30+30 wm minsize $tabindex $tabix $tabiy - #Allow dragged out transaction counter to be resized + #Allow dragged out transaction counter to be resized wm resizable $tabindex true true wm protocol $tabindex WM_DELETE_WINDOW \ [namespace code [list Attach $notebook $tabindex $index]] @@ -343,7 +343,7 @@ proc ed_start_gui { dbdict icons iconalt } { set dfx 4x } set windock [ dict get $icons windock-$dfx ] - image create photo ::img::dock -data $windock + image create photo ::img::dock -data $windock set winundock [ dict get $icons winundock-$dfx ] image create photo ::img::undock -data $winundock set tabcount [ llength [ $notebook tabs ] ] @@ -379,7 +379,7 @@ proc ed_start_gui { dbdict icons iconalt } { {active !disabled} ::img::undock] -compound right $Name add [ tk::frame $Parent.ap ] -text "Autopilot" -state disabled ttk::notebook::enableTraversal $Name - set pminunit [ expr {$mainy / 10} ] + set pminunit [ expr {$mainy / 10} ] $Parent.panedwin.subpanedwin add $Name -minsize [ expr $pminunit * 4.60 ] -stretch always $Parent.panedwin add $Parent.panedwin.subpanedwin -minsize [ expr $pminunit * 4.60 ] @@ -391,15 +391,15 @@ proc ed_start_gui { dbdict icons iconalt } { tkcon show set Name $Parent.buttons.statl15 - ttk::label $Name -text " " - pack $Name -anchor nw -side left -expand 0 -fill x + ttk::label $Name -text " " + pack $Name -anchor nw -side left -expand 0 -fill x set Name $Parent.buttons.statl15a - ttk::label $Name -text " " + ttk::label $Name -text " " pack $Name -anchor nw -side right -expand 0 -fill x set Name $Parent.buttons.statusframe - frame $Name -background [ dict get $icons defaultBackground ] -borderwidth 0 -relief flat + frame $Name -background [ dict get $icons defaultBackground ] -borderwidth 0 -relief flat pack $Name -anchor nw -side right -expand 0 -fill x set Name $Parent.buttons.statusframe.currentstatus @@ -420,8 +420,8 @@ proc populate_tree {rdbms bm icons iconalt} { set Name .ed_mainFrame.treeframe.treeview global selected lastselected treeidicons set lastselected [ .ed_mainFrame.treeframe.treeview selection ] - bind .ed_mainFrame.treeframe.treeview <> { - set selected [ .ed_mainFrame.treeframe.treeview selection ] + bind .ed_mainFrame.treeframe.treeview <> { + set selected [ .ed_mainFrame.treeframe.treeview selection ] if { [ dict exists $treeidicons $lastselected ] } { set unhighlighticon [ dict get $treeidicons $lastselected ] .ed_mainFrame.treeframe.treeview item $lastselected -image [ create_image $unhighlighticon icons ] @@ -548,12 +548,12 @@ proc populate_tree {rdbms bm icons iconalt} { $Name item $rdbms.$bm.datagen -tags {dghlp} tooltip::tooltip $Name -item $rdbms.$bm.datagen "Configure and Run Data Generation for Upload" $Name insert $rdbms.$bm.datagen end -id $rdbms.$bm.datagen.options -text "Options" -image [ create_image option icons ] - dict set treeidicons $rdbms.$bm.datagen.options option + dict set treeidicons $rdbms.$bm.datagen.options option $Name item $rdbms.$bm.datagen.options -tags dgopt tooltip::tooltip $Name -item $rdbms.$bm.datagen.options "Data Generation Options" $Name tag bind dgopt { if { ![ string match [ .ed_mainFrame.treeframe.treeview state ] "disabled focus hover" ] } { dgopts } } $Name insert $rdbms.$bm.datagen end -id $rdbms.$bm.datagen.start -text "Generate" -image [ create_image datagen icons ] - dict set treeidicons $rdbms.$bm.datagen.start datagen + dict set treeidicons $rdbms.$bm.datagen.start datagen $Name item $rdbms.$bm.datagen.start -tags dgstart tooltip::tooltip $Name -item $rdbms.$bm.datagen.start "Start Data Generation" $Name tag bind dgstart { if { ![ string match [ .ed_mainFrame.treeframe.treeview state ] "disabled focus hover" ] } { .ed_mainFrame.buttons.datagen invoke } } @@ -562,12 +562,12 @@ proc populate_tree {rdbms bm icons iconalt} { $Name item $rdbms.$bm.jobs -tags {jobhlp} tooltip::tooltip $Name -item $rdbms.$bm.jobs "Configure and Browse Job Output and Results" $Name insert $rdbms.$bm.jobs end -id $rdbms.$bm.jobs.options -text "Options" -image [ create_image option icons ] - dict set treeidicons $rdbms.$bm.jobs.options option + dict set treeidicons $rdbms.$bm.jobs.options option $Name item $rdbms.$bm.jobs.options -tags jobopt tooltip::tooltip $Name -item $rdbms.$bm.jobs.options "Job Options" $Name tag bind jobopt { if { ![ string match [ .ed_mainFrame.treeframe.treeview state ] "disabled focus hover" ] } { job_options } } $Name insert $rdbms.$bm.jobs end -id $rdbms.$bm.jobs.start -text "Browse" -image [ create_image results icons ] - dict set treeidicons $rdbms.$bm.jobs.start results + dict set treeidicons $rdbms.$bm.jobs.start results $Name item $rdbms.$bm.jobs.start -tags jobstart tooltip::tooltip $Name -item $rdbms.$bm.jobs.start "Start Job Browser" $Name tag bind jobstart { if { ![ string match [ .ed_mainFrame.treeframe.treeview state ] "disabled focus hover" ] } { .ed_mainFrame.buttons.results invoke } } @@ -587,7 +587,7 @@ proc ed_stop_gui {} { proc construct_menu {Name label cmd_list} { upvar #0 icons icons - global _ED + global _ED ttk::menubutton $Name -text $label -underline 0 -width [ string length $label ] incr _ED(menuCount); @@ -622,20 +622,20 @@ proc add_items_to_menu {menubutton cmdList} { } "radio" { set doit "$menubutton add radio -label {[lindex $cmd 1]} \ - -variable [lindex $cmd 2] -value on" + -variable [lindex $cmd 2] -value on" eval $doit } "command" { set doit "$menubutton add [lindex $cmd 0] -background [ dict get $icons defaultBackground ] -label {[lindex $cmd 1]} \ - [lindex $cmd 2]" + [lindex $cmd 2]" eval $doit } "cascade" { incr _ED(menuCount); set newmenu $menubutton.m$_ED(menuCount) set doit "$menubutton add cascade -label {[lindex $cmd 1]} \ - -menu $newmenu" - eval $doit + -menu $newmenu" + eval $doit menu $newmenu $newmenu configure -background [ dict get $icons defaultBackground ] -foreground [ dict get $icons defaultForeground ] -activebackground [ dict get $icons defaultBackground ] -activeforeground "#FF7900" -selectcolor "#FF7900" add_items_to_menu $newmenu [lindex $cmd 2] @@ -649,7 +649,7 @@ proc disable_tree { } { #In v4.0 with SVG themes, moving tree nodes left a trailing column header from the previously seleted database #This version entirely deletes all tree nodes and rebuilds the tree just to remove the trailing column header #This is not the best way to select a new database from a treeview but works around the trailing header - global rdbms bm treebuild pop_treel + global rdbms bm treebuild pop_treel upvar #0 icons icons upvar #0 iconalt iconalt set Name .ed_mainFrame.treeframe.treeview @@ -749,7 +749,7 @@ proc disable_bm_menu {} { .ed_mainFrame.menuframe.tpcc.m3 entryconfigure 2 -state disabled } #Oracle has the option to convert trace files - if {$rdbms == "Oracle"} { + if {$rdbms == "Oracle"} { .ed_mainFrame.editbuttons.console configure -state normal } else { .ed_mainFrame.editbuttons.console configure -state disabled @@ -803,8 +803,8 @@ proc construct_button_svg {Name button_type iconname file cmd helpmsg} { #edit buttons are packed along the left hand side visible when the menu button is pressed #all buttons are bound to show an alternative icon when entered and original when left global tcl_version ctext win_scale_fact - upvar #0 iconssvg iconssvg - upvar #0 iconaltsvg iconaltsvg + upvar #0 iconssvg iconssvg + upvar #0 iconaltsvg iconaltsvg set buttonscale [ expr {round(16 / 1.333333 * $win_scale_fact)} ] set im [image create photo -data [ dict get $iconssvg $iconname ] -format "svg -scaletoheight $buttonscale"] button $Name -image $im -command "$cmd" -highlightthickness 0 -borderwidth 0 -width [ expr {round($buttonscale * 2)} ] -background [ dict get $iconssvg defaultBackground ] -activebackground [ dict get $iconssvg defaultBackground ] @@ -862,7 +862,7 @@ proc ed_file_load {} { } proc ed_file_save {} { - global _ED + global _ED ed_wait_if_blocked set _ED(blockflag) 1 set _ED(package) "[.ed_mainFrame.mainwin.textFrame.left.text get 1.0 end]" @@ -894,7 +894,7 @@ proc ed_file_save {} { } proc ed_loadsave {loadflag} { - global ed_loadsave _ED + global ed_loadsave _ED if {![info exists ed_loadsave(pwd)]} { set ed_loadsave(pwd) [pwd] set ed_loadsave(filter) "*.tcl" @@ -914,13 +914,13 @@ proc ed_loadsave {loadflag} { } wm geometry .ed_loadsave +[expr \ - ([winfo screenwidth .]/2) - 173]+[expr ([winfo screenheight .]/2) - 148] + ([winfo screenwidth .]/2) - 173]+[expr ([winfo screenheight .]/2) - 148] set Parent .ed_loadsave set Name $Parent.dir - ttk::frame $Name - pack $Name -anchor nw -side top + ttk::frame $Name + pack $Name -anchor nw -side top set Name $Parent.dir.e3 ttk::entry $Name -width 35 -textvariable ed_loadsave(pwd) @@ -993,7 +993,7 @@ proc ed_loadsave {loadflag} { bind $Name {ed_loadsaveselbegin %W %y} bind $Name {ed_loadsaveselbegin %W %y} bind $Name {set _ED(packagekeyname) \ - $seld_file; ed_loadsaveselend %W %y} + $seld_file; ed_loadsaveselend %W %y} bind $Name {break} bind $Name {break} bind $Name {ed_loadsaveselend %W %y} @@ -1025,7 +1025,7 @@ proc ed_loadsave {loadflag} { set Name $Parent.buttons.ok ttk::button $Name -text OK \ -command {set _ED(packagekeyname) [.ed_loadsave.file.e11 get]; if \ - {[ed_loadsavevalentry]} {set ed_loadsave(done) 1}} + {[ed_loadsavevalentry]} {set ed_loadsave(done) 1}} pack $Name -side right -anchor nw -padx 3 -pady 3 ed_loadsavegetentries @@ -1056,7 +1056,7 @@ proc ed_loadsaveselend {win ypos} { if {-1 == [string last "/" $fil]} { set ed_loadsave(file) $fil set ed_loadsave(path) \ - [ concat $ed_loadsave(pwd)\/$ed_loadsave(file) ] + [ concat $ed_loadsave(pwd)\/$ed_loadsave(file) ] set ed_loadsave(done) 1 cd [file dirname $ed_loadsave(path) ] return "" @@ -1085,11 +1085,11 @@ proc ed_loadsavegetentries {} { if {$ed_loadsave(filter) == ""} {set ed_loadsave(filter) "*"} set files [lsort $sort_mode "[glob -nocomplain $ed_loadsave(pwd)/.*] \ - [glob -nocomplain $ed_loadsave(pwd)/*]"] + [glob -nocomplain $ed_loadsave(pwd)/*]"] .ed_loadsave.list.lb1 delete 0 end if {$e} { .ed_loadsave configure -cursor {} - update + update return } set d "./ ../" @@ -1237,9 +1237,9 @@ proc ed_edit_searchf {} { grid $Name -column 1 -row 1 global Procs set Procs($Name) { {bind .ed_edit_searchf.f1.e2 } \ - {bind .ed_edit_searchf.f1.e2 } \ - {bind .ed_edit_searchf.f1.e2 } \ - {bind .ed_ediy_searchf.f1.e2 }} + {bind .ed_edit_searchf.f1.e2 } \ + {bind .ed_edit_searchf.f1.e2 } \ + {bind .ed_ediy_searchf.f1.e2 }} bind .ed_edit_searchf.f1.e2 {tkEntryBackspace %W} bind .ed_edit_searchf.f1.e2 { if [%W selection present] { @@ -1265,8 +1265,8 @@ proc ed_edit_searchf {} { set _ED(rplc_term) [.ed_edit_searchf.f1.e2 get] .ed_mainFrame.mainwin.textFrame.left.text insert $_ED(editcursor) $_ED(rplc_term) .ed_mainFrame.mainwin.textFrame.left.text delete sel.first sel.last - raise .ed_edit_searchf - } + raise .ed_edit_searchf + } } -text {Replace} pack $Name -anchor nw -side right -padx 3 -pady 3 @@ -1277,8 +1277,8 @@ proc ed_edit_searchf {} { if {$_ED(srch_new) != $_ED(srch_old)} {set _ED(editcursor) 1.0} ed_edit_search .ed_mainFrame.mainwin.textFrame.left.text $_ED(srch_new) set _ED(srch_old) [.ed_edit_searchf.f1.e1 get] - focus .ed_mainFrame.mainwin.textFrame.left.text - raise .ed_edit_searchf + focus .ed_mainFrame.mainwin.textFrame.left.text + raise .ed_edit_searchf } -text {Search} pack $Name -anchor nw -side right -padx 3 -pady 3 @@ -1289,9 +1289,9 @@ proc ed_edit_searchf {} { raise .ed_edit_searchf update wm minsize .ed_edit_searchf [winfo width .ed_edit_searchf] \ - [winfo height .ed_edit_searchf] + [winfo height .ed_edit_searchf] wm maxsize .ed_edit_searchf [winfo width .ed_edit_searchf] \ - [winfo height .ed_edit_searchf] + [winfo height .ed_edit_searchf] } @@ -1319,7 +1319,7 @@ proc ed_edit_search {textwin srch_string} { proc ed_edit_clear {} { global _ED lprefix if {[ lindex [ split [ join [ stacktrace ] ] ] end ] eq "ed_edit_clear" } { - set lprefix "load" + set lprefix "load" } ed_wait_if_blocked set _ED(blockflag) 1 @@ -1388,7 +1388,7 @@ proc setctexthighlight {w} { set colour(brackets) gray50 set colour(comments) black set colour(strings) red - #Extract list of commands provided by each database for highlighting + #Extract list of commands provided by each database for highlighting dict for {database attributes} $dbdict { dict with attributes { lappend commandl $commands @@ -1401,13 +1401,13 @@ proc setctexthighlight {w} { ctext::addHighlightClass $w cmds $colour(cmds) [join $commandl ] ctext::addHighlightClass $w functions $colour(functions) [ list abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide ] ctext::addHighlightClassForSpecialChars $w brackets $colour(brackets) {\{\}\[\]} - ctext::addHighlightClassForRegexp $w comments $colour(comments) {\#[^\n\r]*} - ctext::addHighlightClassForRegexp $w strings $colour(strings) {"(\\"|[^"])*"} + ctext::addHighlightClassForRegexp $w comments $colour(comments) {\#[^\n\r]*} + ctext::addHighlightClassForRegexp $w strings $colour(strings) {"(\\"|[^"])*"} } proc ed_edit {} { upvar #0 icons icons - global _ED + global _ED global Menu_string global highlight global defaultBackground @@ -1429,7 +1429,7 @@ proc ed_edit {} { set Name $Parent.textFrame.right.vertScrollbar ttk::scrollbar $Name -command "$Parent.textFrame.left.text xview" \ - -orient horizontal + -orient horizontal pack $Name -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx "0 16" \ -pady 0 -side left @@ -1439,21 +1439,21 @@ proc ed_edit {} { -padx 0 -pady 0 -side top set Name $Parent.textFrame.left.horizScrollbar - ttk::scrollbar $Name -command "$Parent.textFrame.left.text yview" + ttk::scrollbar $Name -command "$Parent.textFrame.left.text yview" pack $Name -anchor center -expand 0 -fill y -ipadx 0 -ipady 0 \ -padx 0 -pady 0 -side right set Name $Parent.textFrame.left.text - if { $ttk::currentTheme eq "black" } { - set bwidth 0 + if { $ttk::currentTheme eq "black" } { + set bwidth 0 set hbgrd LightGray - } else { - set bwidth 2 + } else { + set bwidth 2 set hbgrd [ dict get $icons defaultBackground ] - } + } if { $highlight eq "true" } { ctext $Name -relief flat -background white -borderwidth $bwidth -foreground black \ - -highlight 1 \ + -highlight 1 \ -highlightbackground LightGray -insertbackground black \ -selectbackground $hbgrd -selectforeground black \ -wrap none \ @@ -1461,13 +1461,13 @@ proc ed_edit {} { -xscrollcommand "$Parent.textFrame.right.vertScrollbar set" \ -yscrollcommand "$Parent.textFrame.left.horizScrollbar set" \ -linemap 1 \ - -linemapbg $defaultBackground \ - -linemap_markable 0 + -linemapbg $defaultBackground \ + -linemap_markable 0 setctexthighlight $Name easyCtextCommenting $Name } else { ctext $Name -relief flat -background white -borderwidth $bwidth -foreground black \ - -highlight 0 \ + -highlight 0 \ -highlightbackground LightGray -insertbackground black \ -selectbackground $hbgrd -selectforeground black \ -wrap none \ @@ -1475,7 +1475,7 @@ proc ed_edit {} { -xscrollcommand "$Parent.textFrame.right.vertScrollbar set" \ -yscrollcommand "$Parent.textFrame.left.horizScrollbar set" \ -linemap 0 \ - -linemap_markable 0 + -linemap_markable 0 } $Name fastinsert end { } pack $Name -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 \ @@ -1502,7 +1502,7 @@ proc ed_edit {} { # #$Name config -image $im -command "ed_kill_apps" #bind .ed_mainFrame.editbuttons.test {ed_status_message -help \ -# "Stop running code"} +# "Stop running code"} #} proc create_image { iconname iconset } { @@ -1546,7 +1546,7 @@ proc ed_stop_transcount {} { #bindtags command sets a break to prevent highlighting of button bindtags $Name [ list Button .ed_mainFrame all BreakTag2 .ed_mainFrame.buttons.pencil ] tooltip::tooltip .ed_mainFrame.buttons.pencil "Stop Transaction Counter" - bind .ed_mainFrame.buttons.pencil {} + bind .ed_mainFrame.buttons.pencil {} } proc ed_transcount_button {} { @@ -1554,7 +1554,7 @@ proc ed_transcount_button {} { set Name .ed_mainFrame.buttons.pencil #button is pressed so show highlight set im [ create_image pencil iconalt ] - $Name config -image $im -command "transcount" + $Name config -image $im -command "transcount" #return bind order as before so highlights shown bindtags $Name [ list .ed_mainFrame.buttons.pencil Button .ed_mainFrame all ] tooltip::tooltip .ed_mainFrame.buttons.pencil "Start Transaction Counter" @@ -1614,14 +1614,14 @@ proc ed_stop_vuser {} { #bindtags command sets a break to prevent highlighting of button bindtags $Name [ list Button .ed_mainFrame all BreakTag2 .ed_mainFrame.buttons.lvuser ] tooltip::tooltip .ed_mainFrame.buttons.lvuser "Destroy Virtual Users" - bind .ed_mainFrame.buttons.lvuser {} + bind .ed_mainFrame.buttons.lvuser {} set Name .ed_mainFrame.buttons.runworld set im [ create_image rungreen icons ] $Name config -image $im -command "remote_command vurun; vurun" #bindtags command sets a break to prevent highlighting of button bindtags $Name [ list Button .ed_mainFrame all BreakTag2 .ed_mainFrame.buttons.runworld ] tooltip::tooltip .ed_mainFrame.buttons.runworld "Run Virtual Users" - bind .ed_mainFrame.buttons.runworld {} + bind .ed_mainFrame.buttons.runworld {} } proc ed_lvuser_button {} { @@ -1658,11 +1658,11 @@ proc ed_stop_autopilot {} { global _ED tcl_version set Name .ed_mainFrame.buttons.autopilot set im [ create_image stop icons ] - $Name config -image $im -command "ed_kill_autopilot" + $Name config -image $im -command "ed_kill_autopilot" #bindtags command sets a break to prevent highlighting of button bindtags $Name [ list Button .ed_mainFrame all BreakTag2 .ed_mainFrame.buttons.autopilot ] tooltip::tooltip .ed_mainFrame.buttons.autopilot "Stop Autopilot" - bind .ed_mainFrame.buttons.autopilot {} + bind .ed_mainFrame.buttons.autopilot {} } proc vurun {} { @@ -1673,7 +1673,7 @@ proc vurun {} { dict set jsondict error message "Jobid already exists or error in creating jobid in JOBMAIN table" #return } - + #In turn if script is not already loaded vucreate should call loadscript meaning following should not return no workload to run if { [ string length $_ED(package) ] > 0 } { if { [ catch {run_virtual} message ] } { @@ -1717,9 +1717,9 @@ proc ed_run_package {} { if {"$_ED(package)" == ""} { ed_status_message -alert "No code currently in run buffer." update - set maxvuser $tmp_maxvuser - set suppo $tmp_suppo - set ntimes $tmp_ntimes + set maxvuser $tmp_maxvuser + set suppo $tmp_suppo + set ntimes $tmp_ntimes .ed_mainFrame.editbuttons.test configure -state normal return } @@ -1736,7 +1736,7 @@ proc ed_run_package {} { } proc ed_kill_apps {args} { - global _ED ed_mainf + global _ED ed_mainf if {$_ED(runslave) == ""} {return} .ed_mainFrame configure -cursor watch ed_status_message -show "... closing down active GUI applications ..." @@ -1753,21 +1753,91 @@ proc ed_kill_apps {args} { } proc vuser_options {} { - global _ED maxvuser virtual_users delayms conpause ntimes suppo optlog lvuser unique_log_name no_log_buffer log_timestamps threadscreated + global _ED maxvuser virtual_users delayms conpause ntimes suppo optlog lvuser unique_log_name no_log_buffer log_timestamps threadscreated genericdict upvar #0 icons icons - if { [ info exists virtual_users ] } { ; } else { set virtual_users 1 } - if { [ info exists maxvuser ] } { ; } else { set maxvuser $virtual_users } - if { [ info exists delayms ] } { ; } else { set delayms 500 } - if { [ info exists conpause ] } { ; } else { set conpause 500 } - if { [ info exists ntimes ] } { ; } else { set ntimes 1 } - if { [ info exists suppo ] } { ; } else { set suppo 0 } - if { [ info exists optlog ] } { ; } else { set optlog 0 } - if { [ info exists unique_log_name ] } { ; } else { set unique_log_name 0 } - if { [ info exists no_log_buffer ] } { ; } else { set no_log_buffer 0 } - if { [ info exists log_timestamps ] } { ; } else { set log_timestamps 0 } + + #Try to load VU settings from generic db + set dct "virtual_user_options" + set dct_exists [ dict exists $genericdict $dct ? 1 : 0 ] + + if { [ info exists virtual_users ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct virtual_users ] } { + set virtual_users [ dict get $genericdict $dct virtual_users ] + } else { + set virtual_users 1 + } + } + + if { [ info exists maxvuser ] } { ; } else { set maxvuser $virtual_users } + + if { [ info exists delayms ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct delayms ] } { + set delayms [ dict get $genericdict $dct delayms ] + } else { + set delayms 500 + } + } + + if { [ info exists conpause ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct conpause ] } { + set conpause [ dict get $genericdict $dct conpause ] + } else { + set conpause 500 + } + } + + if { [ info exists ntimes ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct ntimes ] } { + set ntimes [ dict get $genericdict $dct ntimes ] + } else { + set ntimes 1 + } + } + + if { [ info exists suppo ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct suppo ] } { + set suppo [ dict get $genericdict $dct suppo ] + } else { + set suppo 0 + } + } + + if { [ info exists optlog ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct optlog ] } { + set optlog [ dict get $genericdict $dct optlog ] + } else { + set optlog 0 + } + } + + if { [ info exists unique_log_name ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct unique_log_name ] } { + set unique_log_name [ dict get $genericdict $dct unique_log_name ] + } else { + set unique_log_name 0 + } + } + + if { [ info exists no_log_buffer ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct no_log_buffer ] } { + set no_log_buffer [ dict get $genericdict $dct no_log_buffer ] + } else { + set no_log_buffer 0 + } + } + + if { [ info exists log_timestamps ] } { ; } else { + if { [ $dct_exists == 1 ] && [ dict exists $genericdict $dct log_timestamps ] } { + set log_timestamps [ dict get $genericdict $dct log_timestamps ] + } else { + set log_timestamps 0 + } + } + + #If window already exists then destroy catch "destroy .vuserop" - if { [ info exists threadscreated ] } { + if { [ info exists threadscreated ] } { tk_messageBox -icon error -message "Virtual Users already created, destroy Virtual Users before changing Virtual User options" return } @@ -1779,7 +1849,7 @@ proc vuser_options {} { set Parent .vuserop set Name $Parent.f1 - ttk::frame $Name + ttk::frame $Name pack $Name -anchor nw -fill x -side top -padx 5 set Prompt $Parent.f1.h1 @@ -1821,10 +1891,10 @@ proc vuser_options {} { ttk::checkbutton $Name -text "Show Output" -variable suppo -onvalue 1 -offvalue 0 grid $Name -column 1 -row 5 -sticky w - bind .vuserop.f1.e5