From dce5a36622f7789681bb8a42b2f90d454e56ca6b Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Thu, 14 Mar 2002 23:40:29 +0000 Subject: [PATCH] Updated the incr Tcl support to cope with itcl 3.2 Added help file for the classes window. Fixed font error in the command window. Fixed the About help dialog. Hitched the version patchlevel. --- ChangeLog | 15 ++- Classes.html | 26 +++++ WhatsNew.html | 134 +++++++++++++------------ about.tcl | 7 +- classes_list.tcl | 253 +++++++++++++++++++++++++++++++---------------- cmdline.tcl | 4 +- help.tcl | 2 +- objects_list.tcl | 86 +++++++++++++++- tkinspect.tcl | 7 +- version.tcl | 10 +- 10 files changed, 384 insertions(+), 160 deletions(-) create mode 100644 Classes.html diff --git a/ChangeLog b/ChangeLog index bd3650f..29ab3aa 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,17 @@ -Fri Mar 1 23:37:21 2002 Pat Thoyts +Thu Mar 14 12:09:24 2002 Pat Thoyts + + * classes_list.tcl: Updated to support itcl 3.2 info syntax + * objects_list.tcl: Updated to support itcl 3.2 info syntax + * Classes.html: new page to describe the classes list window. + * tkinspect.tcl: fixed the About help menu item. + * version.tcl: incremented version to p6. + +Fri Mar 2 00:13:08 2002 Pat Thoyts + + * tkinspect: applied T. Schotanus incr Tcl support patch. This + provides itcl support for older (pre 3.x?) itcl versions. + +Fri Mar 1 23:37:21 2002 Pat Thoyts * tkinspect: applied John LoVerso's 1996 comm patch to support systems without the Tk send command. diff --git a/Classes.html b/Classes.html new file mode 100644 index 0000000..d9c61c8 --- /dev/null +++ b/Classes.html @@ -0,0 +1,26 @@ + + + + Classes List + + + + +

Classes List

+ +

The Classes List contains a list of the incr Tcl classes + defined in the target application.

+ +

The display uses the incr Tcl info command to reconstruct the + class definition showing the member variable definitions and the class + method code. Only the itcl builtin methods are hidden (these + include the cget, configure and info methods).

+ +

+ + +Last modified: Thu Mar 14 23:16:22 GMT 2002 + + + + diff --git a/WhatsNew.html b/WhatsNew.html index 384dd73..df3d7ae 100644 --- a/WhatsNew.html +++ b/WhatsNew.html @@ -1,66 +1,78 @@ - -What's New? - - + + + + What's New? + + - -

What's New?

+ +

What's New?

-See the ChangeLog for more details. + See the ChangeLog for more details. + +

Changes in release 5.1.6p6 (14 Mar 2002)

+ + The original code plus some patches have been collected together and + added to the tkcon + project as SourceForge. Some + general work has been done to bring tkinspect up to date for use with + Tcl 8.3 and 8.4 and incr Tcl 3.2. + +

Changes in release 5.1.6 (23 June 1995)

+ + 5.1.6 has only 2 bug fixes, see the + ChangeLog if you're really interested. + +

Changes in release 5.1.4 (21 June 1995)

+ + 5.1.4 adds more browsing lists, and has a few refinements. + +

Added 3 new lists: images, + menus, and + canvases. The images + list was contributed by Gero Kohnert + <gero@marvin.franken.de>. +
Added button-3 bindings on lists and value (brings + up menu.) +
Added Update This List menu item to lists. +
Cleaned up some things for Tk 4.0b4. +
Renamed the interface function + tkinspect_value_text_window to + tkinspect_value_text_widget (now returns the Tk text + widget.) Added tkinspect_display_image, + tkinspect_show_list, and tkinspect_remove_list. +

Changes in release 5.1.6 (23 June 1995)

- -5.1.6 has only 2 bug fixes, see the ChangeLog if you're really interested. - -

Changes in release 5.1.4 (21 June 1995)

- -5.1.4 adds more browsing lists, and has a few refinements. - -

Added 3 new lists: images, menus, and canvases. The images - list was contributed by Gero Kohnert - <gero@marvin.franken.de>. -
Added button-3 bindings on lists and value (brings - up menu.) -
Added Update This List menu item to lists. -
Cleaned up some things for Tk 4.0b4. -
Renamed the interface function - tkinspect_value_text_window to - tkinspect_value_text_widget (now returns the Tk text - widget.) Added tkinspect_display_image, - tkinspect_show_list, and tkinspect_remove_list. -

- -

Changes in release 5.1 (5 June 1995)

- -5.1 fills in the missing holes of 5.0, fixes a few bugs, and adds some -features. - -

Fixed the bug (?) that caused no interpreters to show up under - Tk 4.0b3. -
Added this HTML help system (renderer based on code from Angel Li - <angel@flipper.rsmas.miami.edu>.) -
Added the command line interface. -
Cleaned up the menus, added some keyboard bindings. -
tkinspect nows reads ~/.tkinspect_opts and - .tkinspect_init (in the current directory.) -
There's an external interface available. See the miscellany help page. - -

- - -

Changes in release 5.0 (February 1995)

- -Release 5.0 was a complete rewrite of previous versions of -tkinspect. This version runs only with Tk 4.0. - -

Changes in release 5.1 (5 June 1995)

+ + 5.1 fills in the missing holes of 5.0, fixes a few bugs, and adds some + features. + +

Fixed the bug (?) that caused no interpreters to show up under + Tk 4.0b3. +
Added this HTML help system (renderer based on code from Angel Li + <angel@flipper.rsmas.miami.edu>.) +
Added the command line interface. +
Cleaned up the menus, added some keyboard bindings. +
tkinspect nows reads ~/.tkinspect_opts and + .tkinspect_init (in the current directory.) +
There's an external interface available. See + the miscellany help page. + +

+ + +

Changes in release 5.0 (February 1995)

+ + Release 5.0 was a complete rewrite of previous versions of + tkinspect. This version runs only with Tk 4.0. + +

-Last modified: Fri Jun 23 01:10:55 1995 +Last modified: Thu Mar 14 23:34:01 GMT 2002 - + + + diff --git a/about.tcl b/about.tcl index 381e12f..0411a12 100644 --- a/about.tcl +++ b/about.tcl @@ -7,7 +7,7 @@ dialog about { param obliqueFont -*-helvetica-medium-o-*-*-12-* Font param font -*-helvetica-medium-r-*-*-12-* Font - param boldFont -*-helvetica-bold-r-*-*-18-* Font + param boldFont -*-helvetica-bold-r-*-*-18-* Font method create {} { global tkinspect tkinspect_library wm withdraw $self @@ -17,10 +17,11 @@ dialog about { label $self.ver \ -text "Release $tkinspect(release) ($tkinspect(release_date))" \ -font $slot(font) - label $self.com -text "Send comments, suggestions, bugs to:" \ + label $self.com -text "\nBugs, suggestions and patches to:\n\ + http://sourceforge.net/projects/tkcon/\n" \ -font $slot(obliqueFont) frame $self.mug -bd 4 - label $self.mug.l -text "Sam Shen " + label $self.mug.l -text "Originally by\nSam Shen " global about_priv if ![info exists about_priv(mug_image)] { set about_priv(mug_image) \ diff --git a/classes_list.tcl b/classes_list.tcl index 8fba400..17bf8c1 100644 --- a/classes_list.tcl +++ b/classes_list.tcl @@ -5,99 +5,182 @@ # E-mail: sst@bouw.tno.nl # URL: http://huizen.dds.nl/~quintess # +# Itcl 3.2 support by Pat Thoyts +# The original code is renamed to base_class_list and if a newer +# version of incr Tcl is found then we shall override some methods. +# -widget class_list { - object_include tkinspect_list - param title "Classes" - - method get_item_name {} { - return class - } +widget base_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 + } +} - method update {target} { - $self clear - set classes [lsort [send $target itcl_info classes]] - foreach class $classes { - $self append $class - } - } +# ------------------------------------------------------------------------- +# Handle new versions of incr Tcl +# ------------------------------------------------------------------------- - method retrieve {target class} { - set res "itcl_class $class {\n" +if {[catch {package versions Itcl} itcl_version]} { + set itcl_version 0 +} - 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" - } +if {$itcl_version < 3.2} { - 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" - } + # Older incr Tcl versions - 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" - } + widget class_list { + object_include tkinspect_list + object_include base_class_list + } - 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" - } +} else { - 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" - } - } - } + # incr Tcl 3.2+ - 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" - } - } - } + widget class_list { + object_include tkinspect_list + object_include base_class_list + + method retrieve {target class} { + set res "itcl::class $class {\n" + + set cmd [list namespace eval $class {info inherit}] + set inh [send $target $cmd] + if {$inh != ""} { + append res " inherit $inh\n\n" + } else { + append res "\n" + } + + set vars [send $target namespace eval $class {info variable}] + foreach var $vars { + set name [namespace tail $var] + set cmd [list namespace eval $class \ + [list info variable $name -protection -type -name -init]] + set text [send $target $cmd] + append res " $text\n" + } + append res "\n" + + + set funcs [send $target [list namespace eval $class {info function}]] + foreach func [lsort $funcs] { + set qualclass "::[string trimleft $class :]" + if {[string first $qualclass $func] == 0} { + set name [namespace tail $func] + set cmd [list namespace eval $class [list info function $name]] + set text [send $target $cmd] - set res "$res}\n" - return $res - } + if {![string match "@itcl-builtin*" [lindex $text 4]]} { + switch -exact -- $name { + constructor { + append res " $name [lrange $text 3 end]\n" + } + destructor { + append res " $name [lrange $text 4 end]\n" + } + default { + append res " [lindex $text 0] [lindex $text 1] $name\ + [lrange $text 3 end]\n" + } + } + } + } + } + + append res "}\n" + return $res + } + } - method send_filter {value} { - return $value - } -} +} \ No newline at end of file diff --git a/cmdline.tcl b/cmdline.tcl index b401733..ae86b58 100644 --- a/cmdline.tcl +++ b/cmdline.tcl @@ -4,6 +4,7 @@ # Provide a command line interface to an application (much of the # code is lifted out of the Tk demo rmt). # +# [PT]: this should be replaced by tkcon... dialog command_line { param main @@ -89,7 +90,8 @@ dialog command_line { } bind $self.t "command_line:text_insert $self %A; break" $self.t tag configure bold \ - -font -*-Courier-Bold-R-Normal-*-120-*-*-*-*-*-* + -font {Courier 12 bold} + #-font -*-Courier-Bold-R-Normal-*-120-*-*-*-*-*-* $self prompt } method destroy {} { diff --git a/help.tcl b/help.tcl index dd1550e..d7a1380 100644 --- a/help.tcl +++ b/help.tcl @@ -4,7 +4,7 @@ dialog help_window { param topics {} - param width 50 + param width 100 param height 35 param helpdir . member history {} diff --git a/objects_list.tcl b/objects_list.tcl index 08668e0..9676ceb 100644 --- a/objects_list.tcl +++ b/objects_list.tcl @@ -5,8 +5,12 @@ # E-mail: sst@bouw.tno.nl # URL: http://huizen.dds.nl/~quintess # +# Itcl 3.2 support by Pat Thoyts +# The original code is renamed to base_class_list and if a newer +# version of incr Tcl is found then we shall override some methods. +# -widget object_list { +widget base_object_list { object_include tkinspect_list param title "Objects" @@ -107,3 +111,83 @@ widget object_list { return $value } } + +# ------------------------------------------------------------------------- +# Handle new versions of incr Tcl +# ------------------------------------------------------------------------- + +if {[catch {package versions Itcl} itcl_version]} { + set itcl_version 0 +} + +if {$itcl_version < 3.2} { + + # Older incr Tcl versions + + widget object_list { + object_include tkinspect_list + object_include base_object_list + } + +} else { + + # incr Tcl 3.2+ + + widget object_list { + object_include tkinspect_list + object_include base_object_list + + method retrieve {target object} { + set class [send $target [list $object info class]] + set res "$class $object {\n" + + set cmd [list $object info inherit] + set inh [send $target $cmd] + if {$inh != ""} { + append res " inherit $inh\n\n" + } else { + append res "\n" + } + + set vars [send $target $object info variable] + foreach var $vars { + set name [namespace tail $var] + set cmd [list $object info variable $name] + set text [send $target $cmd] + append res " $text\n" + } + append res "\n" + + + set funcs [send $target [list $object info function]] + foreach func [lsort $funcs] { + set qualclass "::[string trimleft $class :]" + if {[string first $qualclass $func] == 0} { + set name [namespace tail $func] + set cmd [list $object info function $name] + set text [send $target $cmd] + + if {![string match "@itcl-builtin*" [lindex $text 4]]} { + switch -exact -- $name { + constructor { + append res " $name [lrange $text 3 end]\n" + } + destructor { + append res " $name [lrange $text 4 end]\n" + } + default { + append res " [lindex $text 0] [lindex $text 1] $name\ + [lrange $text 3 end]\n" + } + } + } + } + } + + append res "}\n" + return $res + } + + } + +} \ No newline at end of file diff --git a/tkinspect.tcl b/tkinspect.tcl index 9fc6083..4f35552 100644 --- a/tkinspect.tcl +++ b/tkinspect.tcl @@ -25,7 +25,7 @@ set tkinspect(list_class_files) { } set tkinspect(help_topics) { Intro Value Lists Procs Globals Windows Images Canvases Menus - Value Miscellany Notes WhatsNew ChangeLog + Classes Value Miscellany Notes WhatsNew ChangeLog } if {[info commands itcl_info] != ""} { @@ -81,9 +81,10 @@ proc tkinspect_widgets_init {} { } } -proc tkinspect_about {} { +proc tkinspect_about {parent} { catch {destroy .about} about .about + wm transient .about $parent .about run } @@ -132,7 +133,7 @@ dialog tkinspect_main { -underline 0 pack $self.menu.help -side right set m [menu $self.menu.help.m] - $m add command -label "About..." -command tkinspect_about \ + $m add command -label "About..." -command [list tkinspect_about $self]\ -underline 0 foreach topic $tkinspect(help_topics) { $m add command -label $topic -command [list $self help $topic] \ diff --git a/version.tcl b/version.tcl index 42fcd45..05e47ae 100644 --- a/version.tcl +++ b/version.tcl @@ -6,17 +6,19 @@ proc version_init {} { global tkinspect tk_version tk_patchLevel - set tkinspect(release) 5.1.6p3 - set tkinspect(release_date) "Nov 23, 1997" + set tkinspect(release) 5.1.6p6 + set tkinspect(release_date) "14 Mar 2002" scan $tk_version "%d.%d" major minor if {$major < 8} { puts stderr \ - "tkinspect-5.1.6.p3 requires Tk 8.x, you appear to be running Tk $major.$minor" + "tkinspect-$tkinspect(release) requires Tk 8.x,\ + you appear to be running Tk $major.$minor" exit 1 } if {[scan $tk_patchLevel "4.0b%d" beta] == 1 && $beta < 4} { tk_dialog .warning "Warning!" \ -"tkinspect-$tkinspect(release) has only been tested on 4.0b4. You might have problems running on $tk_patchLevel." warning 0 Ok + "tkinspect-$tkinspect(release) has only been tested on 4.0b4.\ + You might have problems running on $tk_patchLevel." warning 0 Ok } } -- 2.23.0