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