From b75f2d28a3b730824d17d808966653fb71ce32dd Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Sun, 3 Mar 2002 23:44:53 +0000 Subject: [PATCH] Applied the incr Tcl patch from Tako Schotanus (1995) --- classes_list.tcl | 103 ++++++++++++++++++++++++++++++++++++++++++++ install.tcl | 3 +- objects_list.tcl | 109 +++++++++++++++++++++++++++++++++++++++++++++++ tkinspect.tcl | 26 ++++++++--- 4 files changed, 233 insertions(+), 8 deletions(-) create mode 100644 classes_list.tcl create mode 100644 objects_list.tcl diff --git a/classes_list.tcl b/classes_list.tcl new file mode 100644 index 0000000..8fba400 --- /dev/null +++ b/classes_list.tcl @@ -0,0 +1,103 @@ +# +# $Id$ +# +# Written by: T. Schotanus +# E-mail: sst@bouw.tno.nl +# URL: http://huizen.dds.nl/~quintess +# + +widget class_list { + object_include tkinspect_list + param title "Classes" + + method get_item_name {} { + return class + } + + method update {target} { + $self clear + set classes [lsort [send $target itcl_info classes]] + foreach class $classes { + $self append $class + } + } + + method retrieve {target class} { + set res "itcl_class $class {\n" + + set cmd [list $class :: info inherit] + set inh [send $target $cmd] + if {$inh != ""} { + set res "$res\tinherit $inh\n\n" + } else { + set res "$res\n" + } + + set pubs [send $target [list $class :: info public]] + foreach arg $pubs { + regsub {(.*)::} $arg {} a + set res "$res\tpublic $a\n" + } + if {$pubs != ""} { + set res "$res\n" + } + + set prots [send $target [list $class :: info protected]] + foreach arg $prots { + regsub {(.*)::} $arg {} a + if {$a != "this"} { + set res "$res\tprotected $a\n" + } + } + if {$prots != ""} { + set res "$res\n" + } + + set coms [send $target [list $class :: info common]] + foreach arg $coms { + regsub {(.*)::} $arg {} a + set cmd [list $class :: info common $a] + set com [send $target $cmd] + set res "$res\tcommon $a [list [lindex $com 2]] (default: [list [lindex $com 1]])\n" + } + if {$coms != ""} { + set res "$res\n" + } + + set meths [send $target [list $class :: info method]] + foreach arg $meths { + if {[string first $class $arg] == 0} { + regsub {(.*)::} $arg {} a + set cmd [list $class :: info method $a] + set meth [send $target $cmd] + if {$a != "constructor" && $a != "destructor"} { + set nm "method " + } else { + set nm "" + } + if {[lindex $meth 1] != ""} { + set res "$res\t$nm$a [lrange $meth 1 end]\n\n" + } + } + } + + set procs [send $target [list $class :: info proc]] + foreach arg $procs { + if {[string first $class $arg] == 0} { + regsub {(.*)::} $arg {} a + set cmd [list $class :: info proc $a] + set proc [send $target $cmd] + if {[lindex $proc 1] != ""} { + set res "$res\tproc $a [lrange $proc 1 end]\n\n" + } + } + } + + set res "$res}\n" + return $res + } + + method send_filter {value} { + return $value + } +} diff --git a/install.tcl b/install.tcl index 9bb0b27..c5c70ff 100644 --- a/install.tcl +++ b/install.tcl @@ -173,7 +173,8 @@ proc install {} { about.tcl defaults.tcl windows_info.tcl lists.tcl globals_list.tcl procs_list.tcl windows_list.tcl images_list.tcl menus_list.tcl canvas_list.tcl value.tcl stl.tcl sls.ppm version.tcl help.tcl - cmdline.tcl interface.tcl names.tcl tclIndex + cmdline.tcl interface.tcl tclIndex + names.tcl classes_list.tcl objects_list.tcl Intro.html Lists.html Procs.html Globals.html Windows.html Images.html Canvases.html Menus.html Value.html Miscellany.html Notes.html WhatsNew.html ChangeLog.html diff --git a/objects_list.tcl b/objects_list.tcl new file mode 100644 index 0000000..08668e0 --- /dev/null +++ b/objects_list.tcl @@ -0,0 +1,109 @@ +# +# $Id$ +# +# Written by: T. Schotanus +# E-mail: sst@bouw.tno.nl +# URL: http://huizen.dds.nl/~quintess +# + +widget object_list { + object_include tkinspect_list + param title "Objects" + + method get_item_name {} { + return object + } + + method update {target} { + $self clear + set objects [lsort [send $target itcl_info objects]] + foreach object $objects { + $self append $object + } + } + + method retrieve {target object} { + set class [send $target [list $object info class]] + set res "$class $object {\n" + + set cmd [list $class :: info inherit] + set inh [send $target $cmd] + if {$inh != ""} { + set res "$res\tinherit $inh\n\n" + } else { + set res "$res\n" + } + + set pubs [send $target [list $object info public]] + foreach arg $pubs { + regsub {(.*)::} $arg {} a + set cmd [list $object info public $a] + set pub [send $target $cmd] + set res "$res\tpublic $a [list [lindex $pub 2] [lindex $pub 3]] (default: [list [lindex $pub 1]])\n" + } + if {$pubs != ""} { + set res "$res\n" + } + + set prots [send $target [list $object info protected]] + foreach arg $prots { + regsub {(.*)::} $arg {} a + if {$a == "this"} { + continue + } + set cmd [list $object info protected $a] + set prot [send $target $cmd] + set res "$res\tprotected $a [list [lindex $prot 2]] (default: [list [lindex $prot 1]])\n" + } + if {$prots != ""} { + set res "$res\n" + } + + set coms [send $target [list $object info common]] + foreach arg $coms { + regsub {(.*)::} $arg {} a + set cmd [list $object info common $a] + set com [send $target $cmd] + set res "$res\tcommon $a [list [lindex $com 2]] (default: [list [lindex $com 1]])\n" + } + if {$coms != ""} { + set res "$res\n" + } + + set meths [send $target [list $object info method]] + foreach arg $meths { + if {[string first $class $arg] == 0} { + regsub {(.*)::} $arg {} a + set cmd [list $object info method $a] + set meth [send $target $cmd] + if {$a != "constructor" && $a != "destructor"} { + set nm "method " + } else { + set nm "" + } + if {[lindex $meth 1] != ""} { + set res "$res\t$nm$a [lrange $meth 1 end]\n\n" + } + } + } + + set procs [send $target [list $object info proc]] + foreach arg $procs { + if {[string first $class $arg] == 0} { + regsub {(.*)::} $arg {} a + set cmd [list $object info proc $a] + set proc [send $target $cmd] + if {[lindex $proc 1] != ""} { + set res "$res\tproc $a [lrange $proc 1 end]\n\n" + } + } + } + + set res "$res}\n" + return $res + } + + method send_filter {value} { + return $value + } +} diff --git a/tkinspect.tcl b/tkinspect.tcl index a903e6e..9fc6083 100644 --- a/tkinspect.tcl +++ b/tkinspect.tcl @@ -14,12 +14,26 @@ set tkinspect(list_classes) { "images_list Images" "menus_list Menus" "canvas_list Canvases" + "class_list Classes" + "object_list Objects" +} +set tkinspect(list_class_files) { + lists.tcl procs_list.tcl globals_list.tcl windows_list.tcl + images_list.tcl about.tcl value.tcl help.tcl cmdline.tcl + windows_info.tcl menus_list.tcl canvas_list.tcl classes_list.tcl + objects_list.tcl names.tcl } set tkinspect(help_topics) { Intro Value Lists Procs Globals Windows Images Canvases Menus Value Miscellany Notes WhatsNew ChangeLog } +if {[info commands itcl_info] != ""} { + set tkinspect(default_lists) "object_list procs_list globals_list windows_list" +} else { + set tkinspect(default_lists) "procs_list globals_list windows_list" +} + wm withdraw . if [file exists @tkinspect_library@/tclIndex] { @@ -60,11 +74,9 @@ proc tkinspect_exit {} { proc tkinspect_widgets_init {} { global tkinspect_library - foreach file { - lists.tcl procs_list.tcl globals_list.tcl windows_list.tcl - images_list.tcl about.tcl value.tcl help.tcl cmdline.tcl - windows_info.tcl menus_list.tcl canvas_list.tcl names.tcl - } { + global tkinspect + + foreach file $tkinspect(list_class_files) { uplevel #0 source $tkinspect_library/$file } } @@ -76,7 +88,6 @@ proc tkinspect_about {} { } dialog tkinspect_main { - param default_lists "procs_list globals_list windows_list" param target "" member last_list {} member lists "" @@ -141,7 +152,7 @@ dialog tkinspect_main { pack [frame $self.lists -bd 0] -side top -fill both value $self.value -main $self pack $self.value -side top -fill both -expand 1 - foreach list_class $slot(default_lists) { + foreach list_class $tkinspect(default_lists) { $self add_list $list_class set slot(${list_class}_is_on) 1 } @@ -360,3 +371,4 @@ dialog connect_interp { $slot(value) set_target $text } } + -- 2.23.0