You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
310 lines
11 KiB
310 lines
11 KiB
#!/usr/bin/env tclsh |
|
# whatis.tcl - runtime introspection report for a command, aimed at agent/LLM use |
|
# |
|
# Reports for a command name (possibly unqualified, possibly followed by |
|
# subcommand words - e.g 'string is', 'dict getdef'): |
|
# - resolved fully-qualified name and kind (proc / alias / ensemble / native) |
|
# - subcommand-chain resolution via punk::ns::cmdinfo (ensembles, aliases, |
|
# nested chains) with any unresolvable trailing words reported |
|
# - providing package + version and the origin file the loaded copy came from |
|
# - file:line of the proc definition in that origin file (when locatable) |
|
# - punk::args synopsis (compact usage line per form) |
|
# Options: |
|
# -body append the runtime proc body, numbered with file-relative line numbers |
|
# when the definition line was located (numbers then match the origin file) |
|
# -doc append the full argument documentation for all forms as plain text |
|
# (punk::ns::cmdhelp -return text) |
|
# |
|
# Must run inside a punkshell interpreter (needs punk::args, punk::ansi, punk::ns): |
|
# punk91 src script scriptlib/developer/whatis.tcl ?-body? ?-doc? <command> ?subcommand?... |
|
# Use the 'src' launch argument so the working-tree modules under src/modules are |
|
# loaded; without it the kit-stamped copies inside the executable (//zipfs:/...) |
|
# are introspected and file:line will not refer to editable files. |
|
# Exit 0 on success; 1 command not found; 2 usage error. |
|
|
|
proc strip {text} { |
|
if {[info commands ::ansistrip] ne ""} { |
|
return [ansistrip $text] |
|
} elseif {![catch {package require punk::ansi}]} { |
|
return [punk::ansi::ansistrip $text] |
|
} |
|
return $text |
|
} |
|
|
|
proc out {key val} { |
|
puts [format "%-9s %s" $key: [strip $val]] |
|
} |
|
|
|
# longest namespace-prefix of a fully-qualified command that names a package |
|
proc pkg_for_command {fqcmd} { |
|
set parts [lrange [split [string trimleft $fqcmd :] ::] 0 end] |
|
set parts [lsearch -all -inline -not $parts {}] ;# split on :: leaves empties |
|
for {set n [expr {[llength $parts]-1}]} {$n >= 1} {incr n -1} { |
|
set prefix [join [lrange $parts 0 $n-1] ::] |
|
if {![catch {package present $prefix} ver]} { |
|
return [list $prefix $ver] |
|
} |
|
} |
|
return {} |
|
} |
|
|
|
# attempt to load a package matching the namespace prefixes of $name |
|
proc try_autoload {name} { |
|
set parts [lsearch -all -inline -not [split [string trimleft $name :] ::] {}] |
|
for {set n [expr {[llength $parts]-1}]} {$n >= 1} {incr n -1} { |
|
set prefix [join [lrange $parts 0 $n-1] ::] |
|
if {![catch {package require $prefix}]} { |
|
return $prefix |
|
} |
|
} |
|
return {} |
|
} |
|
|
|
# origin file of a loaded package, parsed from its ifneeded script |
|
proc pkg_origin {pkg ver} { |
|
set script [package ifneeded $pkg $ver] |
|
if {[regexp {[;\n]?\s*source\s+(?:-encoding\s+\S+\s+)?(.+?)\s*$} $script -> path]} { |
|
return [string trim $path {"{}}] |
|
} |
|
if {[regexp {load\s+(\S+)} $script -> path]} { |
|
return $path |
|
} |
|
return "" |
|
} |
|
|
|
# locate the proc definition line in a source file; returns list of line numbers |
|
proc find_def_lines {path fqcmd} { |
|
if {$path eq "" || [catch {open $path r} fd]} { |
|
return {} |
|
} |
|
set data [read $fd] |
|
close $fd |
|
set tail [namespace tail $fqcmd] |
|
set noco [string trimleft $fqcmd :] |
|
set exact {} |
|
set bytail {} |
|
set ln 0 |
|
foreach line [split $data \n] { |
|
incr ln |
|
if {[regexp {^\s*proc\s+(:{0,2}[\w:]+)\s} $line -> pname]} { |
|
set pclean [string trimleft $pname :] |
|
if {$pclean eq $noco} { |
|
lappend exact $ln |
|
} elseif {[namespace tail $pclean] eq $tail} { |
|
lappend bytail $ln |
|
} |
|
} |
|
} |
|
if {[llength $exact]} { |
|
return $exact |
|
} |
|
return $bytail |
|
} |
|
|
|
# ---------------------------------------------------------------- arg handling |
|
set opt_body 0 |
|
set opt_doc 0 |
|
set names {} |
|
foreach a $argv { |
|
switch -- $a { |
|
-body {set opt_body 1} |
|
-doc {set opt_doc 1} |
|
default {lappend names $a} |
|
} |
|
} |
|
if {![llength $names]} { |
|
puts stderr "usage: punk91 src script scriptlib/developer/whatis.tcl ?-body? ?-doc? <command> ?subcommand?..." |
|
exit 2 |
|
} |
|
set name [lindex $names 0] |
|
set subwords [lrange $names 1 end] |
|
|
|
# ---------------------------------------------------------------- resolution |
|
set resolved [uplevel #0 [list namespace which -command $name]] |
|
if {$resolved eq ""} { |
|
set loaded [try_autoload $name] |
|
set resolved [uplevel #0 [list namespace which -command $name]] |
|
if {$resolved eq "" && $loaded ne ""} { |
|
puts stderr "whatis: loaded package '$loaded' but no command '$name' appeared" |
|
} |
|
} |
|
if {$resolved eq ""} { |
|
puts stderr "whatis: command '$name' not found (and no matching package could be loaded)" |
|
exit 1 |
|
} |
|
out command [join $names { }] |
|
|
|
set docid $resolved |
|
if {[llength $subwords]} { |
|
# subcommand-chain resolution (ensembles, aliases, nested chains) |
|
if {[catch {package require punk::ns}]} { |
|
puts stderr "whatis: subcommand chains need punk::ns (punk::ns::cmdinfo) which failed to load" |
|
exit 1 |
|
} |
|
if {[catch {punk::ns::cmdinfo {*}$names} cinfo]} { |
|
puts stderr "whatis: punk::ns::cmdinfo failed resolving '[join $names { }]': $cinfo" |
|
exit 1 |
|
} |
|
set chain_origin [dict get $cinfo origin] |
|
set args_remaining [dict get $cinfo args_remaining] |
|
set cinfo_docid [dict get $cinfo docid] |
|
out resolves $chain_origin |
|
if {[llength $args_remaining]} { |
|
out warning "trailing words '[join $args_remaining { }]' could not be resolved as subcommands (cmdtype [dict get $cinfo cmdtype])" |
|
} |
|
set resolved [uplevel #0 [list namespace which -command $chain_origin]] |
|
if {$resolved eq ""} { |
|
# documentation-only level (cmdtype doconly) or unresolvable - report what we know |
|
set resolved $chain_origin |
|
} |
|
set docid [expr {$cinfo_docid ne "" ? $cinfo_docid : $resolved}] |
|
} else { |
|
# alias chain (repl aliases are usually registered without leading colons) |
|
set target $resolved |
|
for {set depth 0} {$depth < 5} {incr depth} { |
|
set atarget {} |
|
foreach token [list [string trimleft $target :] $target] { |
|
set atarget [interp alias {} $token] |
|
if {[llength $atarget]} break |
|
} |
|
if {![llength $atarget]} break |
|
out alias "-> $atarget" |
|
set target [uplevel #0 [list namespace which -command [lindex $atarget 0]]] |
|
if {$target eq ""} break |
|
} |
|
if {$target ne "" && $target ne $resolved} { |
|
out resolves $target |
|
set resolved $target |
|
} |
|
set docid $resolved |
|
# prefer cmdinfo's docid when available (handles curried aliases, doc-only ids) |
|
if {![catch {package require punk::ns}] && ![catch {punk::ns::cmdinfo $name} cinfo]} { |
|
set cinfo_docid [dict get $cinfo docid] |
|
if {$cinfo_docid ne ""} { |
|
set docid $cinfo_docid |
|
} |
|
} |
|
} |
|
|
|
if {[info procs $resolved] ne ""} { |
|
set kind proc |
|
} elseif {[namespace ensemble exists $resolved]} { |
|
set kind ensemble |
|
} else { |
|
set kind "native command (C-implemented or unavailable as script)" |
|
} |
|
out kind $kind |
|
|
|
# ---------------------------------------------------------------- package/origin |
|
set pkginfo [pkg_for_command $resolved] |
|
set origin "" |
|
if {[llength $pkginfo]} { |
|
lassign $pkginfo pkg ver |
|
out package "$pkg $ver" |
|
set origin [pkg_origin $pkg $ver] |
|
if {$origin ne ""} { |
|
out origin $origin |
|
if {[string match //zipfs:* $origin]} { |
|
out warning "origin is the kit-stamped copy inside the executable - relaunch with 'punk91 src script ...' to introspect the working tree under src/modules" |
|
} |
|
} |
|
} else { |
|
out package "(none matched - Tcl core or statically provided)" |
|
} |
|
|
|
set defline 0 |
|
if {$kind eq "proc"} { |
|
set lines [find_def_lines $origin $resolved] |
|
if {[llength $lines] == 1} { |
|
set defline [lindex $lines 0] |
|
out def $origin:$defline |
|
} elseif {[llength $lines] > 1} { |
|
out def "ambiguous - candidate lines [join $lines {, }] in $origin" |
|
} elseif {$origin ne ""} { |
|
out def "(no proc definition found in origin file - possibly generated at runtime)" |
|
} |
|
} |
|
|
|
if {$kind eq "ensemble"} { |
|
set ns [namespace ensemble configure $resolved -namespace] |
|
set map [namespace ensemble configure $resolved -map] |
|
set subs [namespace ensemble configure $resolved -subcommands] |
|
out namespace $ns |
|
if {[dict size $map]} { |
|
puts "map:" |
|
dict for {sub tgt} $map { |
|
puts [format " %-20s -> %s" $sub $tgt] |
|
} |
|
} elseif {[llength $subs]} { |
|
out subcommands $subs |
|
} else { |
|
out subcommands "(exported commands of $ns: [join [info commands ${ns}::*] { }])" |
|
} |
|
} |
|
|
|
# ---------------------------------------------------------------- synopsis |
|
if {![catch {package require punk::args}]} { |
|
if {[catch {punk::args::synopsis $docid} syn]} { |
|
set syn "" |
|
} |
|
if {[string trim [strip $syn]] ne ""} { |
|
puts "synopsis:" |
|
foreach line [split [string trim [strip $syn]] \n] { |
|
puts " $line" |
|
} |
|
} else { |
|
puts "synopsis: (no punk::args definition registered for $docid)" |
|
} |
|
} |
|
|
|
# ---------------------------------------------------------------- optional body |
|
if {$opt_body && $kind eq "proc"} { |
|
set argspec {} |
|
foreach arg [info args $resolved] { |
|
if {[info default $resolved $arg dflt]} { |
|
lappend argspec [list $arg $dflt] |
|
} else { |
|
lappend argspec $arg |
|
} |
|
} |
|
puts "" |
|
if {$defline} { |
|
puts "body (line numbers are file-relative to $origin):" |
|
} else { |
|
puts "body (line numbers relative to definition - file location unknown):" |
|
} |
|
set bodylines [split [info body $resolved] \n] |
|
puts [format "%5d proc %s \{%s\} \{" $defline $resolved [join $argspec]] |
|
set ln $defline |
|
foreach bline [lrange $bodylines 1 end] { |
|
incr ln |
|
puts [format "%5d %s" $ln $bline] |
|
} |
|
} elseif {$opt_body} { |
|
puts "\nbody: (not a proc - no script body available)" |
|
} |
|
|
|
# ---------------------------------------------------------------- optional full doc |
|
if {$opt_doc} { |
|
puts "" |
|
set gotdoc 0 |
|
if {![catch {package require punk::ns}]} { |
|
# -return text: plain text, ANSI-free, all forms (punk::ns >= 0.9.0) |
|
if {![catch {punk::ns::cmdhelp -return text -- {*}$names} doctext]} { |
|
set gotdoc 1 |
|
} |
|
} |
|
if {!$gotdoc} { |
|
# older punk::ns without -return text (e.g kit-stamped copy) - fall back |
|
if {[info commands ::i] ne ""} { |
|
set doctext [strip [i {*}$names]] |
|
} elseif {![catch {punk::args::usage $docid} usage]} { |
|
set doctext [strip $usage] |
|
} else { |
|
set doctext "doc: (no argument documentation available for $docid)" |
|
} |
|
} |
|
puts $doctext |
|
} |
|
|
|
exit 0
|
|
|