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