Bug #533899: Found and merged Paul Healy's 1997 p4 patch which adds a 'namespaces...
authorPat Thoyts <patthoyts@users.sourceforge.net>
Tue, 26 Mar 2002 00:10:17 +0000 (00:10 +0000)
committerPat Thoyts <patthoyts@users.sourceforge.net>
Tue, 26 Mar 2002 00:10:17 +0000 (00:10 +0000)
Improved the incr Tcl support in classes_list.tcl and objects_list.tcl
Updated the README file.

ChangeLog
README
about.tcl
afters_list.tcl [new file with mode: 0644]
classes_list.tcl
globals_list.tcl
install.tcl
names.tcl
namespaces_list.tcl [new file with mode: 0644]
objects_list.tcl
tkinspect.tcl

index 095f44a67ea2a716f0f04f06bf995eea0eb783a8..92486f31ddafc807ff4cb3fca774cce96c387f26 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+Mon Mar 25 12:05:22 2002  Pat Thoyts <patthoyts@users.sourceforge.net>
+
+       * Bug #533899: Found and merged Paul Healy's 1997 p4 patch which adds
+       a 'namespaces' and an 'after' viewer. Comments from the patch:
+         - fix the `Value:' history menu so that it respects changes to target
+           interpreters. The `clear' method is broken?
+         - snapshot afters so that you (nearly would) always to get to see the
+           scripts associated with an after id at a particular time. Also make
+           the afters menu more meaningful.
+       * classes_list.tcl:
+       * objects_list.tcl: Improved the incr Tcl support.
+       * README: modernised the README file.
+
 Sun Mar 24 23:50:29 2002  Pat Thoyts <patthoyts@users.sourceforge.net>
        
        * Bug #533899: gracefully handle unavailable 'comm' package
diff --git a/README b/README
index baa0cf18e96cbe2b93f5b90882d0874adfd6863f..72e21867230b1e01a07d889bcf1164c28475a5e8 100644 (file)
--- a/README
+++ b/README
@@ -1,27 +1,28 @@
-                       tkinspect, release 5.1.6
-                           (June 23, 1995)
+                       tkinspect, release 5.1.6p7
+                           (22 Mar 2002)
 
-This is the 5th release of my browser for Tk programs.  This version
-of tkinspect requires Tk 4.0 or better (tested only with Tk 4.0b4,
-and things will probably fail on previous betas).
-
-To install: type "wish4.0 install.tcl", fill out the form, and hit the
-install button.
+Tkinspect is a Tk program browser originally written by Sam Shen and
+now updated to work with Tcl/Tk 8+, incr Tcl 3+ and to cope with
+systems such as MS Windows where the Tk 'send' command is not
+available. Based upon the 5.1.6 release of tkinspect this version
+contains numerous bug fixes and functionality patches. See the
+ChangeLog file for details.
 
 tkinspect should be pretty easy to use, hopefully you can learn how to
 use it by selecting an interpreter (via the File, Select Interpreter
 menu item) and then clicking on things.  There is also an online help
 system.
 
+tkinspect may either be run in-place (by wish tkinspect.tcl) or can be
+installed using the install program (wish install.tcl). Fill out the
+form, and hit the install button.
+
 tkinspect itself is public domain, you may do whatever you want with
 it.  However, tkinspect uses a hacked down library that I've written
 at LBL, so the files in stl-lite are copyright 1995 Lawrence Berkeley
-Lab.  See stl-lite/COPYRIGHT for the full copyright notice.  (STL will
-soon be renamed to SNTL to avoid conflicting with the C++ template
-library.)
-
-Please send me any comments or suggestions you might have, along with
-any bugs that you may encounter.
+Lab.  See stl-lite/COPYRIGHT for the full copyright notice.
 
-       -Sam Shen
-       SLShen@lbl.gov
+This release is maintained at SourceForge as a module of the tkcon
+project. See http://sourceforge.net/projects/tkcon for the project
+information and http://tkcon.sourceforge.net/tkinspect/ for the
+documentation.
index 0411a1271ca3504cf95b795a0253a281b9c2286c..373f67a2d30157ff6e0b8048ecff50ea76b13f84 100644 (file)
--- a/about.tcl
+++ b/about.tcl
@@ -17,8 +17,8 @@ dialog about {
        label $self.ver \
            -text "Release $tkinspect(release) ($tkinspect(release_date))" \
            -font $slot(font)
-       label $self.com -text "\nBugs, suggestions and patches to:\n\
-                      http://sourceforge.net/projects/tkcon/\n" \
+       label $self.com -text "\n Bugs, suggestions and patches to:\n\
+                      http://sourceforge.net/projects/tkcon/ \n" \
            -font $slot(obliqueFont)
        frame $self.mug -bd 4
        label $self.mug.l -text "Originally by\nSam Shen <slshen@lbl.gov>"
diff --git a/afters_list.tcl b/afters_list.tcl
new file mode 100644 (file)
index 0000000..12e7769
--- /dev/null
@@ -0,0 +1,39 @@
+# afters_list.tcl - Originally written by Paul Healy <ei9gl@indigo.ie>
+#
+# $Id$
+
+widget afters_list {
+    object_include tkinspect_list
+    param title "Afters"
+    method get_item_name {} { return after }
+    method update {target} {
+       $self clear
+       foreach after [lsort [send $target after info]] {
+           $self append $after
+       }
+    }
+    method retrieve {target after} {
+        set cmd [list after info $after]
+        set retcode [catch [list send $target $cmd] msg]
+        if {$retcode != 0} {
+            set result "Error: $msg\n"
+        } elseif {$msg != ""} {
+            set script [lindex $msg 0]
+            set type [lindex $msg 1]
+            set result "# after type=$type\n"
+            # there is no way to get even an indication of when a timer will
+            # expire. tcl should be patched to optionally return this.
+            switch $type {
+                idle  {append result "after idle $script\n"}
+                timer {append result "after ms $script\n"}
+                default {append result "after $type $script\n"}
+            }
+        } else {
+            set result "Error: empty after $after?\n"
+        }
+       return $result
+    }
+    method send_filter {value} {
+       return $value
+    }
+}
index 17bf8c192df347de0cb7e2efa0606e3f53f0a89c..b43d9cb182e8c222941097d548b02ed9fc49e233 100644 (file)
@@ -6,13 +6,14 @@
 # URL:        http://huizen.dds.nl/~quintess
 #
 # Itcl 3.2 support by Pat Thoyts <patthoyts@users.sourceforge.net>
-#   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.
+#   We are hanging onto the older code to support old versions although
+#   this needs testing.
 #
 
-widget base_class_list {
+widget class_list {
     object_include tkinspect_list
     param title "Classes"
+    param itcl_version 0
     
     method get_item_name {} {
         return class
@@ -20,13 +21,28 @@ widget base_class_list {
     
     method update {target} {
         $self clear
-        set classes [lsort [send $target itcl_info classes]]
+        # Need info on older itcl version to do this properly.
+        set cmd [list if {[info command itcl_info] != {}} {itcl_info classes}]
+        set classes [lsort [send $target $cmd]]
+        if {$classes != {}} {
+            set slot(itcl_version) [send $target package provide Itcl]
+        }
         foreach class $classes {
             $self append $class
         }
     }
     
     method retrieve {target class} {
+        if {$slot(itcl_version) != {}} {
+            if {$slot(itcl_version) >= 3} {
+                return [$self retrieve_new $target $class]
+            } else {
+                return [$self retrieve_old $target $class]
+            }
+        }
+    }
+
+    method retrieve_old {target class} {
         set res "itcl_class $class {\n"
         
         set cmd [list $class :: info inherit]
@@ -101,86 +117,58 @@ widget base_class_list {
         return $res
     }
     
-    method send_filter {value} {
-        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 class_list {
-        object_include tkinspect_list
-        object_include base_class_list
-    }
-
-} else {
-
-    # incr Tcl 3.2+
-
-    widget class_list {
-        object_include tkinspect_list
-        object_include base_class_list
+    method retrieve_new {target class} {
+        set res "itcl::class $class {\n"
         
-        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"
-            }
+        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 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]
-
-                    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\
+        }
+        
+        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]
+                
+                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
         }
+        
+        append res "}\n"
+        return $res
     }
 
-}
\ No newline at end of file
+    method send_filter {value} {
+        return $value
+    }
+}
index 229ae140d53c7559d5f3b4cb94a0fdce74f2dc40..85002bb8912570e308a80fcd905c98948d524de9 100644 (file)
@@ -128,7 +128,14 @@ widget globals_list {
     }
     method retrieve {target var} {
        if ![send $target [list array exists $var]] {
-           return [list set $var [send $target [list set $var]]]
+           #return [list set $var [send $target [list set $var]]]
+            set cmd [list set $var]
+            set retcode [catch [list send $target $cmd] msg]
+            if {$retcode != 0} {
+                return "Info: $var has not been defined\n      ($msg)\n"
+            } else {
+                return [list set $var $msg]
+            }
        }
        set result {}
         set names [lsort [send $target [list array names $var]]]
index e9a1f003790f1d1f0c677d32f9451fec38b5d898..b5ea623d6ddf4aff97c730f5da4abcc5adce8f75 100644 (file)
@@ -197,7 +197,8 @@ proc install {} {
        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 tclIndex ChangeLog
-       names.tcl classes_list.tcl objects_list.tcl
+       names.tcl classes_list.tcl objects_list.tcl 
+        afters_list.tcl namespaces_list.tcl
        Intro.html Lists.html Procs.html Globals.html Windows.html
        Images.html Canvases.html Menus.html Classes.html
        Value.html Miscellany.html Notes.html WhatsNew.html
index 8fe5aa3f71097b4b219f9dd0c4ce68b00789c421..ae65d967eb1e9fcc2ae0d44d527252b3624ca241 100644 (file)
--- a/names.tcl
+++ b/names.tcl
@@ -3,50 +3,94 @@
 #
 
 namespace eval names {
+    
+    namespace export names procs vars prototype value exports
+    
+    proc unqualify s {
+        regsub -all "(^| ):+" $s {\1} result
+        return $result
+    }
+    
+    proc names {target {name ::}} {
+        set result $name
+        foreach n [send $target namespace children $name] {
+            append result " " [names $target $n]
+        }
+        return $result
+    }
+    
+    proc procs {target {names ""}} {
+        if {$names == ""} {
+            set names [names $target]
+        }
+        set result {}
+        foreach n $names {
+            foreach p [send $target namespace eval $n ::info procs] {
+                lappend result "$n\::$p"
+            }
+        }
+        return [unqualify $result]
+    }
+    
+    # pinched from globals_list.tcl
+    proc prototype {target proc} {
+        set result {}
+        set args [send $target [list ::info args $proc]]
+        set defaultvar "__tkinspect:default_arg__"
+        foreach arg $args {
+            if [send $target [list ::info default $proc $arg $defaultvar]] {
+                lappend result [list $arg [send $target [list set $defaultvar]]]
+            } else {
+                lappend result $arg
+            }
+        }
+        
+        send $target catch unset $defaultvar
+        
+        return [list proc [namespace tail $proc] $result {} ]
+    }
+    
+    proc vars {target {names ""}} {
+        if {$names == ""} {
+            set names [names $target]
+        }
+        set result {}
+        foreach n $names {
+            foreach v [send $target ::info vars ${n}::*] {
+                lappend result $v
+            }
+        }
+        return [unqualify $result]
+    }
 
-   namespace export names procs vars
+    proc value {target var} {
+        set tail [namespace tail $var]
+        if [send $target [list array size $var]] {
+            return "variable $tail ; # $var is an array\n" ; # dump it out?
+        }
+        set cmd [list set $var]
+        set retcode [catch [list send $target $cmd] msg]
+        if {$retcode != 0} {
+            return "variable $tail ; # $var not defined\n"
+        } else {
+            return "variable $tail \"$msg\"\n"
+        }
+    }
+    
+    proc exports {target namespace} {
+        set result [send $target namespace eval $namespace ::namespace export]
+        return [unqualify $result]
+    }
 
-   proc unqualify s {
-      regsub -all "(^| ):+" $s {\1} result
-      return $result
-   }
-
-   proc names {target {name ::}} {
-      set result $name
-      foreach n [send $target namespace children $name] {
-         append result " " [names $target $n]
-      }
-      return $result
-   }
-
-   proc procs target {
-      set result {}
-      foreach n [names $target] {
-         foreach p [send $target namespace eval $n ::info procs] {
-            lappend result "$n\::$p"
-         }
-      }
-      return [unqualify $result]
-   }
-
-   proc vars target {
-      set result {}
-      foreach n [names $target] {
-         foreach v [send $target ::info vars ${n}::*] {
-            lappend result $v
-         }
-      }
-      return [unqualify $result]
-   }
-
-# dump [tk appname]
-
-   proc dump appname {
-      puts "names: [names $appname]"
-      puts ""
-      puts "procs: [procs $appname]"
-      puts ""
-      puts "vars: [vars $appname]"
-   }
+    # dump [tk appname]
+    proc dump appname {
+        puts "names: [names $appname]"
+        puts ""
+        puts "procs: [procs $appname]"
+        puts ""
+        puts "vars: [vars $appname]"
+        puts ""
+        puts "exports: [exports $appname"
+    }
 }
 
diff --git a/namespaces_list.tcl b/namespaces_list.tcl
new file mode 100644 (file)
index 0000000..fec8ba3
--- /dev/null
@@ -0,0 +1,59 @@
+# namespaces_list.tcl - Originally written by Paul Healy <ei9gl@indigo.ie>
+#
+# $Id$
+
+widget namespaces_list {
+    object_include tkinspect_list
+    param title "Namespaces"
+    method get_item_name {} { return namespace }
+    method update {target} {
+       $self clear
+        foreach namespace [names::names $target] {
+            $self append $namespace
+        }
+    }
+    method retrieve {target namespace} {
+        set result "namespace eval $namespace {\n"
+        
+        set exports [names::exports $target $namespace]
+        if {$exports!=""} {
+            append result "\n   namespace export $exports\n"
+        }
+        
+        set vars [names::vars $target $namespace]
+        if {$vars!=""} {
+            append result "\n"
+        }
+        foreach var [lsort $vars] {
+            append result "   [names::value $target $var]"
+        }
+
+        set procs [lsort [names::procs $target $namespace]]
+        append result "\n# export:\n"
+        foreach proc $procs {
+            if {[lsearch -exact $exports [namespace tail $proc]]!=-1} {
+                append result "   [names::prototype $target $proc]\n"  
+            }
+        }
+        append result "\n# internal:\n"
+        foreach proc $procs {
+            if {[lsearch -exact $exports [namespace tail $proc]]==-1} {
+                append result "   [names::prototype $target $proc]\n"  
+            }
+        }
+
+        append result "}\n\n"
+
+        set children [names::names $target $namespace]
+        foreach child [lsort $children] {
+            if {$child!=$namespace} {
+                append result "namespace eval $child {}\n"
+            }
+        }
+
+       return $result
+    }
+    method send_filter {value} {
+       return $value
+    }
+}
index 9676ceb1df520fe756721fcc24a9a557e604d42b..0c9ae247fd48bc8515aec85f01ecd64c71364964 100644 (file)
 # URL:        http://huizen.dds.nl/~quintess
 #
 # Itcl 3.2 support by Pat Thoyts <patthoyts@users.sourceforge.net>
-#   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.
+#   We are hanging onto the older code to support old versions although
+#   this needs testing.
 #
 
-widget base_object_list {
-       object_include tkinspect_list
-       param title "Objects"
+widget object_list {
+    object_include tkinspect_list
+    param title "Objects"
+    param itcl_version 0
 
-       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] != "<built-in>"} {
-                                       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] != "<built-in>"} {
-                                       set res "$res\tproc $a [lrange $proc 1 end]\n\n"
-                               }
-                       }
-               }
-
-               set res "$res}\n"
-               return $res
-       }
-
-       method send_filter {value} {
-               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
+    method get_item_name {} {
+        return object
     }
 
-} else {
-
-    # incr Tcl 3.2+
-
-    widget object_list {
-        object_include tkinspect_list
-        object_include base_object_list
+    method update {target} {
+        $self clear
+        set cmd [list if {[info command itcl_info] != {}} {itcl_info objects}]
+        set objects [lsort [send $target $cmd]]
+        if {$objects != {}} {
+            set slot(itcl_version) [send $target package provide Itcl]
+        }
+        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 $object info inherit]
-            set inh [send $target $cmd]
-            if {$inh != ""} {
-                append res "    inherit $inh\n\n"
+    method retrieve {target object} {
+        if {$slot(itcl_version) != {}} {
+            if {$slot(itcl_version) >= 3} {
+                return [$self retrieve_new $target $object]
             } else {
-                append res "\n"
+                return [$self retrieve_old $target $object]
             }
-            
-            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"
+        }
+    }
+
+    method retrieve_old {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] != "<built-in>"} {
+                    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] != "<built-in>"} {
+                    set res "$res\tproc $a [lrange $proc 1 end]\n\n"
+                }
             }
+        }
+        
+        set res "$res}\n"
+        return $res
+    }
+    
+    method retrieve_new {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 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\
+        }
+        
+        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
         }
-
+        
+        append res "}\n"
+        return $res
     }
-
-}
\ No newline at end of file
+    
+    method send_filter {value} {
+        return $value
+    }
+}
index 80d51e38d2e568f3d32e77dda79a101dd4b9bffa..ac73632814708922d0d6fd323074992af06a8ce3 100644 (file)
@@ -9,20 +9,22 @@ set tkinspect(title) "Tkinspect"
 set tkinspect(counter) -1
 set tkinspect(main_window_count) 0
 set tkinspect(list_classes) {
+    "namespaces_list Namespaces"
     "procs_list Procs"
     "globals_list Globals"
+    "class_list Classes"
+    "object_list Objects"
     "windows_list Windows"
     "images_list Images"
     "menus_list Menus"
     "canvas_list Canvases"
-    "class_list Classes"
-    "object_list Objects"
+    "afters_list Afters"
 }
 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
+    objects_list.tcl names.tcl afters_list.tcl namespaces_list.tcl
 }
 set tkinspect(help_topics) {
     Intro Value Lists Procs Globals Windows Images Canvases Menus
@@ -32,7 +34,7 @@ set tkinspect(help_topics) {
 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"
+       set tkinspect(default_lists) "namespaces_list procs_list globals_list"
 }
 
 wm withdraw .