I need to get invocation line number of tcl proc inside it’s body.
Starting from 8.5 tcl have info frame command which allows following:
proc printLine {} {
set lineNum [dict get [info frame 1] line]
}
I need the same for 8.4
It's not available in 8.4; the data wasn't collected at all. I guess you could search for a unique token in the line, but that'd be about all.
proc lineNumber {uniqueToken} {
set name [lindex [info level 1] 0]
set body [uplevel 2 [list info body $name]]
set num 0
foreach line [split $body \n] {
incr num
if {[string first $uniqueToken $line] >= 0} {
return $num
}
}
error "could not find token '$uniqueToken'"
}
Note that 8.4 is not supported any more. Upgrade.
I'm using tcl 8.5, but it should work on version 8.4. here is:
#!/usr/bin/tclsh
puts "tcl version: $tcl_version"
proc linum {} {
if {![string equal -nocase precompiled [lindex [info frame -1] 1]]} {
return [lindex [info frame -1] 3]
} else {
return Unknown
}
}
puts "call proc #line:[linum]"
and the result is:
tcl version: 8.5
call proc #line:13
you can reference info frame for more details
Related
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"
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]]
The script have sourced N number of files..,
source file 1
source file 2
.
.
source file N
when particular procedure A called ., Its actually present in most of the sourced files., anyway the last sourced file containing that proc A will do the function.,
how to find which file containing the proc is used when i call the proc ?
Any code i can use to achieve it ?
The simplest way (assuming Tcl 8.5 or 8.6) is to use an execution trace to call info frame to get the details of the call stack.
trace add execution A enter callingA
proc callingA args {
set ctxt [info frame -1]
if {[dict exists $ctxt file] && [dict exists $ctxt proc]} {
puts "Called [lindex $args 0 0] from [dict get $ctxt proc] in [dict get $ctxt file]"
} elseif {[dict exists $ctxt proc]} {
puts "Called [lindex $args 0 0] from [dict get $ctxt proc] (unknown location)"
} else {
# Fallback
puts "Called [lindex $args 0 0] from within [file normalize [info script]]"
}
}
There's quite a bit of other information in the dictionary returned by info frame.
For Tcl 8.4
In Tcl 8.4, you don't have info frame and Tcl doesn't remember where procedures are defined by default. You still have execution traces though (they were a new feature of Tcl 8.4) so that's OK then. (We have to be a bit careful with info script as that's only valid during the source and not after it finishes; procedures tend to be called later.)
To get where every procedure is defined, you have to intercept proc itself, and to do so early in your script execution! (Procedures defined before you set up the interceptor aren't noticed; Tcl's semantics are purely operational.) Fortunately, you can use an execution trace for this.
proc procCalled {cmd code args} {
if {$code==0} {
global procInFile
set procName [uplevel 1 [list namespace which [lindex $cmd 1]]]
set procInFile($procName) [file normalize [info script]]
}
}
# We use a leave trace for maximum correctness
trace add execution proc leave procCalled
Then, you use another execution trace on the command that you want to know the callers of to look up what that command is called, and hence where it was defined.
proc callingA args {
# Wrap in a catch so a lookup failure doesn't cause problems
if {[catch {
set caller [lindex [info level -1] 0]
global procInFile
set file $procInFile($caller)
puts "Calling [lindex $args 0 0] from $caller in $file"
}]} {
# Not called from procedure!
puts "Calling [lindex $args 0 0] from within [file normalize [info script]]"
}
}
trace add execution A enter callingA
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 have implemented many TCL extensions for a specific tool in the domain of formal methods (extensions are implemented in C but I do not want solution to rely on this fact). Thus, the users of my tool can use TCL for prototyping algorithms. Many of them are just linear list of commands (they are powerfull), e.g.:
my_read_file f
my_do_something a b c
my_do_something_else a b c
Now, I am interested in timing. It is possible to change the script to get:
puts [time [my_read_file f] 1]
puts [time [my_do_something a b c] 1]
puts [time [my_do_something_else a b c] 1]
Instead of this I want to define procedure xsource that executes a TCL script and get/write timing for all my commands. Some kind of a profiler. I wrote a naive implementation where the main idea is as follows:
set f [open [lindex $argv 0] r]
set inputLine ""
while {[gets $f line] >= 0} {
set d [expr [string length $line] - 1]
if { $d >= 0 } {
if { [string index $line 0] != "#" } {
if {[string index $line $d] == "\\"} {
set inputLine "$inputLine [string trimright [string range $line 0 [expr $d - 1]]]"
} else {
set inputLine "$inputLine $line"
set inputLine [string trimleft $inputLine]
puts $inputLine
puts [time {eval $inputLine} 1]
}
set inputLine ""
}
}
}
It works for linear list of commands and even allows comments and commands over multiple lines. But it fails if the user uses if statements, loops, and definition of procedures. Can you propose a better approach? It must be pure TCL script with as few extensions as possible.
One way of doing what you're asking for is to use execution traces. Here's a script that can do just that:
package require Tcl 8.5
# The machinery for tracking command execution times; prints the time taken
# upon termination of the command. More info is available too (e.g., did the
# command have an exception) but isn't printed here.
variable timerStack {}
proc timerEnter {cmd op} {
variable timerStack
lappend timerStack [clock microseconds]
}
proc timerLeave {cmd code result op} {
variable timerStack
set now [clock microseconds]
set then [lindex $timerStack end]
set timerStack [lrange $timerStack 0 end-1]
# Remove this length check to print everything out; could be a lot!
# Alternatively, modify the comparison to print more stack frames.
if {[llength $timerStack] < 1} {
puts "[expr {$now-$then}]: $cmd"
}
}
# Add the magic!
trace add execution source enterstep timerEnter
trace add execution source leavestep timerLeave
# And invoke the magic, magically
source [set argv [lassign $argv argv0];set argv0]
# Alternatively, if you don't want argument rewriting, just do:
# source yourScript.tcl
Then you'd call it like this (assuming you've put it in a file called timer.tcl):
tclsh8.5 timer.tcl yourScript.tcl
Be aware that this script has a considerable amount of overhead, as it inhibits many optimization strategies that are normally used. That won't matter too much for uses where you're doing the real meat in your own C code, but when it's lots of loops in Tcl then you'll notice a lot.
You can wrap your commands which you want to measure. And name wrappers exactly as the original ones (renaming original procs before). After that, when instrumented command is executed it actually executes the wrapper, which executes the original procedure and measure the time of execution. The example below (Tcl 8.5).
proc instrument {procs} {
set skip_procs {proc rename instrument puts time subst uplevel return}
foreach p $procs {
if {$p ni $skip_procs} {
uplevel [subst -nocommands {
rename $p __$p
proc $p {args} {
puts "$p: [time {set r [__$p {*}\$args]}]"
return \$r
}
}]
}
}
}
proc my_proc {a} {
set r 1
for {set i 1} {$i <= $a} {incr i} {
set r [expr {$r * $i}]
}
return $r
}
proc my_another_proc {a b} {
set r 0
for {set i $a} {$i <= $b} {incr i} {
incr r $i
}
return $r
}
instrument [info commands my_*]
puts "100 = [my_proc 100]"
puts "200 = [my_proc 100]"
puts "100 - 200 = [my_another_proc 100 200]"
You might want to look at the command "info complete". It can tell you if what you have accumulated so far looks complete from the point of view of most common Tcl syntax markers. It will deal with command input that might be spread across multiple physical lines.