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