30 changed files with 9885 additions and 2198 deletions
@ -0,0 +1,396 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application proctrace 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
################## |
||||
## Module Name -- proctrace.tcl |
||||
## Original Author -- Emmanuel Frecon |
||||
## Description: |
||||
## |
||||
## This module is meant to be a last resort debugging facility. It will |
||||
## arrange for being able to trace execution either at the entry of |
||||
## procedure, either of all commands within procedures. The defaults are to |
||||
## trace all procedures, except the one from a few packages known to slow |
||||
## execution down. See beginning of library for an explanation of the |
||||
## options. |
||||
## |
||||
################## |
||||
|
||||
|
||||
tcl::namespace::eval ::proctrace { |
||||
variable PUNKARGS |
||||
|
||||
namespace eval vars { |
||||
# File to trace execution to (if no file is specified, tracing will |
||||
# occur on the standard error) |
||||
variable -file "" |
||||
# List of pattern to match against the name of current and future |
||||
# procedures. Only the procedures matching the patterns in this list |
||||
# will be considered for tracing. |
||||
variable -allowed {*} |
||||
# List of patterns to match against the name of procedure that should |
||||
# not be considered for tracing. This is a subset of the ones allowed. |
||||
variable -denied {::tcl::* ::aes::* ::logger::*} |
||||
# A boolean, turn it on to trace the execution of each command block |
||||
# within the procedures. |
||||
variable -detailed off |
||||
|
||||
variable fd stderr; # File descriptor where to trace |
||||
variable version 0.2; # Current package version. |
||||
variable enabled 1; # Is tracing enabled |
||||
} |
||||
|
||||
# Automatically export all procedures starting with lower case and |
||||
# create an ensemble for an easier API. |
||||
namespace export {[a-z]*} |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ::proctrace::init -- Init and start tracing |
||||
# |
||||
# Arrange to trace the execution of code either at the entry of procedure, |
||||
# either of all commands within procedures. This command takes a number of |
||||
# dash led options, these are described a the beginning of the library. |
||||
# |
||||
# Arguments: |
||||
# args List of dash-led options and arguments. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side Effects: |
||||
# Will start tracing, which means a LOT of output! |
||||
proc ::proctrace::init { args } { |
||||
# Detect all options available to the procedure, out of the variables that |
||||
# are dash-led. |
||||
set opts [list] |
||||
foreach o [info vars vars::-*] { |
||||
set i [string last "::-" $o] |
||||
lappend opts [string trimleft [string range $o $i end] :] |
||||
} |
||||
|
||||
# "parse" the options, i.e. set the values if they should exist... |
||||
foreach {k v} $args { |
||||
if { $k in $opts } { |
||||
set vars::$k $v |
||||
} else { |
||||
return -code error "$k unknown options, should be [join $opts ,\ ]" |
||||
} |
||||
} |
||||
|
||||
# Open the file for output, if relevant. |
||||
if { ${vars::-file} ne "" } { |
||||
set vars::fd [open ${vars::-file} w] |
||||
} |
||||
|
||||
# Arrange to reroute procedure declaration through our command so we can |
||||
# automagically install execution traces. |
||||
rename ::proc ::proctrace::RealProc |
||||
interp alias {} ::proc {} ::proctrace::Proc |
||||
|
||||
# Catch up with the current set of existing procedure to make sure we can |
||||
# also capture execution within procedure that would have been created |
||||
# before ::proctrace::init was called. |
||||
foreach p [AllProcs] { |
||||
if { [Tracable $p]} { |
||||
Follow $p 2 |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::proctrace::terminate {} {set ::proctrace::vars::enabled 0} |
||||
proc ::proctrace::resume {} {set ::proctrace::vars::enabled 1} |
||||
|
||||
|
||||
# ::proctrace::AllProcs -- List all declared procedures |
||||
# |
||||
# Returns a list of all declared procedures, in all namespaces currently |
||||
# defined in the interpreter. The implementation recursively list all |
||||
# procedures in all sub-namespaces. |
||||
# |
||||
# Arguments: |
||||
# base Namespace at which to start. |
||||
# |
||||
# Results: |
||||
# List of all procedure in current and descendant namespaces. |
||||
# |
||||
# Side Effects: |
||||
# None. |
||||
proc ::proctrace::AllProcs { { base "::" } } { |
||||
# Get list of procedures in current namespace. |
||||
set procs [info procs [string trimright ${base} :]::*] |
||||
# Recurse in children namespaces. |
||||
foreach ns [namespace children $base] { |
||||
set procs [concat $procs [AllProcs $ns]] |
||||
} |
||||
return $procs |
||||
} |
||||
|
||||
|
||||
# ::proctrace::Follow -- Install traces |
||||
# |
||||
# Install traces to be able to get notified whenever procedures are |
||||
# entered or commands within procedures are executed. |
||||
# |
||||
# Arguments: |
||||
# name Name (fully-qualified) of procedure. |
||||
# lvl Call stack level at which to execute trace installation |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side Effects: |
||||
# Arrange for Trace procedure to be called |
||||
proc ::proctrace::Follow { name {lvl 1}} { |
||||
if { [string is true ${vars::-detailed}] } { |
||||
uplevel $lvl [list trace add execution $name enter [list ::proctrace::Trace $name]] |
||||
uplevel $lvl [list trace add execution $name enterstep [list ::proctrace::Trace $name]] |
||||
} else { |
||||
uplevel $lvl [list trace add execution $name enter [list ::proctrace::Trace $name]] |
||||
} |
||||
} |
||||
|
||||
|
||||
# ::proctrace::Proc -- Capturing procedure |
||||
# |
||||
# This is our re-implementation of the proc command. It calls the original |
||||
# command and also arranges to install traces if appropriate. |
||||
# |
||||
# Arguments: |
||||
# name Name of procedure |
||||
# arglist List of arguments to procedure |
||||
# body Procedure body. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side Effects: |
||||
# Creates a new procedure, possibly arrange for tracing its execution. |
||||
proc ::proctrace::Proc { name arglist body } { |
||||
uplevel 1 [list ::proctrace::RealProc $name $arglist $body] |
||||
if { [Tracable $name]} { |
||||
Follow $name 2 |
||||
} |
||||
} |
||||
|
||||
variable tinfo |
||||
# ::proctrace::Trace -- Perform trace |
||||
# |
||||
# Trace procedure/command execution. |
||||
# |
||||
# Arguments: |
||||
# target Name of procedure |
||||
# command Command being executed |
||||
# op Operation (should be enter or enterstep, not used) |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side Effects: |
||||
# Trace execution on globally allocated file descriptor. |
||||
proc ::proctrace::Trace { target command op } { |
||||
if {!$::proctrace::vars::enabled} {return} |
||||
variable tinfo |
||||
if {$op eq "enter"} { |
||||
dict set tinfo($target) firstline -1 |
||||
dict set tinfo($target) procoffset 0 |
||||
dict set tinfo($target) level [expr {[info level]+1}] |
||||
dict set tinfo($target) subcmds 0 |
||||
puts $vars::fd "ENTER $target >> $command" |
||||
return |
||||
} else { |
||||
if {[tcl::info::level] != [tcl::dict::get $tinfo($target) level]} { |
||||
return |
||||
} |
||||
} |
||||
puts $vars::fd "STEP $target >> $command" |
||||
flush $vars::fd |
||||
} |
||||
|
||||
# ::proctrace::Tracable -- Should procedure be traced |
||||
# |
||||
# Decide if a procedure should be traced according to the -allowed and |
||||
# -denied options that are global to this library. |
||||
# |
||||
# Arguments: |
||||
# name Fully-qualified procedure name |
||||
# |
||||
# Results: |
||||
# 1 if the procedure should be traced, 0 otherwise. |
||||
# |
||||
# Side Effects: |
||||
# None. |
||||
proc ::proctrace::Tracable { name } { |
||||
# Traverse -allow(ance) list to allow procedure. |
||||
set allow 0 |
||||
foreach ptn ${vars::-allowed} { |
||||
if { [string match $ptn $name] } { |
||||
set allow 1 |
||||
break |
||||
} |
||||
} |
||||
|
||||
# Possibly negate previous allowance through matching the name against the |
||||
# patterns in the -denied list. |
||||
foreach ptn ${vars::-denied} { |
||||
if { [string match $ptn $name] } { |
||||
set allow 0 |
||||
break |
||||
} |
||||
} |
||||
|
||||
# Return final decision. |
||||
return $allow |
||||
} |
||||
|
||||
package provide proctrace $::proctrace::vars::version |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval proctrace::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval proctrace::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval proctrace { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)proctrace" |
||||
@package -name "proctrace" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return proctrace |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package proctrace |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::proctrace::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{Emmanuel Frecon}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::proctrace::about" |
||||
dict set overrides @cmd -name "proctrace::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About proctrace |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[proctrace::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [proctrace::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::proctrace::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::proctrace::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::proctrace |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide proctrace [tcl::namespace::eval proctrace { |
||||
variable pkg proctrace |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
0.2 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -1,3 +1,3 @@
|
||||
0.1.0 |
||||
0.1.1 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,3 +1,3 @@
|
||||
0.1.3 |
||||
0.1.4 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,68 @@
|
||||
#file should load as list of lists with punk::lib::tclscript_to_scriptlist |
||||
|
||||
|
||||
\ |
||||
\ |
||||
puts test1 |
||||
|
||||
# extended comment with trailing whitespace \ |
||||
etc\ |
||||
|
||||
puts test2 |
||||
|
||||
list\ |
||||
test3\ |
||||
# hmm |
||||
|
||||
set x [list\ |
||||
#blah \ |
||||
etc |
||||
] |
||||
puts "x = $x" |
||||
|
||||
set y [list A B |
||||
] |
||||
puts "y = $y" |
||||
|
||||
set z [list not in z because next line is a new command which becomes result of the script delimited by square brackets |
||||
set j 1 |
||||
] |
||||
#z will be just 1 |
||||
puts "z = $z" |
||||
|
||||
set hmm { |
||||
#seemingly unbalanced comment,but is just part of hmm data - still requires balancing close curly within the data { |
||||
#syntax highlighters usually get this wrong. |
||||
} |
||||
# also not really a comment, but closing curly is not part of data } |
||||
puts $hmm |
||||
|
||||
;# } |
||||
# unbalanced curly in *toplevel* comment is unwise, but not really a problem. info complete for this line will be true. { |
||||
|
||||
set data " |
||||
# { |
||||
" |
||||
|
||||
set j 123;set k 345 |
||||
;list\ |
||||
a b c |
||||
|
||||
set etc { |
||||
\{ a test |
||||
;} |
||||
|
||||
|
||||
list \ #etc |
||||
|
||||
list \ \" ;#etc |
||||
|
||||
proc { x } {a} { |
||||
return $a |
||||
} |
||||
|
||||
|
||||
\ x\ blah |
||||
|
||||
#the end |
||||
|
||||
@ -0,0 +1,43 @@
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test parse_tcl_script_switchargs {test basic parse of switch args (switch form 1) tclscript_to_scriptlist}\ |
||||
-setup $common -body { |
||||
# |
||||
set scr {-exact -- [lindex $args 0] {a - b {expr 33} c {expr 44}} } |
||||
set lol [punk::lib::tclscript_to_scriptlist $scr] |
||||
lappend result [llength $lol] ;#single toplevel script |
||||
lappend result [llength [lindex $lol 0]] |
||||
#final arg to switch -form 1 is a scriptblock consisting of pattern/script pairs |
||||
set patternblock_script [lindex $lol 0 end] |
||||
set patternblock_contents [lindex $patternblock_script 0] ;#it's braced |
||||
#we should be able to treat the data within the braces as a dict. |
||||
lappend result [dict keys $patternblock_contents] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
1 4 {a b c} |
||||
] |
||||
|
||||
test parse_tcl_script_oneline {test basic parse of single-line script to list of lists with tclscript_to_scriptlist}\ |
||||
-setup $common -body { |
||||
set scr {puts [info name]; dict get {a A b "B B"} a} |
||||
set lol [punk::lib::tclscript_to_scriptlist $scr] |
||||
lappend result [llength $lol] ;#2 toplevel scripts |
||||
lappend result [llength [lindex $lol 0]] |
||||
lappend result [llength [lindex $lol 1]] |
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
2 2 4 |
||||
] |
||||
|
||||
} |
||||
Loading…
Reference in new issue