I am taking arguments from command line and passing all those arguments to another program (with expect spawn). I want to parse all options and omit some of them (or do something else). To do that I am doing this:
set arguments [lrange $argv 0 end]
#Check for -lp option. Set the program path
for {set var 0} {$var<$argc} {incr var} {
if {[lindex $arguments $var] == "-lp" || [lindex $arguments $var] == "--launcher-path"} {
if {[lindex $arguments [expr {$var+1}]] != ""} {
set program [lindex $arguments [expr {$var+1}]]
#unset [lindex $arguments $var]
} else {
puts "E: Argument missing for option: [lindex $arguments $var]"
exit 1
}
}
}
But I can't figure out how to unset those args that I used. For example, I need to unset [lindex $arguments [expr {$var+1}]] and [lindex $arguments $var].
This is how I am running the $program:
if {[catch {spawn $program --text {*}$arguments}]} {
puts "E: Launcher not found: $program"
exit 1
}
If your arguments are all key-value, then you can iterate over the arguments in pairs with foreach and build up a new list containing just the arguments you're interested in.
set newarguments [list]
foreach {arg value} $arguments {
switch -exact -- $arg {
"-lp" -
"--launcher-path" {
set program $value
}
default {
lappend newarguments $arg $value
}
}
}
If you have mixed flag and key-value options, then you will need to iterate using an index, similar to your code, but building up the new list of arguments will be roughly the same.
You could also check into the tcllib cmdline package, although that does not handle long options.
This is how I have done it:
set arguments [lreplace $arguments [expr {$var+1}] [expr {$var+1}]]
set arguments [lreplace $arguments $var $var]
As glenn-jackman pointed out, the above can be shortened to:
set arguments [lreplace $arguments $var [expr {$var+1}]]
Related
I have a report file having multiple lines in this form:
str1 num1 num2 ... numN str2
Given that (N) is not the same across lines. These numbers represent coordinates, so I need to enclose each point with curly braces to be:
{num1 num2} {num3 num4} and so on...
I have tried this piece of code:
set file_r [open file.rpt r]
set lines [split [read $file_r] "\n"]
close $file_r
foreach line $lines {
set items [split $line]
set str1 [lindex $items 0]
set str2 [lindex $items [expr [llength $items] - 1]]
set box [lrange $items 1 [expr [llength $items] - 2]]
foreach coord $box {
set index [lsearch $box $coord]
set index_rem [expr $index % 2]
if {index_rem == 0} {
set box [lreplace $box $index $index "{$coord"]
} else {
set box [lreplace $box $index $index "$coord}"]
}
}
puts "box: $box"
}
This gives me a syntax error that a close-brace is missing. And if I try "\{$coord" the back-slash character gets typed in the $box.
Any ideas to overcome this?
There are a few things you could improve to have better and simpler Tcl style.
You usually don't need to use split to form a list from a line if the line is already space separated. Space separated strings can almost always be used directly in list commands.
The exceptions are when the string contains { or " characters.
lindex and lrange can take end and end-N arguments.
This plus Donal's comment to use lmap will result in this:
set file_r [open file.rpt r]
set lines [split [read $file_r] "\n"]
close $file_r
foreach line $lines {
set str1 [lindex $line 0]
set str2 [lindex $line end]
set numbers [lrange $line 1 end-1]
set boxes [lmap {a b} $numbers {list $a $b}]
foreach box $boxes {
puts "box: {$box}"
}
}
Im searching all over the internet , i guess im searching not the right keywords
i tried most of them :)
i want to create in tcl/bash a proc with hyphen flags to get arguments with flags from the user
ex.
proc_name -color red -somethingselse black
It's very easy to do, actually. This code allows abbreviated option names, flag options (-quxwoo in the example) and the ability to stop reading options either with a -- token or with a non-option argument appearing. In the example, unknown option names raise errors. After passing the option-parsing loop, args contains the remaining command-line arguments (not including the -- token if it was used).
proc foo args {
array set options {-bargle {} -bazout vampires -quxwoo 0}
while {[llength $args]} {
switch -glob -- [lindex $args 0] {
-bar* {set args [lassign $args - options(-bargle)]}
-baz* {set args [lassign $args - options(-bazout)]}
-qux* {set options(-quxwoo) 1 ; set args [lrange $args 1 end]}
-- {set args [lrange $args 1 end] ; break}
-* {error "unknown option [lindex $args 0]"}
default break
}
}
puts "options: [array get options]"
puts "other args: $args"
}
foo -barg 94 -quxwoo -- abc def
# => options: -quxwoo 1 -bazout vampires -bargle 94
# => other args: abc def
This is how it works. First set default values for the options:
array set options {-bargle {} -bazout vampires -quxwoo 0}
Then enter a loop that processes the arguments, if there are any (left).
while {[llength $args]} {
During each iteration, look at the first element in the argument list:
switch -glob -- [lindex $args 0] {
String-match ("glob") matching is used to make it possible to have abbreviated option names.
If a value option is found, use lassign to copy the value to the corresponding member of the options array and to remove the first two elements in the argument list.
-bar* {set args [lassign $args - options(-bargle)]}
If a flag option is found, set the corresponding member of the options array to 1 and remove the first element in the argument list.
-qux* {set options(-quxwoo) 1 ; set args [lrange $args 1 end]}
If the special -- token is found, remove it from the argument list and exit the option-processing loop.
-- {set args [lrange $args 1 end] ; break}
If an option name is found that hasn't already been dealt with, raise an error.
-* {error "unknown option [lindex $args 0]"}
If the first argument doesn't match any of the above, we seem to have run out of option arguments: just exit the loop.
default break
Documentation: array, break, error, lassign, lindex, llength, proc, puts, set, switch, while
With array set, we can assign the parameters and their values into an array.
proc getInfo {args} {
# Assigning key-value pair into array
# If odd number of arguments passed, then it should throw error
if {[catch {array set aInfo $args} msg]} {
return $msg
}
parray aInfo; # Just printing for your info
}
puts [getInfo -name Dinesh -age 25 -id 974155]
will produce the following output
aInfo(-age) = 25
aInfo(-id) = 974155
aInfo(-name) = Dinesh
The usual way to handle this in Tcl is by slurping the values into an array or dictionary and then picking them out of that. It doesn't offer the greatest amount of error checking, but it's so easy to get working.
proc myExample args {
# Set the defaults
array set options {-foo 0 -bar "xyz"}
# Read in the arguments
array set options $args
# Use them
puts "the foo option is $options(-foo) and the bar option is $options(-bar)"
}
myExample -bar abc -foo [expr {1+2+3}]
# the foo option is 6 and the bar option is abc
Doing error checking takes more effort. Here's a simple version
proc myExample args {
array set options {-foo 0 -bar "xyz"}
if {[llength $args] & 1} {
return -code error "must have even number of arguments in opt/val pairs"
}
foreach {opt val} $args {
if {![info exist options($opt)]} {
return -code error "unknown option \"$opt\""
}
set options($opt) $val
}
# As before...
puts "the foo option is $options(-foo) and the bar option is $options(-bar)"
}
myExample -bar abc -foo [expr {1+2+3}]
# the foo option is 6 and the bar option is abc
# And here are the errors it spits out...
myExample -spregr sgkjfd
# unknown option "-spregr"
myExample -foo
# must have even number of arguments in opt/val pairs
#flag defaults
set level 1
set inst ""
# Parse Flags
while {[llength $args]} {
set flag [lindex $args 0]
#puts "flag: ($flag)"
switch -glob $flag {
-level {
set level [lindex $args 1]
set args [lrange $args 2 end]
puts "level:($level) args($args)"
} -inst {
set autoname 0
set inst [lindex $args 1]
set args [lrange $args 2 end]
puts "inst:($inst) args($args)"
} -h* {
#help
puts "USAGE:"
exit 1
} -* {
# unknown option
error "unknown option [lindex $args 0]"
} default break
}
}
# remaining arguments
set filename "$args"
puts "filename: $args"
I found a wiki page about how to calculate the depth of a list:
http://wiki.tcl.tk/11602
How can I rewrite the above code as a single proc using tcl 8.6 features lmap and apply? Perhaps "apply" is not really needed.
proc max list {
set res [lindex $list 0]
foreach e [lrange $list 1 end] {if {$e>$res} {set res $e}}
set res
}
# llmap perhaps can be replaced with lmap from Tcl 8.6
proc llmap {func list} {
set res {}
foreach e $list {lappend res [$func $e]}
set res
}
proc ldepth list {
expr {
[llength $list] == 0? 1:
[expr {[lindex $list 0] eq $list}]? 0:
1+[max [llmap ldepth $list]]
}
}
The first level of adaptation already gets us close to where you want to go, sufficiently so that this is what I'd consider as a production solution:
proc ldepth {list} {
expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
1 + [tcl::mathfunc::max {*}[lmap e $list {
ldepth $e
}]]
}
}
This uses the standard lmap and tcl::mathfunc::max (which is the implementation of the max() function). Note that expansion and tcl::mathfunc::max are features of Tcl 8.5, but they're very useful here.
Eliminating expansion
Let's see if we can get rid of that call to tcl::mathfunc::max with the expansion.
proc ldepth {list} {
set m -inf
expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
1 + [lindex [lmap e $list {
set m [expr { max($m, [ldepth $e]) }]
}] end]
}
}
Hmm, that's just a touch ugly. We might as well do this:
proc ldepth {list} {
set m -inf
expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
[foreach e $list {
set m [expr { max($m,[ldepth $e]) }]
}
expr {$m + 1}]
}
}
This definitely isn't getting better, except in that it doesn't keep so much state around (just a running maximum, not a list of depths). Let's go back to the version with lmap!
(What is really needed for true beauty is lfold, but that didn't get done on the grounds that sometimes you've just got to stop adding features and call a release.)
“Eliminating” recursion
The other way we can go is to see about removing the outer recursion. We can't completely eliminate the recursion altogether — we're dealing with a recursive operation over a recursive structure — but we don't need to put it in the outer level where a rename ldepth fred will cause problems. We do this by using apply to create an internal procedure-like thing, and since we're doing recursive calls, we pass the lambda term into itself. (There are tricks you can do to get that value without explicitly passing it in, but they're ugly and we might as well be honest here.)
proc ldepth {list} {
set ldepth {{ldepth list} {expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
1 + [tcl::mathfunc::max {*}[lmap e $list {
apply $ldepth $ldepth $e
}]]
}}
apply $ldepth $ldepth $list
}
Full-bytecode version
Subject to still doing a recursive call.
proc ldepth {list} {
expr {
[llength $list] == 0 ? [return 1] :
[lindex $list 0] eq $list ? [return 0] :
[set m -inf
foreach e $list {
set m [expr {[set d [ldepth $e]]+1>$m ? $d+1 : $m}]
}
return $m]
}
}
Fully recursion-free by using a work queue instead. This is 8.5 code — no 8.6 features required — and you could write this to be 8.4-suitable by replacing the lassigns:
proc ldepth {list} {
set work [list $list 0]
set maxdepth 0
while {[llength $work]} {
### 8.4 version
# foreach {list depth} $work break
# set work [lrange $work 2 end]
set work [lassign $work[unset -nocomplain work] list depth]
if {[llength $list] == 0} {
incr depth
} elseif {[lindex $list 0] ne $list} {
incr depth
foreach e $list {
lappend work $e $depth
}
continue
}
set maxdepth [expr {$maxdepth<$depth ? $depth : $maxdepth}]
}
return $maxdepth
}
The moral of the story? The 8.6 features don't make sense for everything.
Here's a simple one that works.
It just flattens the list until it can't be flattened any further. The number of attempts is the depth. No recursion needed.
proc ldepth {lst} {
set depth 1
set fatter $lst
set flatter [join $fatter]
while {$flatter ne $fatter} {
set fatter $flatter
set flatter [join $fatter]
incr depth
}
return depth
}
Hope this helps!
I'm looking for some Tcl code that would duplicate what puts command sends to stdout to some log file. Yes, there is a possibility to change all calls to puts to some custom function. But I would like to make it as transparent as possible.
I have this trial code, but it doesn't really work that well:
set pass_log_output "0"
rename puts _puts
proc puts { args } {
global pass_log_output
if {[info exists pass_log_output]} {
# There can be several cases:
# -nonewline parameter, stdout specified or not
set stdout_dest [ lsearch $args stdout ]
set nonewline [ lsearch $args -nonewline ]
if { $stdout_dest != -1 } {
log_low_level "" [lindex $args [expr $stdout_dest + 1]] ""
} elseif { $nonewline != -1 && [ llength $args ] > 1} {
log_low_level "" [lindex $args [expr $nonewline + 1]] ""
} else {
log_low_level "" [lindex $args 0] ""
}
}
if { [ catch { eval _puts $args } err ] } {
return -code error $err
}
}
log_low_level function just stores the passed string in a file.
So far I'm getting this error:
Tcl Interpreter Error: too many nested evaluations (infinite loop?)
Does log_low_level use puts? That could be your infinite loop.
If so, try changing it to use _puts.
Thanks for the points. I just want to post the final working code for reference. It even takes care of the storing lines with -nonewline flag properly.
set pass_log_output "0"
set last_call_nonewline 0
rename puts _orig_puts
proc puts { args } {
global pass_log_output
global g_log_file
global last_call_nonewline
if {[info exists pass_log_output]} {
# Check if the logging was initialized
if {![info exists g_log_file]} {
_orig_puts "Log file wasn't initialized!"
return
}
# There can be several cases:
# -nonewline parameter, stdout specified or not
set stdout_dest [ lsearch $args stdout ]
set nonewline [ lsearch $args -nonewline ]
if {[ llength $args ] > 3} {
return -code error "wrong # args: should be puts ?-nonewline? ?channelId? string"
} elseif { $stdout_dest != -1 } {
set message [lindex $args end]
} elseif { $nonewline != -1 && [ llength $args ] == 2} {
set message [lindex $args [expr $nonewline + 1]]
} elseif {[ llength $args ] == 1} {
set message [lindex $args 0]
}
# Store the message in the file, if needed.
# Take into account if the last call was with -nonewline
if {[info exists message]} {
if {$last_call_nonewline == 0} {
_orig_puts -nonewline $g_log_file [clock format [clock seconds] -format "%T - "]
}
if {$nonewline != -1} {
set last_call_nonewline 1
_orig_puts -nonewline $g_log_file "$message"
} else {
set last_call_nonewline 0
_orig_puts $g_log_file "$message"
}
flush $g_log_file
}
}
if { [ catch { eval _orig_puts $args } err ] } {
return -code error $err
}
}
Since puts has very few options, it may be easier to consider the number of args given. Also, you should contain all uses of the original _puts to your new puts proc -- this new puts should be transparent even to your code.
I assume you only want to log stuff you're writing to stdout
rename puts _orig_puts
proc puts {args} {
switch -exact [llength $args] {
3 {
# both -newline and a channelId are given
set do_log [expr {[lindex $args 1] eq "stdout"}]
}
2 {
# only log if not writing to stdout
set chan [lindex $args 0]
set do_log [expr {$chan eq "-nonewline" || $chan eq "stdout"}]
}
1 {
set do_log true
}
default {
error {wrong # args: should be "puts ?-nonewline? ?channelId? string"}
}
}
if {$do_log} {
set chan [open $::mylogfile a]
_orig_puts $chan [lindex $args end]
close $chan
}
_orig_puts {*}$args
}
I am trying to write a small bit of code that will list all of the variables and the values they contain in the info globals command. I have tried several iterations of substitution but cant get Tcl to treat the variable name as a variable, and return its value. Below is what I started with:
set fileid [open "c:/tcl variables.txt" w+]
foreach {x} [lsort [info globals]] {
set y $x
puts $fileid "$x $y "
}
I can get
DEG2RAD DEG2RAD
PI PI
RAD2DEG RAD2DEG
.....
or
DEG2RAD $DEG2RAD
PI $PI
RAD2DEG $RAD2DEG
.....
but what I need is
DEG2RAD 0.017453292519943295
PI 3.1415926535897931
RAD2DEG 57.295779513082323
....
I think you are looking for the subst command:
set fileid [open "c:/tcl variables.txt" w+]
foreach {x} [lsort [info globals]] {
puts $fileid "$x [subst $$x] "
}
Alternatively, you can take advantage of the fact that set returns the value being set:
set fileid [open "c:/tcl variables.txt" w+]
foreach {x} [lsort [info globals]] {
puts $fileid "$x [set $x] "
}
The easiest method for doing this (because it avoids littering the output with your temporary variables) is to use a helper procedure and the upvar command:
proc listAllGlobals {filename} {
set fileid [open $filename w+]
foreach varname [lsort [info globals]] {
upvar "#0" $varname var
if {[array exists var]} continue; # Skip global arrays...
puts $fileid "$varname $var "
}
close $fileid
}
listAllGlobals "C:/tcl variables.txt"
If you've got Tcl 8.5, you can do this without creating a procedure:
apply {{} {
set fileid [open "C:/tcl variables.txt" w+]
foreach varname [lsort [info globals]] {
upvar "#0" $varname var
if {[array exists var]} continue; # Skip global arrays...
puts $fileid "$varname $var "
}
close $fileid
}}
This all works because what upvar does is link a local variable to a variable in another stack frame; #0 is the name of the global stack frame, $varname is the name of the variable in that context, and var is the local variable to bind to.
Arrays are variables too so just for reference, this outputs all variables (including arrays):
proc ListAllGlobals {{?pattern? *}} {
foreach {name} [lsort [info globals ${?pattern?}]] {
upvar {#0} $name var
if {[array exists var]} {
foreach {key val} [array get var] {
puts "${name}($key) [list $val]"
}
} else {
puts "$name [list $var]"
}
}
}
ListAllGlobals
ListAllGlobals tcl_platform
I'm using list to enhanced readability of the values.
A pattern can be specified for a subset of variables. It doesn't apply to array element names.
In keeping with previous examples the output can be written to an opened file with: puts $fileid [ListAllGlobals]