1# util-dump.tcl --
2#
3#	This file implements package ::Utility::dump, which  ...
4#
5# Copyright (c) 1997-8 Jeffrey Hobbs
6#
7# See the file "license.terms" for information on usage and
8# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9#
10
11package require ::Utility
12package provide ::Utility::dump 1.0
13
14namespace eval ::Utility::dump {;
15
16namespace export -clear dump*
17namespace import -force ::Utility::get_opts*
18
19# dump --
20#   outputs recognized item info in source'able form.
21#   Accepts glob style pattern matching for the names
22# Arguments:
23#   type	type of item to dump
24#   -nocomplain
25#   -filter	pattern
26#		specifies a glob filter pattern to be used by the variable
27#		method as an array filter pattern (it filters down for
28#		nested elements) and in the widget method as a config
29#		option filter pattern
30#   -procs
31#   -vars
32#   -recursive
33#   -imports
34#   --		forcibly ends options recognition
35# Results:
36#	the values of the requested items in a 'source'able form
37;proc dump {type args} {
38    if {![llength $args]} {
39	## If no args, assume they gave us something to dump and
40	## we'll try anything
41	set args [list $type]
42	set type multi
43    }
44    ## Args are handled individually by the routines because of the
45    ## variable parameters for each type
46    set prefix [namespace current]::dump_
47    if {[string match {} [set arg [info commands $prefix$type]]]} {
48	set arg [info commands $prefix$type*]
49    }
50    set result {}
51    set code ok
52    switch [llength $arg] {
53	1 { set code [catch {uplevel $arg $args} result] }
54	0 {
55	    set arg [info commands $prefix*]
56	    regsub -all $prefix $arg {} arg
57	    return -code error "unknown [lindex [info level 0] 0] type\
58		    \"$type\", must be one of: [join [lsort $arg] {, }]"
59	}
60	default {
61	    regsub -all $prefix $arg {} arg
62	    return -code error "ambiguous type \"$type\",\
63		    could be one of: [join [lsort $arg] {, }]"
64	}
65    }
66    return -code $code $result
67}
68
69# dump_multi --
70#
71#   Tries to work the args into one of the main dump types:
72#   variable, command, widget, namespace
73#
74# Arguments:
75#   args	comments
76# Results:
77#   Returns ...
78#
79proc dump_multi {args} {
80    array set opts {
81	-nocomplain 0
82    }
83    set namesp [namespace current]
84    set args [get_opts opts $args {-nocomplain 0} {} 1]
85    set code ok
86    if {
87	[catch {uplevel ${namesp}::dump var $args} err] &&
88	[catch {uplevel ${namesp}::dump com $args} err] &&
89	[catch {uplevel ${namesp}::dump wid $args} err] &&
90	[catch {uplevel ${namesp}::dump nam $args} err]
91    } {
92	set result "# unable to resolve type for \"$args\"\n"
93	if {!$opts(-nocomplain)} {
94	    set code error
95	}
96    } else {
97	set result $err
98    }
99    return -code $code [string trimright $result \n]
100}
101
102# dump_command --
103#
104# outputs commands by figuring out, as well as possible,
105# it does not attempt to auto-load anything
106#
107# Arguments:
108#   args	comments
109# Results:
110#   Returns ...
111#
112proc dump_command {args} {
113    array set opts {
114	-nocomplain 0 -origin 0
115    }
116    set args [get_opts opts $args {-nocomplain 0 -origin 0}]
117    if {[string match {} $args]} {
118	if {$opts(-nocomplain)} {
119	    return
120	} else {
121	    return -code error "wrong \# args: dump command ?-nocomplain?"
122	}
123    }
124    set code ok
125    set result {}
126    set namesp [namespace current]
127    foreach arg $args {
128	if {[string compare {} [set cmds \
129		[uplevel info command [list $arg]]]]} {
130	    foreach cmd [lsort $cmds] {
131		if {[lsearch -exact [interp aliases] $cmd] > -1} {
132		    append result "\#\# ALIAS:   $cmd =>\
133			    [interp alias {} $cmd]\n"
134		} elseif {![catch {uplevel ${namesp}::dump_proc \
135			[expr {$opts(-origin)?{-origin}:{}}] \
136			-- [list $cmd]} msg]} {
137		    append result $msg\n
138		} else {
139		    if {$opts(-origin) || [string compare $namesp \
140			    [uplevel namespace current]]} {
141			set cmd [uplevel namespace origin [list $cmd]]
142		    }
143		    append result "\#\# COMMAND: $cmd\n"
144		}
145	    }
146	} elseif {!$opts(-nocomplain)} {
147	    append result "\#\# No known command $arg\n"
148	    set code error
149	}
150    }
151    return -code $code [string trimright $result \n]
152}
153
154# dump_proc --
155#
156#   ADD COMMENTS HERE
157#
158# Arguments:
159#   args	comments
160# Results:
161#   Returns ...
162#
163proc dump_proc {args} {
164    array set opts {
165	-nocomplain 0 -origin 0
166    }
167    set args [get_opts opts $args {-nocomplain 0 -origin 0}]
168    if {[string match {} $args]} {
169	if {$opts(-nocomplain)} {
170	    return
171	} else {
172	    return -code error "wrong \# args: dump proc ?-nocomplain?"
173	}
174    }
175    set code ok
176    set result {}
177    foreach arg $args {
178	set procs [uplevel info command [list $arg]]
179	set count 0
180	if {[string compare $procs {}]} {
181	    foreach p [lsort $procs] {
182		set cmd [uplevel namespace origin [list $p]]
183		set namesp [namespace qualifiers $cmd]
184		if {[string match {} $namesp]} { set namesp :: }
185		if {[string compare [namespace eval $namesp \
186			info procs [list [namespace tail $cmd]]] {}]} {
187		    incr count
188		} else {
189		    continue
190		}
191		set pargs {}
192		foreach a [info args $cmd] {
193		    if {[info default $cmd $a tmp]} {
194			lappend pargs [list $a $tmp]
195		    } else {
196			lappend pargs $a
197		    }
198		}
199		if {$opts(-origin) || [string compare $namesp \
200			[uplevel namespace current]]} {
201		    ## This is ideal, but list can really screw with the
202		    ## format of the body for some procs with odd whitespacing
203		    ## (everything comes out backslashed)
204		    #append result [list proc $cmd $pargs [info body $cmd]]
205		    append result [list proc $cmd $pargs]
206		} else {
207		    ## We don't include the full namespace qualifiers
208		    ## if we are in the namespace of origin
209		    #append result [list proc $p $pargs [info body $cmd]]
210		    append result [list proc $p $pargs]
211		}
212		append result " \{[info body $cmd]\}\n\n"
213	    }
214	}
215	if {!$count && !$opts(-nocomplain)} {
216	    append result "\#\# No known proc $arg\n"
217	    set code error
218	}
219    }
220    return -code $code [string trimright $result \n]
221}
222
223# dump_variable --
224#
225# outputs variable value(s), whether array or simple, namespaced or otherwise
226#
227# Arguments:
228#   args	comments
229# Results:
230#   Returns ...
231#
232## FIX perhaps a little namespace which is necessary here
233proc dump_variable {args} {
234    array set opts {
235	-nocomplain 0 -filter *
236    }
237    set args [get_opts opts $args {-nocomplain 0 -filter 1}]
238    if {[string match {} $args]} {
239	if {$opts(-nocomplain)} {
240	    return
241	} else {
242	    return -code error "wrong \# args: dump variable ?-nocomplain?\
243		    ?-filter glob? ?--? pattern ?pattern ...?"
244	}
245    }
246    set code ok
247    set result {}
248    foreach arg $args {
249	if {[string match {} [set vars [uplevel info vars [list $arg]]]]} {
250	    if {[uplevel info exists $arg]} {
251		set vars $arg
252	    } elseif {!$opts(-nocomplain)} {
253		append result "\#\# No known variable $arg\n"
254		set code error
255		continue
256	    } else { continue }
257	}
258	foreach var [lsort -dictionary $vars] {
259	    set var [uplevel [list namespace which -variable $var]]
260	    upvar $var v
261	    if {[array exists v] || [catch {string length $v}]} {
262		set nest {}
263		append result "array set $var \{\n"
264		foreach i [lsort -dictionary [array names v $opts(-filter)]] {
265		    upvar 0 v\($i\) __ary
266		    if {[array exists __ary]} {
267			append nest "\#\# NESTED ARRAY ELEMENT: $i\n"
268			append nest "upvar 0 [list $var\($i\)] __ary;\
269				[dump v -filter $opts(-filter) __ary]\n"
270		    } else {
271			append result "    [list $i]\t[list $v($i)]\n"
272		    }
273		}
274		append result "\}\n$nest"
275	    } else {
276		append result [list set $var $v]\n
277	    }
278	}
279    }
280    return -code $code [string trimright $result \n]
281}
282
283# dump_namespace --
284#
285#   ADD COMMENTS HERE
286#
287# Arguments:
288#   args	comments
289# Results:
290#   Returns ...
291#
292proc dump_namespace {args} {
293    array set opts {
294	-nocomplain 0 -filter *	-procs 1 -vars 1 -recursive 0 -imports 1
295    }
296    set args [get_opts opts $args {-nocomplain 0 -procs 1 -vars 1 \
297	    -recursive 0 -imports 1} {-procs boolean -vars boolean \
298	    -imports boolean}]
299    if {[string match {} $args]} {
300	if {$opts(-nocomplain)} {
301	    return
302	} else {
303	    return -code error "wrong \# args: dump namespace ?-nocomplain?\
304		    ?-procs 0/1? ?-vars 0/1? ?-recursive? ?-imports 0/1?\
305		    ?--? pattern ?pattern ...?"
306	}
307    }
308    set code ok
309    set result {}
310    foreach arg $args {
311	set cur [uplevel namespace current]
312	# Namespace search order:
313	# If it starts with ::, try and break it apart and see if we find
314	# children matching the pattern
315	# Then do the same in $cur if it has :: anywhere in it
316	# Then look in the calling namespace for children matching $arg
317	# Then look in the global namespace for children matching $arg
318	if {
319	    ([string match ::* $arg] &&
320	    [catch [list namespace children [namespace qualifiers $arg] \
321		    [namespace tail $arg]] names]) &&
322	    ([string match *::* $arg] &&
323	    [catch [list namespace eval $cur [list namespace children \
324		    [namespace qualifiers $arg] \
325		    [namespace tail $arg]] names]]) &&
326	    [catch [list namespace children $cur $arg] names] &&
327	    [catch [list namespace children :: $arg] names]
328	} {
329	    if {!$opts(-nocomplain)} {
330		append result "\#\# No known namespace $arg\n"
331		set code error
332	    }
333	}
334	if {[string compare $names {}]} {
335	    set count 0
336	    foreach name [lsort $names] {
337		append result "namespace eval $name \{;\n\n"
338		if {$opts(-vars)} {
339		    set vars [lremove [namespace eval $name info vars] \
340			    [info globals]]
341		    append result [namespace eval $name \
342			    [namespace current]::dump_variable [lsort $vars]]\n
343		}
344		set procs [namespace eval $name info procs]
345		if {$opts(-procs)} {
346		    set export [namespace eval $name namespace export]
347		    if {[string compare $export {}]} {
348			append result "namespace export -clear $export\n\n"
349		    }
350		    append result [namespace eval $name \
351			    [namespace current]::dump_proc [lsort $procs]]
352		}
353		if {$opts(-imports)} {
354		    set cmds [info commands ${name}::*]
355		    regsub -all ${name}:: $cmds {} cmds
356		    set cmds [lremove $cmds $procs]
357		    foreach cmd [lsort $cmds] {
358			set cmd [namespace eval $name \
359				[list namespace origin $cmd]]
360			if {[string compare $name \
361				[namespace qualifiers $cmd]]} {
362			    ## Yup, it comes from somewhere else
363			    append result [list namespace import -force $cmd]
364			} else {
365			    ## It is probably an alias
366			    set alt [interp alias {} $cmd]
367			    if {[string compare $alt {}]} {
368				append result "interp alias {} $cmd {} $alt"
369			    } else {
370				append result "# CANNOT HANDLE $cmd"
371			    }
372			}
373			append result \n
374		    }
375		    append result \n
376		}
377		if {$opts(-recursive)} {
378		    append result [uplevel [namespace current]::dump_namespace\
379			    [namespace children $name]]
380		}
381		append result "\}; # end of namespace $name\n\n"
382	    }
383	} elseif {!$opts(-nocomplain)} {
384	    append result "\#\# No known namespace $arg\n"
385	    set code error
386	}
387    }
388    return -code $code [string trimright $result \n]
389}
390
391# dump_widget --
392#   Outputs a widget configuration in source'able but human readable form.
393# Arguments:
394#   args	comments
395# Results:
396#   Returns widget configuration in "source"able form.
397#
398proc dump_widget {args} {
399    if {[string match {} [info command winfo]]} {
400	return -code error "winfo not present, cannot dump widgets"
401    }
402    array set opts {
403	-nocomplain 0 -filter .* -default 0
404    }
405    set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0} \
406	    {-filter regexp}]
407    if {[string match {} $args]} {
408	if {$opts(-nocomplain)} {
409	    return
410	} else {
411	    return -code error "wrong \# args: dump widget ?-nocomplain?\
412		    ?-default? ?-filter regexp? ?--? pattern ?pattern ...?"
413	}
414    }
415    set code ok
416    set result {}
417    foreach arg $args {
418	if {[string compare {} [set ws [info command $arg]]]} {
419	    foreach w [lsort $ws] {
420		if {[winfo exists $w]} {
421		    if {[catch {$w configure} cfg]} {
422			append result "\#\# Widget $w\
423				does not support configure method"
424			if {!$opts(-nocomplain)} {
425			    set code error
426			}
427		    } else {
428			append result "\#\# [winfo class $w] $w\n$w configure"
429			foreach c $cfg {
430			    if {[llength $c] != 5} continue
431			    ## Filter options according to user provided
432			    ## filter, and then check to see that they
433			    ## are a default
434			    if {[regexp -nocase -- $opts(-filter) $c] && \
435				    ($opts(-default) || [string compare \
436				    [lindex $c 3] [lindex $c 4]])} {
437				append result " \\\n\t[list [lindex $c 0]\
438					[lindex $c 4]]"
439			    }
440			}
441			append result \n
442		    }
443		}
444	    }
445	} elseif {!$opts(-nocomplain)} {
446	    append result "\#\# No known widget $arg\n"
447	    set code error
448	}
449    }
450    return -code $code [string trimright $result \n]
451}
452
453# dump_canvas --
454#
455#   ADD COMMENTS HERE
456#
457# Arguments:
458#   args	comments
459# Results:
460#   Returns ...
461#
462proc dump_canvas {args} {
463    if {[string match {} [info command winfo]]} {
464	return -code error "winfo not present, cannot dump widgets"
465    }
466    array set opts {
467	-nocomplain 0 -default 0 -configure 0 -filter .*
468    }
469    set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0 \
470	    -configure 0} {-filter regexp}]
471    if {[string match {} $args]} {
472	if {$opts(-nocomplain)} {
473	    return
474	} else {
475	    return -code error "wrong \# args: dump canvas ?-nocomplain?\
476		    ?-configure? ?-default? ?-filter regexp? ?--? pattern\
477		    ?pattern ...?"
478	}
479    }
480    set code ok
481    set result {}
482    foreach arg $args {
483	if {[string compare {} [set ws [info command $arg]]]} {
484	    foreach w [lsort $ws] {
485		if {[winfo exists $w]} {
486		    if {[string compare Canvas [winfo class $w]]} {
487			append result "\#\# Widget $w is not a canvas widget"
488			if {!$opts(-nocomplain)} {
489			    set code error
490			}
491		    } else {
492			if {$opts(-configure)} {
493			    append result [dump_widget -filter $opts(-filter) \
494				    [expr {$opts(-default)?{-default}:{-no}}] \
495				    $w]
496			    append result \n
497			} else {
498			    append result "\#\# Canvas $w items\n"
499			}
500			## Output canvas items in numerical order
501			foreach i [lsort -integer [$w find all]] {
502			    append result "\#\# Canvas item $i\n" \
503				    "$w create [$w type $i] [$w coords $i]"
504			    foreach c [$w itemconfigure $i] {
505				if {[llength $c] != 5} continue
506				if {$opts(-default) || [string compare \
507					[lindex $c 3] [lindex $c 4]]} {
508				    append result " \\\n\t[list [lindex $c 0]\
509					    [lindex $c 4]]"
510				}
511			    }
512			    append result \n
513			}
514		    }
515		}
516	    }
517	} elseif {!$opts(-nocomplain)} {
518	    append result "\#\# No known widget $arg\n"
519	    set code error
520	}
521    }
522    return -code $code [string trimright $result \n]
523}
524
525# dump_text --
526#
527#   ADD COMMENTS HERE
528#
529# Arguments:
530#   args	comments
531# Results:
532#   Returns ...
533#
534proc dump_text {args} {
535    if {[string match {} [info command winfo]]} {
536	return -code error "winfo not present, cannot dump widgets"
537    }
538    array set opts {
539	-nocomplain 0 -default 0 -configure 0 -start 1.0 -end end
540    }
541    set args [get_opts opts $args {-nocomplain 0 -default 0 \
542	    -configure 0 -start 1 -end 1}]
543    if {[string match {} $args]} {
544	if {$opts(-nocomplain)} {
545	    return
546	} else {
547	    return -code error "wrong \# args: dump text ?-nocomplain?\
548		    ?-configure? ?-default? ?-filter regexp? ?--? pattern\
549		    ?pattern ...?"
550	}
551    }
552    set code ok
553    set result {}
554    foreach arg $args {
555	if {[string compare {} [set ws [info command $arg]]]} {
556	    foreach w [lsort $ws] {
557		if {[winfo exists $w]} {
558		    if {[string compare Text [winfo class $w]]} {
559			append result "\#\# Widget $w is not a text widget"
560			if {!$opts(-nocomplain)} {
561			    set code error
562			}
563		    } else {
564			if {$opts(-configure)} {
565			    append result [dump_widget -filter $opts(-filter) \
566				    [expr {$opts(-default)?{-default}:{-no}}] \
567				    $w]
568			    append result \n
569			} else {
570			    append result "\#\# Text $w dump\n"
571			}
572			catch {unset tags}
573			catch {unset marks}
574			set text {}
575			foreach {k v i} [$w dump $opts(-start) $opts(-end)] {
576			    switch -exact $k {
577				text {
578				    append text $v
579				}
580				window {
581				    # must do something with windows
582				    # will require extra options to determine
583				    # whether to rebuild the window or to
584				    # just reference it
585				    append result "#[list $w] window create\
586					    $i [$w window configure $i]\n"
587				}
588				mark {set marks($v) $i}
589				tagon {lappend tags($v) $i}
590				tagoff {lappend tags($v) $i}
591				default {
592				    error "[info level 0]:\
593					    should not be in this switch arm"
594				}
595			    }
596			}
597			append result "[list $w insert $opts(-start) $text]\n"
598			foreach i [$w tag names] {
599			    append result "[list $w tag configure $i]\
600				    [$w tag configure $i]\n"
601			    if {[info exists tags($i)]} {
602				append result "[list $w tag add $i]\
603					$tags($i)\n"
604			    }
605			    foreach seq [$w tag bind $i] {
606				append result "[list $w tag bind $i $seq \
607					[$w tag bind $i $seq]]\n"
608			    }
609			}
610			foreach i [array names marks] {
611			    append result "[list $w mark set $i $marks($i)]\n"
612			}
613		    }
614		}
615	    }
616	} elseif {!$opts(-nocomplain)} {
617	    append result "\#\# No known widget $arg\n"
618	    set code error
619	}
620    }
621    return -code $code [string trimright $result \n]
622}
623
624# dump_interface -- NOT FUNCTIONAL
625#
626#   the end-all-be-all of Tk dump commands.  This should dump the widgets
627#   of an interface with all the geometry management.
628#
629# Arguments:
630#   args	comments
631# Results:
632#   Returns ...
633#
634proc dump_interface {args} {
635
636}
637
638# dump_state --
639#
640#   This dumps the state of an interpreter.  This is primarily a wrapper
641#   around other dump commands with special options.
642#
643# Arguments:
644#   args	comments
645# Results:
646#   Returns ...
647#
648proc dump_state {args} {
649
650}
651
652
653## Force the parent namespace to include the exported commands
654##
655catch {namespace eval ::Utility namespace import -force ::Utility::dump::*}
656
657}; # end of namespace ::Utility::dump
658
659return