@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/tcltk/exec/util-dump.tcl

@@ -0,0 +1,660 @@
+# 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