661 lines
17 KiB
Tcl
661 lines
17 KiB
Tcl
# util-dump.tcl --
|
|
#
|
|
# This file implements package ::Utility::dump, which ...
|
|
#
|
|
# Copyright (c) 1997-8 Jeffrey Hobbs
|
|
#
|
|
# See the file "license.terms" for information on usage and
|
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
#
|
|
|
|
package require ::Utility
|
|
package provide ::Utility::dump 1.0
|
|
|
|
namespace eval ::Utility::dump {;
|
|
|
|
namespace export -clear dump*
|
|
namespace import -force ::Utility::get_opts*
|
|
|
|
# dump --
|
|
# outputs recognized item info in source'able form.
|
|
# Accepts glob style pattern matching for the names
|
|
# Arguments:
|
|
# type type of item to dump
|
|
# -nocomplain
|
|
# -filter pattern
|
|
# specifies a glob filter pattern to be used by the variable
|
|
# method as an array filter pattern (it filters down for
|
|
# nested elements) and in the widget method as a config
|
|
# option filter pattern
|
|
# -procs
|
|
# -vars
|
|
# -recursive
|
|
# -imports
|
|
# -- forcibly ends options recognition
|
|
# Results:
|
|
# the values of the requested items in a 'source'able form
|
|
;proc dump {type arg
|
|
s} {
|
|
if {![llength $args]} {
|
|
## If no args, assume they gave us something to dump and
|
|
## we'll try anything
|
|
set args [list $type]
|
|
set type multi
|
|
}
|
|
## Args are handled individually by the routines because of the
|
|
## variable parameters for each type
|
|
set prefix [namespace current]::dump_
|
|
if {[string match {} [set arg [info commands $prefix$type]]]} {
|
|
set arg [info commands $prefix$type*]
|
|
}
|
|
set result {}
|
|
set code ok
|
|
switch [llength $arg] {
|
|
1 { set code [catch {uplevel $arg $args} result] }
|
|
0 {
|
|
set arg [info commands $prefix*]
|
|
regsub -all $prefix $arg {} arg
|
|
return -code error "unknown [lindex [info level 0] 0] type\
|
|
\"$type\", must be one of: [join [lsort $arg] {, }]"
|
|
}
|
|
default {
|
|
regsub -all $prefix $arg {} arg
|
|
return -code error "ambiguous type \"$type\",\
|
|
could be one of: [join [lsort $arg] {, }]"
|
|
}
|
|
}
|
|
return -code $code $result
|
|
}
|
|
|
|
# dump_multi --
|
|
#
|
|
# Tries to work the args into one of the main dump types:
|
|
# variable, command, widget, namespace
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_multi {args} {
|
|
array set opts {
|
|
-nocomplain 0
|
|
}
|
|
set namesp [namespace current]
|
|
set args [get_opts opts $args {-nocomplain 0} {} 1]
|
|
set code ok
|
|
if {
|
|
[catch {uplevel ${namesp}::dump var $args} err] &&
|
|
[catch {uplevel ${namesp}::dump com $args} err] &&
|
|
[catch {uplevel ${namesp}::dump wid $args} err] &&
|
|
[catch {uplevel ${namesp}::dump nam $args} err]
|
|
} {
|
|
set result "# unable to resolve type for \"$args\"\n"
|
|
if {!$opts(-nocomplain)} {
|
|
set code error
|
|
}
|
|
} else {
|
|
set result $err
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_command --
|
|
#
|
|
# outputs commands by figuring out, as well as possible,
|
|
# it does not attempt to auto-load anything
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_command {args} {
|
|
array set opts {
|
|
-nocomplain 0 -origin 0
|
|
}
|
|
set args [get_opts opts $args {-nocomplain 0 -origin 0}]
|
|
if {[string match {} $args]} {
|
|
if {$opts(-nocomplain)} {
|
|
return
|
|
} else {
|
|
return -code error "wrong \# args: dump command ?-nocomplain?"
|
|
}
|
|
}
|
|
set code ok
|
|
set result {}
|
|
set namesp [namespace current]
|
|
foreach arg $args {
|
|
if {[string compare {} [set cmds \
|
|
[uplevel info command [list $arg]]]]} {
|
|
foreach cmd [lsort $cmds] {
|
|
if {[lsearch -exact [interp aliases] $cmd] > -1} {
|
|
append result "\#\# ALIAS: $cmd =>\
|
|
[interp alias {} $cmd]\n"
|
|
} elseif {![catch {uplevel ${namesp}::dump_proc \
|
|
[expr {$opts(-origin)?{-origin}:{}}] \
|
|
-- [list $cmd]} msg]} {
|
|
append result $msg\n
|
|
} else {
|
|
if {$opts(-origin) || [string compare $namesp \
|
|
[uplevel namespace current]]} {
|
|
set cmd [uplevel namespace origin [list $cmd]]
|
|
}
|
|
append result "\#\# COMMAND: $cmd\n"
|
|
}
|
|
}
|
|
} elseif {!$opts(-nocomplain)} {
|
|
append result "\#\# No known command $arg\n"
|
|
set code error
|
|
}
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_proc --
|
|
#
|
|
# ADD COMMENTS HERE
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_proc {args} {
|
|
array set opts {
|
|
-nocomplain 0 -origin 0
|
|
}
|
|
set args [get_opts opts $args {-nocomplain 0 -origin 0}]
|
|
if {[string match {} $args]} {
|
|
if {$opts(-nocomplain)} {
|
|
return
|
|
} else {
|
|
return -code error "wrong \# args: dump proc ?-nocomplain?"
|
|
}
|
|
}
|
|
set code ok
|
|
set result {}
|
|
foreach arg $args {
|
|
set procs [uplevel info command [list $arg]]
|
|
set count 0
|
|
if {[string compare $procs {}]} {
|
|
foreach p [lsort $procs] {
|
|
set cmd [uplevel namespace origin [list $p]]
|
|
set namesp [namespace qualifiers $cmd]
|
|
if {[string match {} $namesp]} { set namesp :: }
|
|
if {[string compare [namespace eval $namesp \
|
|
info procs [list [namespace tail $cmd]]] {}]} {
|
|
incr count
|
|
} else {
|
|
continue
|
|
}
|
|
set pargs {}
|
|
foreach a [info args $cmd] {
|
|
if {[info default $cmd $a tmp]} {
|
|
lappend pargs [list $a $tmp]
|
|
} else {
|
|
lappend pargs $a
|
|
}
|
|
}
|
|
if {$opts(-origin) || [string compare $namesp \
|
|
[uplevel namespace current]]} {
|
|
## This is ideal, but list can really screw with the
|
|
## format of the body for some procs with odd whitespacing
|
|
## (everything comes out backslashed)
|
|
#append result [list proc $cmd $pargs [info body $cmd]]
|
|
append result [list proc $cmd $pargs]
|
|
} else {
|
|
## We don't include the full namespace qualifiers
|
|
## if we are in the namespace of origin
|
|
#append result [list proc $p $pargs [info body $cmd]]
|
|
append result [list proc $p $pargs]
|
|
}
|
|
append result " \{[info body $cmd]\}\n\n"
|
|
}
|
|
}
|
|
if {!$count && !$opts(-nocomplain)} {
|
|
append result "\#\# No known proc $arg\n"
|
|
set code error
|
|
}
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_variable --
|
|
#
|
|
# outputs variable value(s), whether array or simple, namespaced or otherwise
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
## FIX perhaps a little namespace which is necessary here
|
|
proc dump_variable {args} {
|
|
array set opts {
|
|
-nocomplain 0 -filter *
|
|
}
|
|
set args [get_opts opts $args {-nocomplain 0 -filter 1}]
|
|
if {[string match {} $args]} {
|
|
if {$opts(-nocomplain)} {
|
|
return
|
|
} else {
|
|
return -code error "wrong \# args: dump variable ?-nocomplain?\
|
|
?-filter glob? ?--? pattern ?pattern ...?"
|
|
}
|
|
}
|
|
set code ok
|
|
set result {}
|
|
foreach arg $args {
|
|
if {[string match {} [set vars [uplevel info vars [list $arg]]]]} {
|
|
if {[uplevel info exists $arg]} {
|
|
set vars $arg
|
|
} elseif {!$opts(-nocomplain)} {
|
|
append result "\#\# No known variable $arg\n"
|
|
set code error
|
|
continue
|
|
} else { continue }
|
|
}
|
|
foreach var [lsort -dictionary $vars] {
|
|
set var [uplevel [list namespace which -variable $var]]
|
|
upvar $var v
|
|
if {[array exists v] || [catch {string length $v}]} {
|
|
set nest {}
|
|
append result "array set $var \{\n"
|
|
foreach i [lsort -dictionary [array names v $opts(-filter)]] {
|
|
upvar 0 v\($i\) __ary
|
|
if {[array exists __ary]} {
|
|
append nest "\#\# NESTED ARRAY ELEMENT: $i\n"
|
|
append nest "upvar 0 [list $var\($i\)] __ary;\
|
|
[dump v -filter $opts(-filter) __ary]\n"
|
|
} else {
|
|
append result " [list $i]\t[list $v($i)]\n"
|
|
}
|
|
}
|
|
append result "\}\n$nest"
|
|
} else {
|
|
append result [list set $var $v]\n
|
|
}
|
|
}
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_namespace --
|
|
#
|
|
# ADD COMMENTS HERE
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_namespace {args} {
|
|
array set opts {
|
|
-nocomplain 0 -filter * -procs 1 -vars 1 -recursive 0 -imports 1
|
|
}
|
|
set args [get_opts opts $args {-nocomplain 0 -procs 1 -vars 1 \
|
|
-recursive 0 -imports 1} {-procs boolean -vars boolean \
|
|
-imports boolean}]
|
|
if {[string match {} $args]} {
|
|
if {$opts(-nocomplain)} {
|
|
return
|
|
} else {
|
|
return -code error "wrong \# args: dump namespace ?-nocomplain?\
|
|
?-procs 0/1? ?-vars 0/1? ?-recursive? ?-imports 0/1?\
|
|
?--? pattern ?pattern ...?"
|
|
}
|
|
}
|
|
set code ok
|
|
set result {}
|
|
foreach arg $args {
|
|
set cur [uplevel namespace current]
|
|
# Namespace search order:
|
|
# If it starts with ::, try and break it apart and see if we find
|
|
# children matching the pattern
|
|
# Then do the same in $cur if it has :: anywhere in it
|
|
# Then look in the calling namespace for children matching $arg
|
|
# Then look in the global namespace for children matching $arg
|
|
if {
|
|
([string match ::* $arg] &&
|
|
[catch [list namespace children [namespace qualifiers $arg] \
|
|
[namespace tail $arg]] names]) &&
|
|
([string match *::* $arg] &&
|
|
[catch [list namespace eval $cur [list namespace children \
|
|
[namespace qualifiers $arg] \
|
|
[namespace tail $arg]] names]]) &&
|
|
[catch [list namespace children $cur $arg] names] &&
|
|
[catch [list namespace children :: $arg] names]
|
|
} {
|
|
if {!$opts(-nocomplain)} {
|
|
append result "\#\# No known namespace $arg\n"
|
|
set code error
|
|
}
|
|
}
|
|
if {[string compare $names {}]} {
|
|
set count 0
|
|
foreach name [lsort $names] {
|
|
append result "namespace eval $name \{;\n\n"
|
|
if {$opts(-vars)} {
|
|
set vars [lremove [namespace eval $name info vars] \
|
|
[info globals]]
|
|
append result [namespace eval $name \
|
|
[namespace current]::dump_variable [lsort $vars]]\n
|
|
}
|
|
set procs [namespace eval $name info procs]
|
|
if {$opts(-procs)} {
|
|
set export [namespace eval $name namespace export]
|
|
if {[string compare $export {}]} {
|
|
append result "namespace export -clear $export\n\n"
|
|
}
|
|
append result [namespace eval $name \
|
|
[namespace current]::dump_proc [lsort $procs]]
|
|
}
|
|
if {$opts(-imports)} {
|
|
set cmds [info commands ${name}::*]
|
|
regsub -all ${name}:: $cmds {} cmds
|
|
set cmds [lremove $cmds $procs]
|
|
foreach cmd [lsort $cmds] {
|
|
set cmd [namespace eval $name \
|
|
[list namespace origin $cmd]]
|
|
if {[string compare $name \
|
|
[namespace qualifiers $cmd]]} {
|
|
## Yup, it comes from somewhere else
|
|
append result [list namespace import -force $cmd]
|
|
} else {
|
|
## It is probably an alias
|
|
set alt [interp alias {} $cmd]
|
|
if {[string compare $alt {}]} {
|
|
append result "interp alias {} $cmd {} $alt"
|
|
} else {
|
|
append result "# CANNOT HANDLE $cmd"
|
|
}
|
|
}
|
|
append result \n
|
|
}
|
|
append result \n
|
|
}
|
|
if {$opts(-recursive)} {
|
|
append result [uplevel [namespace current]::dump_namespace\
|
|
[namespace children $name]]
|
|
}
|
|
append result "\}; # end of namespace $name\n\n"
|
|
}
|
|
} elseif {!$opts(-nocomplain)} {
|
|
append result "\#\# No known namespace $arg\n"
|
|
set code error
|
|
}
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_widget --
|
|
# Outputs a widget configuration in source'able but human readable form.
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns widget configuration in "source"able form.
|
|
#
|
|
proc dump_widget {args} {
|
|
if {[string match {} [info command winfo]]} {
|
|
return -code error "winfo not present, cannot dump widgets"
|
|
}
|
|
array set opts {
|
|
-nocomplain 0 -filter .* -default 0
|
|
}
|
|
set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0} \
|
|
{-filter regexp}]
|
|
if {[string match {} $args]} {
|
|
if {$opts(-nocomplain)} {
|
|
return
|
|
} else {
|
|
return -code error "wrong \# args: dump widget ?-nocomplain?\
|
|
?-default? ?-filter regexp? ?--? pattern ?pattern ...?"
|
|
}
|
|
}
|
|
set code ok
|
|
set result {}
|
|
foreach arg $args {
|
|
if {[string compare {} [set ws [info command $arg]]]} {
|
|
foreach w [lsort $ws] {
|
|
if {[winfo exists $w]} {
|
|
if {[catch {$w configure} cfg]} {
|
|
append result "\#\# Widget $w\
|
|
does not support configure method"
|
|
if {!$opts(-nocomplain)} {
|
|
set code error
|
|
}
|
|
} else {
|
|
append result "\#\# [winfo class $w] $w\n$w configure"
|
|
foreach c $cfg {
|
|
if {[llength $c] != 5} continue
|
|
## Filter options according to user provided
|
|
## filter, and then check to see that they
|
|
## are a default
|
|
if {[regexp -nocase -- $opts(-filter) $c] && \
|
|
($opts(-default) || [string compare \
|
|
[lindex $c 3] [lindex $c 4]])} {
|
|
append result " \\\n\t[list [lindex $c 0]\
|
|
[lindex $c 4]]"
|
|
}
|
|
}
|
|
append result \n
|
|
}
|
|
}
|
|
}
|
|
} elseif {!$opts(-nocomplain)} {
|
|
append result "\#\# No known widget $arg\n"
|
|
set code error
|
|
}
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_canvas --
|
|
#
|
|
# ADD COMMENTS HERE
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_canvas {args} {
|
|
if {[string match {} [info command winfo]]} {
|
|
return -code error "winfo not present, cannot dump widgets"
|
|
}
|
|
array set opts {
|
|
-nocomplain 0 -default 0 -configure 0 -filter .*
|
|
}
|
|
set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0 \
|
|
-configure 0} {-filter regexp}]
|
|
if {[string match {} $args]} {
|
|
if {$opts(-nocomplain)} {
|
|
return
|
|
} else {
|
|
return -code error "wrong \# args: dump canvas ?-nocomplain?\
|
|
?-configure? ?-default? ?-filter regexp? ?--? pattern\
|
|
?pattern ...?"
|
|
}
|
|
}
|
|
set code ok
|
|
set result {}
|
|
foreach arg $args {
|
|
if {[string compare {} [set ws [info command $arg]]]} {
|
|
foreach w [lsort $ws] {
|
|
if {[winfo exists $w]} {
|
|
if {[string compare Canvas [winfo class $w]]} {
|
|
append result "\#\# Widget $w is not a canvas widget"
|
|
if {!$opts(-nocomplain)} {
|
|
set code error
|
|
}
|
|
} else {
|
|
if {$opts(-configure)} {
|
|
append result [dump_widget -filter $opts(-filter) \
|
|
[expr {$opts(-default)?{-default}:{-no}}] \
|
|
$w]
|
|
append result \n
|
|
} else {
|
|
append result "\#\# Canvas $w items\n"
|
|
}
|
|
## Output canvas items in numerical order
|
|
foreach i [lsort -integer [$w find all]] {
|
|
append result "\#\# Canvas item $i\n" \
|
|
"$w create [$w type $i] [$w coords $i]"
|
|
foreach c [$w itemconfigure $i] {
|
|
if {[llength $c] != 5} continue
|
|
if {$opts(-default) || [string compare \
|
|
[lindex $c 3] [lindex $c 4]]} {
|
|
append result " \\\n\t[list [lindex $c 0]\
|
|
[lindex $c 4]]"
|
|
}
|
|
}
|
|
append result \n
|
|
}
|
|
}
|
|
}
|
|
}
|
|
} elseif {!$opts(-nocomplain)} {
|
|
append result "\#\# No known widget $arg\n"
|
|
set code error
|
|
}
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_text --
|
|
#
|
|
# ADD COMMENTS HERE
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_text {args} {
|
|
if {[string match {} [info command winfo]]} {
|
|
return -code error "winfo not present, cannot dump widgets"
|
|
}
|
|
array set opts {
|
|
-nocomplain 0 -default 0 -configure 0 -start 1.0 -end end
|
|
}
|
|
set args [get_opts opts $args {-nocomplain 0 -default 0 \
|
|
-configure 0 -start 1 -end 1}]
|
|
if {[string match {} $args]} {
|
|
if {$opts(-nocomplain)} {
|
|
return
|
|
} else {
|
|
return -code error "wrong \# args: dump text ?-nocomplain?\
|
|
?-configure? ?-default? ?-filter regexp? ?--? pattern\
|
|
?pattern ...?"
|
|
}
|
|
}
|
|
set code ok
|
|
set result {}
|
|
foreach arg $args {
|
|
if {[string compare {} [set ws [info command $arg]]]} {
|
|
foreach w [lsort $ws] {
|
|
if {[winfo exists $w]} {
|
|
if {[string compare Text [winfo class $w]]} {
|
|
append result "\#\# Widget $w is not a text widget"
|
|
if {!$opts(-nocomplain)} {
|
|
set code error
|
|
}
|
|
} else {
|
|
if {$opts(-configure)} {
|
|
append result [dump_widget -filter $opts(-filter) \
|
|
[expr {$opts(-default)?{-default}:{-no}}] \
|
|
$w]
|
|
append result \n
|
|
} else {
|
|
append result "\#\# Text $w dump\n"
|
|
}
|
|
catch {unset tags}
|
|
catch {unset marks}
|
|
set text {}
|
|
foreach {k v i} [$w dump $opts(-start) $opts(-end)] {
|
|
switch -exact $k {
|
|
text {
|
|
append text $v
|
|
}
|
|
window {
|
|
# must do something with windows
|
|
# will require extra options to determine
|
|
# whether to rebuild the window or to
|
|
# just reference it
|
|
append result "#[list $w] window create\
|
|
$i [$w window configure $i]\n"
|
|
}
|
|
mark {set marks($v) $i}
|
|
tagon {lappend tags($v) $i}
|
|
tagoff {lappend tags($v) $i}
|
|
default {
|
|
error "[info level 0]:\
|
|
should not be in this switch arm"
|
|
}
|
|
}
|
|
}
|
|
append result "[list $w insert $opts(-start) $text]\n"
|
|
foreach i [$w tag names] {
|
|
append result "[list $w tag configure $i]\
|
|
[$w tag configure $i]\n"
|
|
if {[info exists tags($i)]} {
|
|
append result "[list $w tag add $i]\
|
|
$tags($i)\n"
|
|
}
|
|
foreach seq [$w tag bind $i] {
|
|
append result "[list $w tag bind $i $seq \
|
|
[$w tag bind $i $seq]]\n"
|
|
}
|
|
}
|
|
foreach i [array names marks] {
|
|
append result "[list $w mark set $i $marks($i)]\n"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
} elseif {!$opts(-nocomplain)} {
|
|
append result "\#\# No known widget $arg\n"
|
|
set code error
|
|
}
|
|
}
|
|
return -code $code [string trimright $result \n]
|
|
}
|
|
|
|
# dump_interface -- NOT FUNCTIONAL
|
|
#
|
|
# the end-all-be-all of Tk dump commands. This should dump the widgets
|
|
# of an interface with all the geometry management.
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_interface {args} {
|
|
|
|
}
|
|
|
|
# dump_state --
|
|
#
|
|
# This dumps the state of an interpreter. This is primarily a wrapper
|
|
# around other dump commands with special options.
|
|
#
|
|
# Arguments:
|
|
# args comments
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
proc dump_state {args} {
|
|
|
|
}
|
|
|
|
|
|
## Force the parent namespace to include the exported commands
|
|
##
|
|
catch {namespace eval ::Utility namespace import -force ::Utility::dump::*}
|
|
|
|
}; # end of namespace ::Utility::dump
|
|
|
|
return
|