how to create tcl proc with hyphen flag arguments - tcl

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"

Related

What is the proper way to create hyphen parameters in TCL that are Boolean or have values? [duplicate]

I am writing a proc to create a header in an output file.
Currently it needs to take an optional parameter, which is a possible comment for the header.
I have ended up coding this as a single optional parameter
proc dump_header { test description {comment = ""}}
but would like to know how I can achieve the same using args
proc dump_header { test description args }
It's quite easy to check for args being a single blank parameter ($args == ""), but doesn't cope well if passing multiple parameters - and I need the negative check anyway.
Your proc definition is incorrect (you'd get the error message too many fields in argument specifier "comment = """). Should be:
proc dump_header { test description {comment ""}} {
puts $comment
}
If you want to use args, you could examine the llength of it:
proc dump_header {test desc args} {
switch -exact [llength $args] {
0 {puts "no comment"}
1 {puts "the comment is: $args"}
default {
puts "the comment is: [lindex $args 0]"
puts "the other args are: [lrange $args 1 end]"
}
}
}
You might also want to pass name-value pairs in a list:
proc dump_header {test desc options} {
# following will error if $options is an odd-length list
array set opts $options
if {[info exists opts(comment)]} {
puts "the comment is: $opts(comment)"
}
puts "here are all the options given:"
parray opts
}
dump_header "test" "description" {comment "a comment" arg1 foo arg2 bar}
Some prefer a combination of args and name-value pairs (a la Tk)
proc dump_header {test desc args} {
# following will error if $args is an odd-length list
array set opts $args
if {[info exists opts(-comment)]} {
puts "the comment is: $opts(-comment)"
}
parray opts
}
dump_header "test" "description" -comment "a comment" -arg1 foo -arg2 bar
I use tcllib's cmdline library to do option parsing.
This is the example from cmdline documentation:
set options {
{a "set the atime only"}
{m "set the mtime only"}
{c "do not create non-existent files"}
{r.arg "" "use time from ref_file"}
{t.arg -1 "use specified time"}
}
set usage ": MyCommandName \[options] filename ...\noptions:"
array set params [::cmdline::getoptions argv $options $usage]
if { $params(a) } { set set_atime "true" }
set has_t [expr {$params(t) != -1}]
set has_r [expr {[string length $params(r)] > 0}]
if {$has_t && $has_r} {
return -code error "Cannot specify both -r and -t"
} elseif {$has_t} {
...
}
So, in your case, you'd just use args in place of argv in the above example.
It should be mentioned explicitly that args is a special word in Tcl that, when used at the end of the argument list, contains a list of all the remaining arguments. If no args are given, then no error is produced (unlike any other variable name, which would be considered a required argument).
I was looking for a way to have functionality similar to python's kwargs (optional key-value pair arguments), and something that works nicely is (similar to Glenn's last example):
proc my_proc {positional_required1 {positional_optional1 "a_string"} args} {
# Two optional arguments can be given: "opt1" and "opt2"
if {![string equal $args ""]} {
# If one or more args is given, parse them or assign defaults.
array set opts $args
if {[info exists opts(opt1)]} { set opt1 $opts(opt1) } else { set opt1 0 }
if {[info exists opts(op2)]} { set opt2 $opts(opt2) } else { set opt2 -1 }
} else {
# If no args are given, assign default values.
set op1 0
set op2 -1
}
# DO STUFF HERE
}
And can be called like:
my_proc "positional_required1_argument"
# OR
my_proc "positional_required1_argument" "a_string"
# OR
my_proc "positional_required1_argument" "a_string" opt1 7
# OR
my_proc "positional_required1_argument" "a_string" opt1 7 opt2 50
# etc.
A potential downside (as I've currently implemented it) is that if a user passes a non-approved key-value option, there is no error.

Tcl: Using the unknown command to include dot notation procedures

Tcl syntax is very simple and consistant in the sense of its command / arguments structure. Sometimes I miss the dot notation of other languages like ruby. In ruby you can right something like this:
-199.abs # => 199
"ice is nice".length # => 11
"ruby is cool.".index("u") # => 1
"Nice Day Isn't It?".downcase.split("").uniq.sort.join # => " '?acdeinsty"
In Radical Language Modification and Let unknown know there are ideas of how to modify the language with the unknown command, e.g.:
proc know {cond body} {
proc unknown {args} [string map [list #c# $cond #b# $body] {
if {![catch {expr {#c#}} res] && $res} {
return [eval {#b#}]
}
}][info body unknown]
}
know {[regexp {^([a-z]+)\.([a-z]+)$} [lindex $args 0] -> from to]} {
set res {}
while {$from<=$to} {lappend res $from; incr from}
set res
}
# % puts [1..5]
# 1 2 3 4 5
How can I modify the previous code, so I can write commands with dot notation as in the Ruby example.
You can do it for specific operations, but not all, and there are some syntactic limitations. For example:
know {[regexp {^(.*)\.length$} [lindex $args 0] -> value]} {
string length $value
}
puts [abc.length]
# ---> 3
set thevar "abc def"
puts [$thevar.length]
# ---> 7
puts ["abc def".length]
# ---> extra characters after close-quote
That is, the value must still be syntactically-valid Tcl; that last example is not. You can chain the know handlers by using [$value] instead of plain $value in the handler, provided you've got a handler for the base case.
know {[regexp {^(.*)\.length$} [lindex $args 0] -> value]} {
string length [$value]
}
know {[regexp {^(.*)\.repeat\((\d+)\)$} [lindex $args 0] -> value count]} {
string repeat [$value] $count
}
# Base case for simple words
know {[regexp {^'(.*)'$} [lindex $args 0] -> value]} {
set value
}
puts ['abc\ def'.repeat(5).length]
# ---> 35
Ultimately, while you can do all sorts of stuff like this, it's not how Tcl is designed to work. It is going to be slow (the unknown calling mechanism is not an optimised path) and you're going to hit limitations. Better to learn to do things the normal way:
puts [string length [string repeat "abc def" 5]]

Remove all OBX segments from a HL7 message

I have the following code which removed all OBX segments prior to the first one that contains addendum:
# This Cloverleaf TPS script removes all OBX segments prior to the first one that contains "ADDENDUM".
# This script also renumbers the OBX segments.
#
# See http://clovertech.healthvision.com/viewtopic.php?t=5953
proc remove_prior_to_addendum {args} {
# set the procedure name
# This is used for error messages
set procname [lindex [info level [info level]] 0]
# bring some common variables into the scope of this proc
global HciSite HciSiteDir HciProcessesDir HciConnName HciRootDir ibdir
# fetch mode
keylget args MODE mode
# keylget args ARGS.ARGNAME argname
switch -exact -- $mode {
start {
# Perform special init functions
# N.B.: there may or may not be a MSGID key in args
}
run {
# 'run' mode always has a MSGID; fetch and process it
keylget args MSGID msgid
# get the message
set msgdata [msgget $msgid]
# does this message have "ADDENDUM"?
if {! [regexp {OBX[^\r]*\|ADDENDUM} $msgdata] } {
# This message does not have an ADDENDUM, so continue the message
return "{CONTINUE $msgid}"
}
# if we get here, we have an ADDENDUM
# get the separators
set segment_sep \r
# process the message
if { [catch {
# commands
# split the message into segments
set segments [split $msgdata $segment_sep]
# find the first OBX with an ADDENDUM
set addendum_index [lsearch -regexp $segments {^OBX[^\r]*\|ADDENDUM}]
# renumber the OBX segments that will remain
set i 1
foreach index [lsearch -all -regexp -start $addendum_index $segments {^OBX}] {
set segment [lindex $segments $index]
set segments [lreplace $segments $index $index [regsub {^OBX\|[0-9]*\|} $segment "OBX|$i|"]]
incr i
}
# now find any OBX segments prior to the ADDENDUM segment
set obx_indexes [lsearch -all -regexp [lrange $segments 0 [expr $addendum_index - 1]] {^OBX}]
# sort the indexes descending so that we can safely remove the indexes
set obx_indexes [lsort -decreasing -integer $obx_indexes]
# remove each segment
foreach index $obx_indexes {
set segments [lreplace $segments $index $index]
}
# rebuild the message
set msgdata [join $segments $segment_sep]
} errmsg ] } {
# the commands errored
global errorInfo
msgmetaset $msgid USERDATA "ERROR: $errmsg\n*** Tcl TRACE ***\n$errorInfo"
# rethrow the error
error $errmsg $errorInfo
}
# set the output message
msgset $msgid $msgdata
# return whether to kill, continue, etc. the message
return "{CONTINUE $msgid}"
}
time {
# Timer-based processing
# N.B.: there may or may not be a MSGID key in args
}
shutdown {
# Do some clean-up work
}
default {
error "Unknown mode in $procname: $mode"
return "" ;# Dont know what to do
}
}
}
How do I edit the script so it removed ALL OBX segments from the message?
I don't know much about hl7 (in fact I know nothing about it) but it looks like you want to remove those lines:
# does this message have "ADDENDUM"?
if {! [regexp {OBX[^\r]*\|ADDENDUM} $msgdata] } {
# This message does not have an ADDENDUM, so continue the message
return "{CONTINUE $msgid}"
}

How TCL stores variable in Memory

file1.txt
dut1Loop1Net = [::ip::contract [::ip::prefix 1.1.1.1/24]]/24
My script is
set in [open file1.txt r]
set line [gets $in]
if {[string trim [string range $line1 0 0]] != "#"} {
set devicePort [string trim [lindex $line1 0]]
set mark [expr [string first "=" $line1] + 1]
set val [string trim [string range $line1 $mark end]]
global [set t $devicePort]
set [set t $devicePort] $val
}
close $in
Problem
I am getting output as
% set dut1Loop1Net
[::ip::contract [::ip::prefix 1.1.1.1/24]]/24
Here i am getting the string without evaluating.
I am expecting the output as 1.1.1.0/24. Because TCL does not evaluate code here, it is printing like a string.
I am interesting to know how TCL stores the data and in which form it will retreive the data.
How Tcl stores values.
The short story:
Everything is a string
The long strory
Tcl stores the data in the last used datatype, calculate the string representation only when nessecary, uses copy on write, a simple refcount memory managment.
The answer how you evaluate it is with eval or subst. In your case probably subst.
Edit:
If your config file looks like this:
# This is a comment
variable = value
othervar = [doStuff]
you can use some tricks to get Tcl parsing it for you:
rename ::unknown ::_confp_unknown_orig
proc unknown args {
if {[llength $args] == 3 && [lindex $args 1] eq "="} {
# varname = value
uplevel 1 [list set [lindex $args 0] [lindex $args 2]
return [lindex $args 2]
}
# otherwise fallback to the original unknown
uplevel 1 [linsert $args 0 ::_confp_unknown_orig]
# if you are on 8.6, replace the line above with
# tailcall ::_confp_unknown_orig {*}$args
}
# Now just source the file:
source file1.txt
# cleanup - if you like
rename ::unknown {}
rename ::_confp_unknown_orig ::unknown
An other way to do that is to use a safe interp, but in this case using your main interp looks fine.
The problem is that the code you store inside val is never executed.
You access it using $val, but this way you get the code itself, and not the result of its execution.
To solve it, you must be sure [::ip::contract [::ip::prefix 1.1.1.1/24]]/24 is executed, and you can do that by replacing this line
set val [string trim [string range $line1 $mark end]]
with this one
eval "set val [string trim [string range $line1 $mark end]]"
Why? Here's my simple explaination:
The parser sees the "..." part, so it performs substitutions inside it
The first substitution is the execution of the string range $line1 $mark end command
The second substitution is the execution of the string trim ... command
So, when substitutions are complete and the eval command is ready to run, its like your line has become
eval {set val [::ip::contract [::ip::prefix 1.1.1.1/24]]/24}
Now the eval command is executed, it calls recursively the interpreter, so the string set val [::ip::contract [::ip::prefix 1.1.1.1/24]]/24 goes to another substitution phase, which finally runs what you want and puts the string 1.1.1/24 into the variable val.
I hope this helps.

How can I safely deal with optional parameters

I am writing a proc to create a header in an output file.
Currently it needs to take an optional parameter, which is a possible comment for the header.
I have ended up coding this as a single optional parameter
proc dump_header { test description {comment = ""}}
but would like to know how I can achieve the same using args
proc dump_header { test description args }
It's quite easy to check for args being a single blank parameter ($args == ""), but doesn't cope well if passing multiple parameters - and I need the negative check anyway.
Your proc definition is incorrect (you'd get the error message too many fields in argument specifier "comment = """). Should be:
proc dump_header { test description {comment ""}} {
puts $comment
}
If you want to use args, you could examine the llength of it:
proc dump_header {test desc args} {
switch -exact [llength $args] {
0 {puts "no comment"}
1 {puts "the comment is: $args"}
default {
puts "the comment is: [lindex $args 0]"
puts "the other args are: [lrange $args 1 end]"
}
}
}
You might also want to pass name-value pairs in a list:
proc dump_header {test desc options} {
# following will error if $options is an odd-length list
array set opts $options
if {[info exists opts(comment)]} {
puts "the comment is: $opts(comment)"
}
puts "here are all the options given:"
parray opts
}
dump_header "test" "description" {comment "a comment" arg1 foo arg2 bar}
Some prefer a combination of args and name-value pairs (a la Tk)
proc dump_header {test desc args} {
# following will error if $args is an odd-length list
array set opts $args
if {[info exists opts(-comment)]} {
puts "the comment is: $opts(-comment)"
}
parray opts
}
dump_header "test" "description" -comment "a comment" -arg1 foo -arg2 bar
I use tcllib's cmdline library to do option parsing.
This is the example from cmdline documentation:
set options {
{a "set the atime only"}
{m "set the mtime only"}
{c "do not create non-existent files"}
{r.arg "" "use time from ref_file"}
{t.arg -1 "use specified time"}
}
set usage ": MyCommandName \[options] filename ...\noptions:"
array set params [::cmdline::getoptions argv $options $usage]
if { $params(a) } { set set_atime "true" }
set has_t [expr {$params(t) != -1}]
set has_r [expr {[string length $params(r)] > 0}]
if {$has_t && $has_r} {
return -code error "Cannot specify both -r and -t"
} elseif {$has_t} {
...
}
So, in your case, you'd just use args in place of argv in the above example.
It should be mentioned explicitly that args is a special word in Tcl that, when used at the end of the argument list, contains a list of all the remaining arguments. If no args are given, then no error is produced (unlike any other variable name, which would be considered a required argument).
I was looking for a way to have functionality similar to python's kwargs (optional key-value pair arguments), and something that works nicely is (similar to Glenn's last example):
proc my_proc {positional_required1 {positional_optional1 "a_string"} args} {
# Two optional arguments can be given: "opt1" and "opt2"
if {![string equal $args ""]} {
# If one or more args is given, parse them or assign defaults.
array set opts $args
if {[info exists opts(opt1)]} { set opt1 $opts(opt1) } else { set opt1 0 }
if {[info exists opts(op2)]} { set opt2 $opts(opt2) } else { set opt2 -1 }
} else {
# If no args are given, assign default values.
set op1 0
set op2 -1
}
# DO STUFF HERE
}
And can be called like:
my_proc "positional_required1_argument"
# OR
my_proc "positional_required1_argument" "a_string"
# OR
my_proc "positional_required1_argument" "a_string" opt1 7
# OR
my_proc "positional_required1_argument" "a_string" opt1 7 opt2 50
# etc.
A potential downside (as I've currently implemented it) is that if a user passes a non-approved key-value option, there is no error.