tclsh is a shell containing the TCL commands.
The TCL uplevel command evaluates the given TCL script, but it fails to evaluate a tclsh script (which can contain bash commands).
How can I obtain an analogue of uplevel for the tclsh script?
Consider this TCL script:
# file main.tcl
proc prompt { } \
{
puts -nonewline stdout "MyShell > "
flush stdout
}
proc process { } \
{
catch { uplevel #0 [gets stdin] } got
if { $got ne "" } {
puts stderr $got
flush stderr
}
prompt
}
fileevent stdin readable process
prompt
while { true } { update; after 100 }
This is a kind of TCL shell, so when you type tclsh main.tcl it shows a prompt MyShell > and it acts like you are in interactive tclsh session. However, you are in non-interactive tclsh session, and everything you type is evaluated by the uplevel command. So here you can't use bash commands like you can do it int interactive tclsh session. E.g. you can't open vim right from the shell, also exec vim will not work.
What I want is to make MyShell > act like interactive tclsh session. The reason why I can't just use tclsh is the loop at the last line of main.tcl: I have to have that loop and everything has to happen in that loop. I also have to do some stuff at each iteration of that loop, so can use vwait.
Here is the solution.
I have found no better solution then to overwrite the ::unknown function.
# file main.tcl
proc ::unknown { args } \
{
variable ::tcl::UnknownPending
global auto_noexec auto_noload env tcl_interactive
global myshell_evaluation
if { [info exists myshell_evaluation] && $myshell_evaluation } {
set level #0
} else {
set level 1
}
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
#return -code error "You need an {*}"
set arglist [lrange $args 1 end]
set ret [catch {uplevel $level ::$cmd $arglist} result opts]
dict unset opts -errorinfo
dict incr opts -level
return -options $opts $result
}
catch {set savedErrorInfo $::errorInfo}
catch {set savedErrorCode $::errorCode}
set name $cmd
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
if {[info exists UnknownPending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set UnknownPending($name) pending;
set ret [catch {
auto_load $name [uplevel $level {::namespace current}]
} msg opts]
unset UnknownPending($name);
if {$ret != 0} {
dict append opts -errorinfo "\n (autoloading \"$name\")"
return -options $opts $msg
}
if {![array size UnknownPending]} {
unset UnknownPending
}
if {$msg} {
if {[info exists savedErrorCode]} {
set ::errorCode $savedErrorCode
} else {
unset -nocomplain ::errorCode
}
if {[info exists savedErrorInfo]} {
set ::errorInfo $savedErrorInfo
} else {
unset -nocomplain ::errorInfo
}
set code [catch {uplevel $level $args} msg opts]
if {$code == 1} {
#
# Compute stack trace contribution from the [uplevel].
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
set errorInfo [dict get $opts -errorinfo]
set errorCode [dict get $opts -errorcode]
set cinfo $args
if {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 150]
while {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 end-1]
}
append cinfo ...
}
append cinfo "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel $level \$args\""
#
# Try each possible form of the stack trace
# and trim the extra contribution from the matching case
#
set expect "$msg\n while executing\n\"$cinfo"
if {$errorInfo eq $expect} {
#
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
#
dict unset opts -errorinfo
dict incr opts -level
return -options $opts $msg
}
#
# Stack trace is nested, trim off just the contribution
# from the extra "eval" of $args due to the "catch" above.
#
set expect "\n invoked from within\n\"$cinfo"
set exlen [string length $expect]
set eilen [string length $errorInfo]
set i [expr {$eilen - $exlen - 1}]
set einfo [string range $errorInfo 0 $i]
#
# For now verify that $errorInfo consists of what we are about
# to return plus what we expected to trim off.
#
if {$errorInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
}
return -code error -errorcode $errorCode -errorinfo $einfo $msg
} else {
dict incr opts -level
return -options $opts $msg
}
}
}
if { ( [info exists myshell_evaluation] && $myshell_evaluation ) || (([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive) } {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new ne ""} {
set redir ""
if {[namespace which -command console] eq ""} {
set redir ">&#stdout <#stdin"
}
uplevel $level [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
}
if {$name eq "!!"} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name -> event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
uplevel $level [list ::catch $newcmd ::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
set ret [catch {set candidates [info commands $name*]} msg]
if {$name eq "::"} {
set name ""
}
if {$ret != 0} {
dict append opts -errorinfo "\n (expanding command prefix \"$name\" in unknown)"
return -options $opts $msg
}
# Filter out bogus matches when $name contained
# a glob-special char [Bug 946952]
if {$name eq ""} {
# Handle empty $name separately due to strangeness
# in [string first] (See RFE 1243354)
set cmds $candidates
} else {
set cmds [list]
foreach x $candidates {
if {[string first $name $x] == 0} {
lappend cmds $x
}
}
}
if {[llength $cmds] == 1} {
uplevel $level [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
if {[llength $cmds]} {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
}
}
return -code error "invalid command name \"$name\""
}
proc prompt { } \
{
puts -nonewline stdout "MyShell > "
flush stdout
}
proc process { } \
{
global myshell_evaluation
set myshell_evaluation true
catch { uplevel #0 [gets stdin] } got
set myshell_evaluation false
if { $got ne "" } {
puts stderr $got
flush stderr
}
prompt
}
fileevent stdin readable process
prompt
while { true } { update; after 100 }
The idea is to modify the ::unknown function so that it handles MyShell evaluations as the ones of tclsh interactive session.
This is an ugly solution, as I am fixing the code of ::unknown function which can be different for different systems and diferent versions of tcl.
Is there any solution which circumvents these issues?
uplevel does not only evaluate a script, but it evaluates it in the stack context of the caller of the instance where it's executed. It's a pretty advanced command which should be used when you define your own execution control structures, and OFC it's TCL specific - I find myself unable to imagine how a tclsh equivalent should work.
If you just want to evaluate another script, the proper TCL command would be eval. If that other script is tclsh, why don't you just open another tclsh?
The simplest answer, I think, would be to use the approach you're using; to rewrite the unknown command. Specifically, there is a line in it that checks to make sure the current context is
Not run in a script
Interactive
At the top level
If you replace that line:
if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} {
with something that just checks the level
if ([info level] == 1} {
you should get what you want.
Vaghan, you do have the right solution. Using ::unknown is how tclsh itself provides the interactive-shell-functionality you're talking about (invoking external binaries, etc). And you've lifted that same code and included it in your MyShell.
But, if I understand your concerns about it being an "ugly solution", you'd rather not reset ::unknown ?
In which case, why not just append the additional functionality you want to the end of the pre-existing ::unknown's body (or prepend it - you choose)
If you search on the Tcl'ers wiki for "let unknown know", you'd see a simple proc which demonstrates this. It prepends new code to the existing ::unknown, so you can keep adding additional "fallback code" as you go along.
(apologies if I've misunderstood why you feel your solution is "ugly")
Instead of changing the unknown proc, I suggest that you make the changes to evaluate the expresion
if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} {
to true.
info level: call your stuff with uplevel #0 $code
info script: call info script {} to set it to an empty value
tcl_interactive. Simple: set ::tcl_interactive 1
so your code would be
proc prompt { } {
puts -nonewline stdout "MyShell > "
flush stdout
}
proc process { } {
catch { uplevel #0 [gets stdin] } got
if { $got ne "" } {
puts stderr $got
flush stderr
}
prompt
}
fileevent stdin readable process
set tcl_interactive 1
info script {}
prompt
vwait forever
Related
I am currently encountering a problem.
When I want to download a file on a mikrotik in 6.48.6 using mtlogin and fetch tool, it works perfectly and the script waits until the router has finished downloading to send a "quit".
However, when trying the same manipulation on a router in version 7.1.5, the "quit" is sent directly, thus stopping the download because of the letter Q and thus sending "uit" thereafter in the prompt.
The prompts are similar for 6.48.6 and 7.1.5, and even when trying to add expects in the script, the result is the same.
I think the problem is in this part of the code, but don't know how to fix it.
# Run commands given on the command line.
proc run_commands { prompt command } {
global do_interact in_proc
set in_proc 1
# escape any parens in the prompt, such as "(enable)"
regsub -all "\[)(]" $prompt {\\&} reprompt
# handle escaped ;s in commands, and ;; and ^;
regsub -all {([^\\]);} $command "\\1\u0002;" esccommand
regsub -all {([^\\]);;} $esccommand "\\1;\u0002;" command
regsub {^;} $command "\u0002;" esccommand
regsub -all {[\\];} $esccommand ";" command
regsub -all {\u0002;} $command "\u0002" esccommand
set sep "\u0002"
set commands [split $esccommand $sep]
set num_commands [llength $commands]
for {set i 0} {$i < $num_commands} { incr i} {
send -- "[subst -nocommands [lindex $commands $i]]\r"
if { [lindex $commands $i] == "/system/reboot"} {
send "y\r"
}
expect {
-re "^\[^\n\r]*$reprompt" {}
-re "^\[^\n\r ]*>>.*$reprompt" { exp_continue }
-re "\[\n\r]+" { exp_continue }
}
}
if { $do_interact == 1 } {
interact
return 0
}
send "quit\r"
expect {
-re "^WARNING: There are unsaved configuration changes." {
send "y\r"
exp_continue
}
"\n" { exp_continue }
"\[^\n\r *]*Session terminated" { return 0 }
timeout { catch {close}; catch {wait};
return 0
}
eof { return 0 }
}
set in_proc 0
}
That's how it looks like
Does anyone have a solution?
I just find the solution in mtlogin at line 625!
foreach router [lrange $argv $i end] {
set router [string tolower $router]
send_user "$router\n"
# Figure out prompt.
set prompt "] > " #Just added a second whitespace after >
# alteon only "enables" based on the password used at login time
set autoenable 1
set enable 0
Hope it's gonna help you
Using TCL, I am trying to use the "try" command in TCL as a background process and return the error codes. However, using the ampersand (&) always returns the error code as 0 indicating a successful run.
try {
exec cmd /c test.exe &
set returnvalue 0
} on ok {output} {
puts "Command successful"
} trap {CHILDSTATUS} {output options} {
set result [lindex [dict get $options -errorcode] end]
if {$result == 3} {
puts "Argument undefined"
} elseif {$result == 4} {
puts "Login Failed"
} elseif {$result == 1} {
puts "Process Cancelled by user"
}
}
How can I instruct the interpreter to execute test.exe in the background and yet return the appropriate error codes?
My intention is to run test.exe and another program in parallel, and yet read the error codes from test.exe run and post-process based on the error codes.
Any expert advices?
To run processes in the background and get their exit code, you have to switch to using open "|cmd /c ... &" and fileevents. Then catch the close command (in blocking mode) for the end result:
# Helper proc to run commands in the background
proc bgexec {args} {
set fd [open "|$args &"]
fconfigure $fd -blocking 0
fileevent $fd readable [list bgevent $fd [join $args]]
}
# Helper proc to handle file events
proc bgevent {fd cmd} {
# Discard any output
read $fd
if {[eof $fd]} {
fconfigure $fd -blocking 1
try {
close $fd
} on ok {output} {
puts "$cmd: Command successful"
} trap {CHILDSTATUS} {output options} {
set result [lindex [dict get $options -errorcode] end]
if {$result == 3} {
puts "$cmd: Argument undefined"
} elseif {$result == 4} {
puts "$cmd: Login Failed"
} elseif {$result == 1} {
puts "$cmd: Process Cancelled by user"
}
}
}
}
bgexec cmd /c test.exe
bgexec cmd /c test.exe arg1
vwait forever
I need to create a file with all hashicorp vault key value pairs data using shell script.
I want to dump all the data from vault to a flat file.
please advice best way to do it.
Thanks in advance
Prudhvi
Just for keys and values you can use my little Perl script 'vault-backup', that also freezes the data using the correct vault commands.
Please note that this does NOT create a full backup of your Vault! There are no methods being backed up, or any other (unlistable) stuff outside the secrets. It's only usable for simple keys and values. It also probably isn't usable for multiline or binary values. You can patch the script to support that, if you like. ;)
#!/usr/bin/perl
#
# Usage: vault-backup [<PATH> [stdout]]
use Data::Dumper;
use Storable qw(freeze thaw);
# Set vault environment variables
# Always end with a " && " for the actual command
my $setenv =
"VAULT_ADDR=https://myvault.somewhere.com:8200 && ".
"VAULT_CA_PATH=/etc/yourcertificates/ && ";
my $path = $ARGV[0] || "secret/";
if ($path!~/\/$/) {
$path="$path/";
}
push #list, getData($path);
if ($ARGV[1] eq "stdout") {
print Dumper(\#list);
} else {
my $fn="vault-backup-frozen-".time().".dat";
open W,">$fn";
print W freeze(\#list);
close W;
print STDERR "Wrote data to $fn\n";
}
sub getData {
my $path=shift;
print STDERR "Starting getData($path)\n";
my #ret=();
my $command="$setenv vault kv list -tls-skip-verify $path | tail -n+3 ";
print STDERR "starting command: $command\n";
my #lines = `$command`;
chomp #lines;
foreach my $line (#lines) {
if ($line=~/\/$/) {
my #result = getData($path.$line);
if (scalar(#result)>0) {
# Find deeper results
push #ret, #result;
} else {
# empty final dir, no values
push #ret, { path => $path.$line };
}
} else {
# Found a key!
my $command="$setenv vault kv get -tls-skip-verify $path$line";
print STDERR "starting command: $command\n";
my $values = `$command`;
push #ret, {path=>$path.$line, value=>$values};
}
}
return #ret;
}
To restore the data, you can use the script below. It handles data only, it does not act on metadata.
#!/usr/bin/perl
# Usage: vault-restore <backup-filename>
use Data::Dumper;
use Storable qw(thaw);
my %all_entries;
# Set vault environment variables
# Always end with a " && " for the actual command
my $setenv =
"VAULT_ADDR=https://myothervault.somewhere.com:8200 && ".
"VAULT_CA_PATH=/etc/mycertificates/ && ";
# Read the data
my $fn = $ARGV[0] || die("I need a filename with the frozen data");
open F,"<$fn";
my #list = #{ thaw(join("",<F>)) };
close F;
print STDERR "Read ".scalar(#list)." entries.\n";
# Process the data
foreach my $entry (#list) {
print STDERR "\n# adding entry -> $entry->{path}\n";
addEntry($entry);
}
foreach my $path (keys %all_entries) {
my $keyvalues="";
foreach my $key (keys %{$all_entries{$path}}) {
my $value=$all_entries{$path}{$key};
$keyvalues.="'$key=$value' ";
}
print STDERR "vault kv put $path $keyvalues\n";
# `$command`;
}
sub addEntry {
my $entry=shift;
my $path = $entry->{'path'};
if ($entry->{'value'}) {
my $values = $entry->{value};
my #list=split("\n", $values);
my $metadata_engage=0;
my $data_engage=0;
foreach my $keyvalue (#list) {
if ($keyvalue=~/==== Metadata ====/) {
$metadata_engage=1;
$data_engage=0;
} elsif ($keyvalue=~/==== Data ====/) {
$metadata_engage=0;
$data_engage=1;
} elsif ($data_engage) {
my ($key,$value)=($keyvalue=~/^([^ ]+) +(.*)$/);
if ($key ne "Key" && $key ne "---") {
# print STDERR "key=$key ; value=$value\n";
$all_entries{$path}{$key}=$value;
} else {
# print STDERR "-- separator\n";
}
}
}
} else {
print STDERR "Found a final but empty path: $path\n";
}
}
Does anyone know a standard package for tcl to easily parse the input arguments ? or a ready proc ? ( I have only 3 flags but something general is preferable ).
The documentation includes an example. Here is a simple example:
package require cmdline
set parameters {
{server.arg "" "Which server to search"}
{debug "Turn on debugging, default=off"}
}
set usage "- A simple script to demo cmdline parsing"
array set options [cmdline::getoptions ::argv $parameters $usage]
parray options
Sample runs:
$ tclsh simple.tcl
options(debug) = 0
options(server) =
$ tclsh simple.tcl -server google.com
options(debug) = 0
options(server) = google.com
$ tclsh simple.tcl -server google.com -debug
options(debug) = 1
options(server) = google.com
$ tclsh simple.tcl -help
simple - A simple script to demo cmdline parsing
-server value Which server to search <>
-debug Turn on debugging, default=off
-help Print this message
-? Print this message
while executing
"error [usage $optlist $usage]"
(procedure "cmdline::getoptions" line 15)
invoked from within
"cmdline::getoptions ::argv $parameters $usage"
invoked from within
"array set options [cmdline::getoptions ::argv $parameters $usage]"
(file "simple.tcl" line 11)
Discussion
Unlike most Linux utilities, TCL uses single dash instead of double dashes for command-line options
When a flags ends with .arg, then that flag expects an argument to follow, such as in the case of server.arg
The debug flag does not end with .arg, therefore it does not expect any argument
The user defines the command-line parameters by a list of lists. Each sub-list contains 2 or 3 parts:
The flag (e.g. debug)
The default value (e.g. 0), only if the parameter takes an argument (flag ends with .arg).
And the help message
Invoke usage/help with -help or -?, however, the output is not pretty, see the last sample run.
Update: Help/Usage
I have been thinking about the message output when the user invoke help (see the last sample run above). To get around that, you need to trap the error yourself:
set usage "- A simple script to demo cmdline parsing"
if {[catch {array set options [cmdline::getoptions ::argv $parameters $usage]}]} {
puts [cmdline::usage $parameters $usage]
} else {
parray options
}
Sample run 2:
$ tclsh simple.tcl -?
simple - A simple script to demo cmdline parsing
-server value Which server to search <>
-debug Turn on debugging, default=off
-help Print this message
-? Print this message
Tcllib has such a package, cmdline. It's a bit underdocumented, but it works.
Here is a simple, native, no-package argument parser:
#
# arg_parse simple argument parser
# Example `arg_parse {help version} {with-value} {-with-value 123 positional arguments}`
# will return:
# `positionals {positional arguments} with-value 123`
#
# #param boolean_flags flags which does not requires additional arguments (like help)
# #param argument_flags flags which requires values (-with-value value)
# #param args the got command line arguments
#
# #return stringified array of parsed arguments
#
proc arg_parse { boolean_flags argument_flags args } {
set argsarr(positionals) {}
for {set i 0} {$i < [llength $args]} {incr i} {
set arg [lindex $args $i]
if { [sstartswith $arg "-" ] } {
set flag [string range $arg 1 end]
if { [lsearch $boolean_flags $flag] >= 0 } {
set argsarr($flag) 1
} elseif { [lsearch $argument_flags $flag] >= 0 } {
incr i
set argsarr($flag) [lindex $args $i]
} else {
puts "ERROR: Unknown flag argument: $arg"
return
}
} else {
lappend argsarr(positionals) $arg
}
}
return [array get argsarr]
}
USE argument parser
#
# USE argument parser:
#
proc my_awesome_proc { args } {
array set argsarr [arg_parse "help version" "with-value" {*}$args]
parray argsarr
}
USE my_awesome_proc :
% my_awesome_proc -help
argsarr(help) = 1
argsarr(positionals) =
% my_awesome_proc -with-value 123
argsarr(positionals) =
argsarr(with-value) = 123
% my_awesome_proc -wrong
ERROR: Unknown flag argument: -wrong
% my_awesome_proc positional arguments
argsarr(positionals) = positional arguments
%
I need to test how my remote server is handling ping request. I need to ping remote server from my windows with payload of say 50 kb. I need my tcl script sholud generate 20 such ping requests with 50 kb payload parallel so it will result 1 mb receive traffic at server at given instance. here is the code for ping test
proc ping-igp {} {
foreach i {
172.35.122.18
} {
if {[catch {exec ping $i -n 1 -l 10000} result]} {
set result 0
}
if {[regexp "Reply from $i" $result]} {
puts "$i pinged"
} else {
puts "$i Failed"
}
}
}
If you want to ping in parallel then you can use open instead of exec and use fileevents to read from the ping process.
An example of using open to ping a server with two parallel processes:
set server 172.35.122.18
proc pingResult {chan serv i} {
set reply [read $chan]
if {[eof $chan]} {
close $chan
}
if {[regexp "Reply from $serv" $result]} {
puts "$serv number $i pinged"
} else {
puts "$serv number $i Failed"
}
}
for {set x 0} {$x < 2} {incr $x} {
set chan [open "|ping $server -n 1 -l 10000"]
fileevent $chan readable "pingResult $chan {$server} $x"
}
See this page for more info: http://www.tcl.tk/man/tcl/tutorial/Tcl26.html
Here's a very simple piece of code to do the pinging in the background by opening a pipeline. To do that, make the first character of the “filename” to open be a |, when the rest of the “filename” is interpreted as a Tcl list of command line arguments, just as in exec:
proc doPing {host} {
# These are the right sort of arguments to ping for OSX.
set f [open "|ping -c 1 -t 5 $host"]
fconfigure $f -blocking 0
fileevent $f readable "doRead $host $f"
}
proc doRead {host f} {
global replies
if {[gets $f line] >= 0} {
if {[regexp "Reply from $host" $result]} {
# Switch to drain mode so this pipe will get cleaned up
fileevent $f readable "doDrain $f"
lappend replies($host) 1
incr replies(*)
}
} elseif {[eof $f]} {
# Pipe closed, search term not present
lappend replies($host) 0
incr replies(*)
close $f
}
}
# Just reads and forgets lines until EOF
proc doDrain {f} {
gets $f
if {[eof $f]} {close $f}
}
You'll also need to run the event loop; this might be trivial (you're using Tk) or might need to be explicit (vwait) but can't be integrated into the above. But you can use a clever trick to run the event loop for long enough to collect all the results:
set hosts 172.35.122.18
set replies(*)
foreach host $hosts {
for {set i 0} {$i < 20} {incr i} {
doPing $host
incr expectedCount
}
}
while {$replies(*) < $expectedCount} {
vwait replies(*)
}
Then, just look at the contents of the replies array to get a summary of what happened.