src/library/tcltk/exec/util-dump.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