├── sls.ppm ├── .editorconfig ├── dot.tkinspect_init ├── stl.tcl ├── Menus.html ├── Canvases.html ├── Procs.html ├── Images.html ├── defaults.tcl ├── version.tcl ├── Classes.html ├── procs_list.tcl ├── menus_list.tcl ├── stl-lite ├── COPYRIGHT ├── feedback.tcl ├── tk_util.tcl ├── simpleentry.tcl ├── filechsr.tcl ├── object.tcl └── tkhtml.tcl ├── canvas_list.tcl ├── README ├── Globals.html ├── afters_list.tcl ├── Notes.html ├── Value.html ├── windows_info.tcl ├── about.tcl ├── tclIndex ├── interface.tcl ├── namespaces_list.tcl ├── Intro.html ├── images_list.tcl ├── Miscellany.html ├── Lists.html ├── Windows.html ├── sls.xbm ├── names.tcl ├── WhatsNew.html ├── help.tcl ├── cmdline.tcl ├── value.tcl ├── classes_list.tcl ├── objects_list.tcl ├── windows_list.tcl ├── globals_list.tcl ├── install.tcl ├── lists.tcl ├── ChangeLog └── tkinspect.tcl /sls.ppm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tcltk/tkinspect/master/sls.ppm -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*.tcl] 4 | indent_style = space 5 | indent_size = 4 6 | tab_width = 8 7 | charset = utf-8 8 | trim_trailing_whitespace = true 9 | insert_final_newline = true -------------------------------------------------------------------------------- /dot.tkinspect_init: -------------------------------------------------------------------------------- 1 | # 2 | # this is an example .tkinspect_init, it's what I use when I debug tkinspect 3 | # itself. 4 | # 5 | tkinspect_set_target tkinspect.tcl 6 | tkinspect_show_list images 7 | tkinspect_show_list canvas 8 | tkinspect_select global tkPriv 9 | tkinspect_help WhatsNew 10 | tkinspect_create_cmdline 11 | tkinspect_trace_global tkPriv 12 | -------------------------------------------------------------------------------- /stl.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Stl is my own tcl library. It's not quite ready to be released. 5 | # The stl-lite directory contains an extremely trimmed down version. 6 | # This proc loads it. 7 | # 8 | 9 | proc stl_lite_init {} { 10 | global tkinspect_library 11 | foreach file { 12 | object.tcl filechsr.tcl simpleentry.tcl tk_util.tcl feedback.tcl 13 | tkhtml.tcl 14 | } { 15 | uplevel #0 [list source $tkinspect_library/stl-lite/$file] 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /Menus.html: -------------------------------------------------------------------------------- 1 | 2 | Menus Lists 3 | 4 | 5 | 6 | 7 |

Menus Lists

13 | 14 | This list has no list-specific operations. 15 | 16 |

17 | 18 | Last modified: Wed Jun 21 15:42:26 1995 19 | 20 | 21 | -------------------------------------------------------------------------------- /Canvases.html: -------------------------------------------------------------------------------- 1 | 2 | Canvases List 3 | 4 | 5 | 6 | 7 |

Canvases List

13 | 14 | This list has no list-specific operations. 15 | 16 |

17 | 18 | Last modified: Wed Jun 21 15:42:59 1995 19 | 20 | 21 | -------------------------------------------------------------------------------- /Procs.html: -------------------------------------------------------------------------------- 1 | 2 | Procs List 3 | 4 | 5 | 6 | 7 |

Procs List

8 | 9 | The Procs List contains a list of the procedures of the target 10 | application. This list has no list-specific operations. The default 11 | list of patterns for the list filter is: 12 | 13 |

14 |     ^tk[A-Z].*
15 |     ^auto_.*
16 |

17 | 18 | And is read from the option *Procs_list.patterns. 19 | 20 |

21 | 22 | Last modified: Mon Jun 5 01:50:13 1995 23 | 24 | 25 | -------------------------------------------------------------------------------- /Images.html: -------------------------------------------------------------------------------- 1 | 2 | Images List 3 | 4 | 5 | 6 | 7 |

Images List

13 | 14 | There is only one list-specific operation: Display Image, which 15 | sends commands to the target to create a new toplevel window 16 | containing a label with the image. 17 | 18 |

19 | 20 | Last modified: Wed Jun 21 15:42:00 1995 21 | 22 | 23 | -------------------------------------------------------------------------------- /defaults.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | proc tkinspect_default_options {} { 6 | global tkinspect_default 7 | option add *Scrollbar*width 12 8 | option add *Label*padX 0 9 | option add *Label*padY 0 10 | option add *Label*borderWidth 0 11 | option add *Frame.highlightThickness 0 12 | option add *Frame.borderWidth 2 13 | option add *tearOff: 0 14 | option add *Menubutton.borderWidth 0 15 | option add *Command_line.highlightThickness 0 16 | option add *Command_line.borderWidth 2 17 | option add *Tkinspect_main.highlightThickness 0 18 | option add *Procs_list.patterns { 19 | ^tk[A-Z].* 20 | ^auto_.* 21 | } 22 | option add *Globals_list.patterns { 23 | ^tkPriv.* 24 | ^auto_.* 25 | ^tk_.* 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /version.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Contains version numbers for tkinspect-5. 5 | # 6 | 7 | proc version_init {} { 8 | global tkinspect tk_version tk_patchLevel 9 | set tkinspect(release) 5.1.6p10 10 | set tkinspect(release_date) "21 Jun 2003" 11 | scan $tk_version "%d.%d" major minor 12 | if {$major < 8} { 13 | puts stderr \ 14 | "tkinspect-$tkinspect(release) requires Tk 8.x,\ 15 | you appear to be running Tk $major.$minor" 16 | exit 1 17 | } 18 | if {[scan $tk_patchLevel "4.0b%d" beta] == 1 && $beta < 4} { 19 | tk_dialog .warning "Warning!" \ 20 | "tkinspect-$tkinspect(release) has only been tested on 4.0b4.\ 21 | You might have problems running on $tk_patchLevel." warning 0 Ok 22 | } 23 | } 24 | 25 | -------------------------------------------------------------------------------- /Classes.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Classes List 5 | 6 | 7 | 8 | 9 |

Classes List

10 | 11 |

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

13 | 14 |

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

18 | 19 |

20 | 21 | 22 | Last modified: Thu Mar 14 23:16:22 GMT 2002 23 | 24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /procs_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | widget procs_list { 6 | object_include tkinspect_list 7 | param title "Procs" 8 | method get_item_name {} { return proc } 9 | method update {target} { 10 | $self clear 11 | foreach proc [lsort [names::procs $target]] { 12 | $self append $proc 13 | } 14 | } 15 | method retrieve {target proc} { 16 | set result [list proc $proc] 17 | set formals {} 18 | foreach arg [send $target [list ::info args $proc]] { 19 | if [send $target [list ::info default $proc $arg __tkinspect_default_arg__]] { 20 | lappend formals [list $arg [send $target \ 21 | [list ::set __tkinspect_default_arg__]]] 22 | } else { 23 | lappend formals $arg 24 | } 25 | } 26 | send $target ::catch {::unset __tkinspect_default_arg__} 27 | lappend result $formals 28 | lappend result [send $target [list ::info body $proc]] 29 | return $result 30 | } 31 | method send_filter {value} { 32 | return $value 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /menus_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Handles browsing menus. 5 | # 6 | 7 | widget menus_list { 8 | object_include tkinspect_list 9 | param title "Menus" 10 | method get_item_name {} { return menu } 11 | method update_self {target} { 12 | $slot(main) windows_info update $target 13 | $self update $target 14 | } 15 | method update {target} { 16 | $self clear 17 | foreach w [$slot(main) windows_info get_windows] { 18 | if {[$slot(main) windows_info get_class $target $w] == "Menu"} { 19 | $self append $w 20 | } 21 | } 22 | } 23 | method retrieve {target menu} { 24 | set end [send $target $menu index end] 25 | if {$end == "none"} { set end 0 } else { incr end } 26 | set result "# menu $menu has $end entries\n" 27 | for {set i 0} {$i < $end} {incr i} { 28 | append result "$menu entryconfigure $i" 29 | foreach spec [send $target [list $menu entryconfig $i]] { 30 | append result " \\\n\t[lindex $spec 0] [list [lindex $spec 4]]" 31 | } 32 | append result "\n" 33 | } 34 | return $result 35 | } 36 | method send_filter {value} { 37 | return $value 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /stl-lite/COPYRIGHT: -------------------------------------------------------------------------------- 1 | This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that: (1) source code distributions 5 | retain the above copyright notice and this paragraph in its entirety, (2) 6 | distributions including binary code include the above copyright notice and 7 | this paragraph in its entirety in the documentation or other materials 8 | provided with the distribution, and (3) all advertising materials mentioning 9 | features or use of this software display the following acknowledgement: 10 | ``This product includes software developed by the University of California, 11 | Lawrence Berkeley Laboratory and its contributors.'' Neither the name of 12 | the University nor the names of its contributors may be used to endorse 13 | or promote products derived from this software without specific prior 14 | written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED 17 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 19 | -------------------------------------------------------------------------------- /canvas_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Handles browsing canvas items. 5 | # 6 | 7 | widget canvas_list { 8 | object_include tkinspect_list 9 | param title "Canvases" 10 | method get_item_name {} { return canvas } 11 | method update_self {target} { 12 | $slot(main) windows_info update $target 13 | $self update $target 14 | } 15 | method update {target} { 16 | $self clear 17 | foreach w [$slot(main) windows_info get_windows] { 18 | if {[$slot(main) windows_info get_class $target $w] == "Canvas"} { 19 | $self append $w 20 | } 21 | } 22 | } 23 | method retrieve {target canvas} { 24 | set items [send $target $canvas find all] 25 | set result "# canvas $canvas has [llength $items] items\n" 26 | foreach item $items { 27 | append result "# item $item is tagged [list [send $target $canvas gettags $item]]\n" 28 | append result "$canvas itemconfigure $item" 29 | foreach spec [send $target [list $canvas itemconfig $item]] { 30 | append result " \\\n\t[lindex $spec 0] [list [lindex $spec 4]]" 31 | } 32 | append result "\n" 33 | } 34 | return $result 35 | } 36 | method send_filter {value} { 37 | return $value 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | tkinspect, release 5.1.6p10 2 | (21 Jun 2003) 3 | 4 | Tkinspect is a Tk program browser originally written by Sam Shen and 5 | now updated to work with Tcl/Tk 8+, incr Tcl 3+ and to cope with 6 | systems such as MS Windows where the Tk 'send' command is not 7 | available. Based upon the 5.1.6 release of tkinspect this version 8 | contains numerous bug fixes and functionality patches. See the 9 | ChangeLog file for details. 10 | 11 | tkinspect should be pretty easy to use, hopefully you can learn how to 12 | use it by selecting an interpreter (via the File, Select Interpreter 13 | menu item) and then clicking on things. There is also an online help 14 | system. 15 | 16 | tkinspect may either be run in-place (by wish tkinspect.tcl) or can be 17 | installed using the install program (wish install.tcl). Fill out the 18 | form, and hit the install button. 19 | 20 | tkinspect itself is public domain, you may do whatever you want with 21 | it. However, tkinspect uses a hacked down library that I've written 22 | at LBL, so the files in stl-lite are copyright 1995 Lawrence Berkeley 23 | Lab. See stl-lite/COPYRIGHT for the full copyright notice. 24 | 25 | This release is maintained at SourceForge as a module of the tkcon 26 | project. See http://sourceforge.net/projects/tkcon for the project 27 | information and http://tkcon.sourceforge.net/tkinspect/ for the 28 | documentation. 29 | -------------------------------------------------------------------------------- /Globals.html: -------------------------------------------------------------------------------- 1 | 2 | Globals List 3 | 4 | 5 | 6 | 7 |

Globals List

8 | 9 | The Globals List contains a list of the global variables of the 10 | target application.

19 | 20 | For an interesting example of how this works, try the following: 21 | 22 |

Select an application (for example, tkinspect itself.) 24 |
Choose Show Global... from the Globals menu, and 25 | enter tkPriv. 26 |
Choose Trace Variable from the Globals menu. 27 |

28 | 29 | You will now be tracking the tkPriv array.

30 | 31 | The default list of patterns for the list filter is: 32 | 33 |

34 |     ^tkPriv.*
35 |     ^auto_.*
36 |     ^tk_.*
37 |

38 | 39 | And is read from the option *Globals_list.patterns. 40 | 41 |

42 | 43 | Last modified: Sun Jun 4 22:23:01 1995 44 | 45 | 46 | -------------------------------------------------------------------------------- /afters_list.tcl: -------------------------------------------------------------------------------- 1 | # afters_list.tcl - Originally written by Paul Healy 2 | # 3 | # $Id$ 4 | 5 | widget afters_list { 6 | object_include tkinspect_list 7 | param title "Afters" 8 | method get_item_name {} { return after } 9 | method update {target} { 10 | $self clear 11 | foreach after [lsort [send $target ::after info]] { 12 | $self append $after 13 | } 14 | } 15 | method retrieve {target after} { 16 | set cmd [list ::after info $after] 17 | set retcode [catch [list send $target $cmd] msg] 18 | if {$retcode != 0} { 19 | set result "Error: $msg\n" 20 | } elseif {$msg != ""} { 21 | set script [lindex $msg 0] 22 | set type [lindex $msg 1] 23 | set result "# after type=$type\n" 24 | # there is no way to get even an indication of when a timer will 25 | # expire. tcl should be patched to optionally return this. 26 | switch $type { 27 | idle {append result "after idle $script\n"} 28 | timer {append result "after ms $script\n"} 29 | default {append result "after $type $script\n"} 30 | } 31 | } else { 32 | set result "Error: empty after $after?\n" 33 | } 34 | return $result 35 | } 36 | method send_filter {value} { 37 | return $value 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /Notes.html: -------------------------------------------------------------------------------- 1 | 2 | Tkinspect Notes 3 | 4 | 5 | 6 | 7 |

Tkinspect Notes

8 | 9 | tkinspect started as a quick hack to help me debug my Tk 10 | programs. Since then, I've also used tkinspect to explore and 11 | experiment with Tk programming. What started out as a 150 line one 12 | day hack has now been re-written twice and grown to over 3000 lines. 13 | I'm still having a lot of fun programming in Tcl, and so I expect 14 | tkinspect will continue to grow and evolve.

15 | 16 | tkinspect was written using a object system written in Tcl. 17 | The object system is really just a way to group a Tcl array and a 18 | bunch of procedures. It's part of a larger Tcl library of mine called 19 | STL. tkinspect includes a subset of that library.

26 | 27 | If you have any comments, questions, or bug reports please send them 28 | to me. My address is SLShen@lbl.gov. 29 | 30 |

31 | 32 | Last modified: Wed Jun 21 15:55:16 1995 33 | 34 | 35 | -------------------------------------------------------------------------------- /stl-lite/feedback.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | dialog feedback { 6 | param steps 10 7 | param title {} 8 | param barwidth 200 9 | param barheight 20 10 | param barcolor DodgerBlue 11 | member step 0 12 | member old_focus {} 13 | method create {} { 14 | $self config -bd 4 -relief ridge 15 | label $self.title 16 | pack $self.title -side top -fill x -padx 2 -pady 2 17 | frame $self.spacer 18 | frame $self.bar -relief raised -bd 2 -highlightthickness 0 19 | pack $self.spacer $self.bar -side top -padx 10 -anchor w 20 | label $self.percentage -text 0% 21 | pack $self.percentage -side top -fill x -padx 2 -pady 2 22 | wm transient $self . 23 | } 24 | method reconfig {} { 25 | $self.title config -text $slot(title) 26 | $self.spacer config -width $slot(barwidth) 27 | $self.bar config -height $slot(barheight) -bg $slot(barcolor) 28 | center_window $self 29 | update idletasks 30 | } 31 | method destroy {} { 32 | if {[grab current $self] == $self} { 33 | grab release $self 34 | } 35 | } 36 | method grab {} { 37 | while {[catch {grab set $self}]} { 38 | } 39 | } 40 | method reset {} { 41 | set slot(step) -1 42 | $self step 43 | } 44 | method step {{inc 1}} { 45 | if {$slot(step) >= $slot(steps)} return 46 | incr slot(step) $inc 47 | set fraction [expr 1.0*$slot(step)/$slot(steps)] 48 | $self.percentage config -text [format %.0f%% [expr 100.0*$fraction]] 49 | $self.bar config -width [expr int($slot(barwidth)*$fraction)] 50 | update 51 | } 52 | } 53 | 54 | -------------------------------------------------------------------------------- /Value.html: -------------------------------------------------------------------------------- 1 | 2 | Value Window 3 | 4 | 5 | 6 | 7 |

The Value Window

15 | 16 | In addition to the standard text bindings, the value window 17 | understands the following key strokes: 18 | 19 |

Control-x Control-s sends the value back to the 21 | selected interpreter. 22 | 23 |
Control-s brings up the Find... dialog. 24 | 25 |
Button-3 brings up the Value menu. 26 |

27 | 28 | The Value menu item in the main menu bar contains the following 29 | entries: 30 | 31 |

Send Value sends the value back to the selected 33 | interpreter. 34 |
Find... brings up a dialog box that allows searching of 35 | the contents of the value window. 36 |
Save Value... and Load Value... bring up a 37 | file selection dialog that allow the value to be saved or 38 | loaded from a file. 39 |
Detach Value creates a new tkinspect window that 40 | contains only the main menu, a 41 | command/button window, and a value window. The current value 42 | will be copied to the new value window. 43 |

44 | 45 |

46 | 47 | Last modified: Wed Jun 21 16:00:31 1995 48 | 49 | 50 | -------------------------------------------------------------------------------- /stl-lite/tk_util.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Misc procs for use with Tk 5 | # 6 | # This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory. 7 | # 8 | # Redistribution and use in source and binary forms, with or without 9 | # modification, are permitted provided that: (1) source code distributions 10 | # retain the above copyright notice and this paragraph in its entirety, (2) 11 | # distributions including binary code include the above copyright notice and 12 | # this paragraph in its entirety in the documentation or other materials 13 | # provided with the distribution, and (3) all advertising materials mentioning 14 | # features or use of this software display the following acknowledgement: 15 | # ``This product includes software developed by the University of California, 16 | # Lawrence Berkeley Laboratory and its contributors.'' Neither the name of 17 | # the University nor the names of its contributors may be used to endorse 18 | # or promote products derived from this software without specific prior 19 | # written permission. 20 | # 21 | # THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED 22 | # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 23 | # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 24 | 25 | proc center_window {win} { 26 | wm withdraw $win 27 | update idletasks 28 | set w [winfo reqwidth $win] 29 | set h [winfo reqheight $win] 30 | set sh [winfo screenheight $win] 31 | set sw [winfo screenwidth $win] 32 | wm geometry $win +[expr {($sw-$w)/2}]+[expr {($sh-$h)/2}] 33 | wm deiconify $win 34 | } 35 | 36 | proc under_mouse {win} { 37 | set xy [winfo pointerxy $win] 38 | wm withdraw $win 39 | wm geometry $win +[expr [lindex $xy 0] - 10]+[expr [lindex $xy 1] - 10] 40 | wm deiconify $win 41 | } 42 | -------------------------------------------------------------------------------- /windows_info.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Maintains the list of windows, and caches window class information. 5 | # (the list is shared between windows_list and menus_list.) 6 | # 7 | 8 | object_class windows_info { 9 | member windows {} 10 | method clear {} { 11 | foreach w $slot(windows) { 12 | if [info exists slot($w.class)] { 13 | unset slot($w.class) 14 | } 15 | } 16 | set slot(windows) {} 17 | } 18 | method get_windows {} { return $slot(windows) } 19 | method append_windows {target result_var parent} { 20 | upvar $result_var result 21 | set cmd "if {\[::info command ::winfo\] != {}} {\n\ 22 | ::winfo children $parent\n\ 23 | }" 24 | foreach w [send $target $cmd] { 25 | lappend slot(windows) $w 26 | $self append_windows $target result $w 27 | } 28 | } 29 | method update {target} { 30 | $self clear 31 | set cmd [list if {[::info command winfo] != {}} {::winfo children .}] 32 | if {[catch {set slot(windows) [send $target $cmd]}]} { 33 | set slot(windows) {} 34 | } 35 | feedback .feedback -title "Getting Windows" \ 36 | -steps [llength $slot(windows)] 37 | .feedback grab 38 | foreach w $slot(windows) { 39 | $self append_windows $target windows $w 40 | .feedback step 41 | update idletasks 42 | } 43 | destroy .feedback 44 | } 45 | method get_class {target w} { 46 | if ![info exists slot($w.class)] { 47 | if ![send $target [list winfo exists $w]] { 48 | # the window no longer exists, so delete it from our list 49 | set ndx [lsearch -exact $slot(windows) $w] 50 | if {$ndx >= 0} { 51 | set slot(windows) [lreplace $slot(windows) $ndx $ndx] 52 | } 53 | return "" 54 | } 55 | set slot($w.class) [send $target [list winfo class $w]] 56 | } 57 | return $slot($w.class) 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /about.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Handle the about box. 5 | # 6 | 7 | dialog about { 8 | param obliqueFont -*-helvetica-medium-o-*-*-12-* Font 9 | param font -*-helvetica-medium-r-*-*-12-* Font 10 | param boldFont -*-helvetica-bold-r-*-*-18-* Font 11 | method create {} { 12 | global tkinspect tkinspect_library 13 | wm withdraw $self 14 | wm transient $self . 15 | pack [ttk::frame $self.border] -expand 1 -fill both 16 | ttk::label $self.title -text "tkinspect" -font $slot(boldFont) 17 | ttk::label $self.ver \ 18 | -text "Release $tkinspect(release) ($tkinspect(release_date))" \ 19 | -font $slot(font) 20 | ttk::label $self.com -text "\n Bugs, suggestions and patches to:\n\ 21 | http://sourceforge.net/projects/tkcon/ \n" \ 22 | -font $slot(obliqueFont) 23 | ttk::frame $self.mug 24 | ttk::label $self.mug.l -justify left \ 25 | -text "Originally by Sam Shen\n\Contributions\ 26 | from:\nPaul Healy\nJohn LoVerso\n\T. Schotanus\ 27 | \nPat Thoyts\nAlexander Caldwell\n" 28 | 29 | global about_priv 30 | if ![info exists about_priv(mug_image)] { 31 | set about_priv(mug_image) \ 32 | [image create photo -file $tkinspect_library/sls.ppm] 33 | } 34 | ttk::label $self.mug.bm -image $about_priv(mug_image) 35 | pack $self.mug.l -side left -fill both -expand yes 36 | pack $self.mug.bm -fill none 37 | ttk::button $self.ok -text "Ok" -command "destroy $self" 38 | pack $self.title $self.ver $self.com $self.mug \ 39 | -in $self.border -side top -fill x 40 | pack $self.ok -in $self.border -side bottom -pady 5 41 | bind $self "destroy $self" 42 | } 43 | method reconfig {} { 44 | } 45 | method run {} { 46 | wm deiconify $self 47 | focus $self 48 | center_window $self 49 | tkwait visibility $self 50 | grab set $self 51 | tkwait window $self 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /stl-lite/simpleentry.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # A entry in a frame with a label. 5 | # 6 | # This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory. 7 | # 8 | # Redistribution and use in source and binary forms, with or without 9 | # modification, are permitted provided that: (1) source code distributions 10 | # retain the above copyright notice and this paragraph in its entirety, (2) 11 | # distributions including binary code include the above copyright notice and 12 | # this paragraph in its entirety in the documentation or other materials 13 | # provided with the distribution, and (3) all advertising materials mentioning 14 | # features or use of this software display the following acknowledgement: 15 | # ``This product includes software developed by the University of California, 16 | # Lawrence Berkeley Laboratory and its contributors.'' Neither the name of 17 | # the University nor the names of its contributors may be used to endorse 18 | # or promote products derived from this software without specific prior 19 | # written permission. 20 | # 21 | # THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED 22 | # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 23 | # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 24 | 25 | widget simpleentry { 26 | param label "" 27 | param width 10 28 | param textvariable "" 29 | method create {} { 30 | set w $self 31 | ttk::label $w.l 32 | pack $w.l -in $w -side left 33 | ttk::entry $w.e 34 | pack $w.e -in $w -side left -fill x -expand 1 35 | } 36 | method reconfig {} { 37 | set w $self 38 | $w.l configure -text $slot(label) 39 | $w.e configure -width $slot(width) -textvariable $slot(textvariable) 40 | } 41 | method entry args { 42 | uplevel [concat $self.e $args] 43 | } 44 | method bind {event args} { 45 | uplevel [concat [list bind $self.e $event] $args] 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /tclIndex: -------------------------------------------------------------------------------- 1 | # Tcl autoload index file, version 2.0 2 | # This file is generated by the "auto_mkindex" command 3 | # and sourced to set up indexing information for one or 4 | # more commands. Typically each line is a command that 5 | # sets an element in the auto_index array, where the 6 | # element name is the name of a command and the value is 7 | # a script that loads the command. 8 | 9 | set auto_index(tkinspect_exit) "source $dir/tkinspect.tcl" 10 | set auto_index(tkinspect_widgets_init) "source $dir/tkinspect.tcl" 11 | set auto_index(tkinspect_about) "source $dir/tkinspect.tcl" 12 | set auto_index(tkinspect_create_main_window) "source $dir/tkinspect.tcl" 13 | set auto_index(tkinspect_failure) "source $dir/tkinspect.tcl" 14 | set auto_index(tkerror) "source $dir/tkinspect.tcl" 15 | set auto_index(log) "source $dir/install.tcl" 16 | set auto_index(install_files) "source $dir/install.tcl" 17 | set auto_index(regsub_quote) "source $dir/install.tcl" 18 | set auto_index(install) "source $dir/install.tcl" 19 | set auto_index(tkinspect_default_options) "source $dir/defaults.tcl" 20 | set auto_index(value_no_filter) "source $dir/value.tcl" 21 | set auto_index(create_variable_trace) "source $dir/globals_list.tcl" 22 | set auto_index(stl_lite_init) "source $dir/stl.tcl" 23 | set auto_index(version_init) "source $dir/version.tcl" 24 | set auto_index(tkinspect_main_window) "source $dir/interface.tcl" 25 | set auto_index(tkinspect_set_target) "source $dir/interface.tcl" 26 | set auto_index(tkinspect_select) "source $dir/interface.tcl" 27 | set auto_index(tkinspect_create_cmdline) "source $dir/interface.tcl" 28 | set auto_index(tkinspect_help) "source $dir/interface.tcl" 29 | set auto_index(tkinspect_value_text_window) "source $dir/interface.tcl" 30 | set auto_index(tkinspect_send_value) "source $dir/interface.tcl" 31 | set auto_index(tkinspect_detach_value) "source $dir/interface.tcl" 32 | set auto_index(tkinspect_trace_global) "source $dir/interface.tcl" 33 | -------------------------------------------------------------------------------- /interface.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Provide a uniform interface to tkinspect's actions. 5 | # 6 | 7 | # look for a main window 8 | proc tkinspect_main_window {} { 9 | for {set i 0} {1} {incr i} { 10 | if [winfo exists .main$i] { 11 | return .main$i 12 | } 13 | } 14 | } 15 | 16 | proc tkinspect_show_list {list} { 17 | set main [tkinspect_main_window] 18 | $main add_list ${list}_list 19 | } 20 | 21 | proc tkinspect_remove_list {list} { 22 | set main [tkinspect_main_window] 23 | $main.lists.${list}_list remove 24 | } 25 | 26 | proc tkinspect_set_target {target} { 27 | set main [tkinspect_main_window] 28 | $main set_target $target 29 | } 30 | 31 | proc tkinspect_select {type thing} { 32 | set main [tkinspect_main_window] 33 | if {$type == "canvas"} { set type canva } ;# terrible hack 34 | $main.lists.${type}s_list run_command $thing 35 | } 36 | 37 | proc tkinspect_create_cmdline {} { 38 | set main [tkinspect_main_window] 39 | $main add_cmdline 40 | } 41 | 42 | proc tkinspect_help {{topic ""}} { 43 | global tkinspect 44 | if ![string length $topic] { 45 | set topic [lindex $tkinspect(help_topics) 0] 46 | } 47 | set main [tkinspect_main_window] 48 | $main help $topic 49 | } 50 | 51 | proc tkinspect_value_window {} { 52 | return [tkinspect_main_window].value 53 | } 54 | 55 | proc tkinspect_value_text_widget {} { 56 | return [tkinspect_main_window].value.t 57 | } 58 | 59 | proc tkinspect_send_value {} { 60 | [tkinspect_value_window] send_value 61 | } 62 | 63 | proc tkinspect_detach_value {} { 64 | [tkinspect_value_window] detach 65 | } 66 | 67 | proc tkinspect_trace_global {var} { 68 | set main [tkinspect_main_window] 69 | create_variable_trace $main [$main target] $var 70 | } 71 | 72 | proc tkinspect_display_image {image} { 73 | set main [tkinspect_main_window] 74 | tkinspect_select image $image 75 | $main.lists.images_list display_image 76 | } 77 | -------------------------------------------------------------------------------- /namespaces_list.tcl: -------------------------------------------------------------------------------- 1 | # namespaces_list.tcl - Originally written by Paul Healy 2 | # 3 | # $Id$ 4 | 5 | widget namespaces_list { 6 | object_include tkinspect_list 7 | param title "Namespaces" 8 | method get_item_name {} { return namespace } 9 | method update {target} { 10 | $self clear 11 | foreach namespace [names::names $target] { 12 | $self append $namespace 13 | } 14 | } 15 | method retrieve {target namespace} { 16 | set result "namespace eval $namespace {\n" 17 | 18 | set exports [names::exports $target $namespace] 19 | if {$exports!=""} { 20 | append result "\n namespace export $exports\n" 21 | } 22 | 23 | set vars [names::vars $target $namespace] 24 | if {$vars!=""} { 25 | append result "\n" 26 | } 27 | foreach var [lsort $vars] { 28 | append result " [names::value $target $var]" 29 | } 30 | 31 | set procs [lsort [names::procs $target $namespace]] 32 | append result "\n# export:\n" 33 | foreach proc $procs { 34 | if {[lsearch -exact $exports [namespace tail $proc]]!=-1} { 35 | append result " [names::prototype $target $proc]\n" 36 | } 37 | } 38 | append result "\n# internal:\n" 39 | foreach proc $procs { 40 | if {[lsearch -exact $exports [namespace tail $proc]]==-1} { 41 | append result " [names::prototype $target $proc]\n" 42 | } 43 | } 44 | 45 | append result "}\n\n" 46 | 47 | set children [names::names $target $namespace] 48 | foreach child [lsort $children] { 49 | if {$child!=$namespace} { 50 | append result "namespace eval $child {}\n" 51 | } 52 | } 53 | 54 | return $result 55 | } 56 | method send_filter {value} { 57 | return $value 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /Intro.html: -------------------------------------------------------------------------------- 1 | 2 | Tkinspect 3 | 4 | 5 | 6 | 7 |

Tkinspect Introduction

8 | 9 | tkinspect is an inspector for Tk applications. It uses Tk's 10 | send command to retreive infomation from other Tk 11 | applications. When you choose an application through the 12 | File/Select Interpreter menu, lists will 13 | be filled with the names of the procs, globals, and windows the the 14 | application. Clicking on one of those names will fill the value window with the definition of the proc, the 16 | value of the global variable, or various information about the window. 17 | The value window is editable and its contents 18 | can be sent back to the selected application.

19 | 20 | Tcl commands can be sent to the seleted application using the 21 | Command: entry, or through a command 22 | line (via the File/New Command Line menu) interface to the 23 | application. The command line is nearly identical to Tk's demo 24 | rmt.

25 | 26 | For further information, select a topic from the help window's 27 | Topics menu or from the list below: 28 | 29 |

Tkinspect Introduction 31 |
The Value Window 32 |
The Lists 33 |
- The Procs List 35 |
- The Globals List 36 |
- The Windows List 37 |
- The Images List 38 |
- The Canvases List 39 |
- The Menus List 40 |
41 |
Miscellany: how tkinspect 42 | starts up, how to customize, etc. 43 |
Notes: notes about tkinspect 44 |
Whats New: what's new in this 45 | version. 46 |
Tkinspect ChangeLog: a detailed list 47 | of changes. 48 |

49 | 50 |

51 | 52 | Last modified: Wed Jun 21 15:51:23 1995 53 | 54 | 55 | -------------------------------------------------------------------------------- /images_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Contributed by Gero Kohnert (gero@marvin.franken.de) 1995 5 | # 6 | 7 | widget images_list { 8 | object_include tkinspect_list 9 | param title "Images" 10 | method create {} { 11 | tkinspect_list:create $self 12 | $slot(menu) add separator 13 | $slot(menu) add command -label "Display Image" -underline 0 \ 14 | -command "$self display_image" 15 | } 16 | method get_item_name {} { return image } 17 | method update_self {target} { 18 | $slot(main) windows_info update $target 19 | $self update $target 20 | } 21 | method update {target} { 22 | $self clear 23 | set cmd [list if {[::info command image] != {}} {::image names}] 24 | foreach image [lsort [send $target $cmd]] { 25 | $self append $image 26 | } 27 | } 28 | method retrieve {target image} { 29 | set result "# image configuration for [list $image]\n" 30 | append result "# ([send $target ::image width $image]x[send $target ::image height $image] [send $target ::image type $image] image)\n" 31 | append result "$image config" 32 | foreach spec [send $target [list $image config]] { 33 | if {[llength $spec] == 2} continue 34 | append result " \\\n\t[lindex $spec 0] [list [lindex $spec 4]]" 35 | } 36 | append result "\n" 37 | return $result 38 | } 39 | method send_filter {value} { 40 | return $value 41 | } 42 | method display_image {} { 43 | set target [$slot(main) target] 44 | if ![string length $slot(current_item)] { 45 | tkinspect_failure \ 46 | "No image has been selected. Please select one first." 47 | } 48 | if ![send $target ::info exists __tkinspect_image_counter__] { 49 | send $target ::set __tkinspect_image_counter__ 0 50 | } 51 | while {[send $target ::winfo exists .tkinspect_image\$__tkinspect_image_counter__]} { 52 | send $target ::incr __tkinspect_image_counter__ 53 | } 54 | set w .tkinspect_image[send $target ::set __tkinspect_image_counter__] 55 | send $target [::subst { 56 | ::toplevel $w 57 | ::button $w.close -text "Close $slot(current_item)" \ 58 | -command "destroy $w" 59 | ::label $w.img -image $slot(current_item) 60 | ::pack $w.close $w.img -side top 61 | ::wm title $w "tkinspect $slot(current_item)" 62 | }] 63 | } 64 | } 65 | -------------------------------------------------------------------------------- /Miscellany.html: -------------------------------------------------------------------------------- 1 | 2 | Miscellany 3 | 4 | 5 | 6 | 7 |

Tkinspect Startup

18 | 19 |

Tkinspect Interface

20 | 21 | The following functions are available for controlling tkinspect 22 | or for use in startup files: 23 | 24 |

tkinspect_set_target target sets target as 26 | the current interpreter.
27 |
tkinspect_select type name selects a proc, global, 29 | window, image, menu, or canvas. type should be 32 | proc, global, window, image, 33 | menu, or canvas. 34 | name should be the name of the thing.
35 |
tkinspect_create_cmdline creates a command line 36 | interface.
37 |
tkinspect_help ?topic? brings up the help window 38 | containing topic. topic defaults to 39 | Intro.
40 |
tkinspect_value_text_widget returns the name of the text 41 | widget in the value.
42 |
tkinspect_send_value sends the current value.
43 |
tkinspect_detach_value detaches the value window.
44 |
tkinspect_trace_global var creates a trace on the 45 | global variable var.
46 |
tkinspect_display_image image displays the image 47 | image.
48 |

49 | 50 |

51 | 52 | Last modified: Fri Jun 23 00:59:53 1995 53 | 54 | 55 | -------------------------------------------------------------------------------- /Lists.html: -------------------------------------------------------------------------------- 1 | 2 | Tkinspect Lists 3 | 4 | 5 | 6 | 7 |

Lists

8 | 9 | The lists are the listboxes just below the Command: entry. 10 | By default, there are three lists: 11 | 12 |

Procs is a list of all the Tcl 14 | procedures in the target application. 15 |
Globals is a list of the global 16 | variables of the target application. 17 |
Windows is a list of the windows 18 | of the target application. 19 |
Images is a list of the images 20 | of the target application. 21 |
Menus is a list of the menu widgets 22 | of the target application. 23 |
Canvases is a list of the 24 | canvas widgets of the target application. 25 |

32 | 33 | Each list also has a menu in the menu bar. (The menu can also be 34 | brought up by pressing button-3 in the list.) The menu 35 | contains a set of standard operations, followed by list-specific 36 | operations (if any are available.) The standard list operations are: 37 | 38 |

Show a X.. brings up a dialog that prompts for the name 40 | of a proc, global, or window and places the its value in the value window. 42 |
Find X... brings up a dialog that searches the list. 43 |
Edit Filter... brings up a dialog that allows editing of 44 | the list filter. The list will only displays those items that 45 | either match or don't match a set of patterns. (The default 46 | list of patterns varies for each list type.) 47 |
Update This List updates the contents of this list. 48 | All the lists can be updated via the File/Update 49 | Lists menu item. 50 |
Remove This List removes this list from the tkinspect 51 | window. A list can also be removed by deselecting its checkbox 52 | in the File menu. 53 |

54 | 55 |

56 | 57 | Last modified: Wed Jun 21 15:32:14 1995 58 | 59 | 60 | -------------------------------------------------------------------------------- /Windows.html: -------------------------------------------------------------------------------- 1 | 2 | Windows List 3 | 4 | 5 | 6 | 7 |

Windows List

8 | 9 | The Windows List is tkinspect's most complicated list. 10 | In addition to the standard list operations, the 11 | Windows menu contains the following items that control what 12 | information about a window to display: 13 | 14 |

Window Configuration shows the configuration of the window. 16 |
Window Packing shows the pack commands that 17 | packed the window into its parent. 18 |
Slave Window Packing shows the pack 19 | commands that packed the slaves of the window. 20 |
Window Bindtags & Bindings shows the current 21 | bindtag order along with the bindings of each of the tags. 22 |
Window Bindtags shows the current bindtag order of the 23 | window. 24 |
Window Bindings shows just the bindings for the window. 25 |
Window Class Bindings shows the bindings for the 26 | window's class. 27 |

28 | 29 | The following options avoid common pitfalls in sending back window 30 | values: 31 | 32 |

Filter Empty Window Options removes window options that 34 | are empty ({}) from values that are sent. Some Tk 35 | configuration parameters are displayed as empty, but setting 36 | them to {} can mean something different. For example, 37 | canvas scrollregion's. 38 |
Filter Window -class Options removes -class 39 | options from values that are sent. Setting the window class of 40 | frame's and 41 | toplevel's after they've been created is an error. 42 |
Filter Pack -in Options removes -in options 43 | from values that are sent. 44 |

45 | 46 | The following options control when & how windows are retreived: 47 | 48 |

Get Window Information controls whether or not the 50 | windows should be retrieved when a new interpreter is selected 51 | or the lists are updated. You may want to turn this on if 52 | getting the list of windows takes a long time. 53 |
Use Feedback When Getting Windows controls whether or 54 | not the little feedback percentage bar appears when the windows 55 | list is created. 56 |

57 | 58 |

59 | 60 | Last modified: Sun Jun 11 02:11:40 1995 61 | 62 | 63 | -------------------------------------------------------------------------------- /sls.xbm: -------------------------------------------------------------------------------- 1 | #define noname_width 64 2 | #define noname_height 64 3 | static char noname_bits[] = { 4 | 0x00,0x00,0x00,0xfc,0x7f,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0x7f,0x01,0x00, 5 | 0x00,0x00,0x00,0xe0,0xff,0xff,0x0f,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0x0f, 6 | 0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0x3f,0x00,0x00,0x00,0x00,0xfc,0xff,0xff, 7 | 0x3f,0x00,0x00,0x00,0x00,0xfc,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0xf8,0xff, 8 | 0xff,0x7f,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0x00,0x00,0x00,0x00,0xfe, 9 | 0xff,0xff,0xff,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0x07,0x00,0x00,0x00, 10 | 0xff,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0x03,0x00,0x00, 11 | 0x00,0xff,0xff,0x07,0xf8,0x0f,0x00,0x00,0x00,0xff,0xff,0x01,0xf0,0x07,0x00, 12 | 0x00,0x00,0xff,0xff,0x00,0xc0,0x03,0x00,0x00,0x00,0xff,0x7f,0x00,0xc0,0x01, 13 | 0x00,0x00,0x00,0xff,0x1f,0x00,0x00,0x01,0x00,0x00,0x00,0xfe,0x3f,0x00,0x80, 14 | 0x01,0x00,0x00,0x00,0xa7,0x17,0x00,0x80,0x01,0x00,0x00,0x00,0x07,0x0f,0x00, 15 | 0x80,0x00,0x00,0x00,0x00,0x83,0x9b,0x7f,0x80,0x00,0x00,0x00,0x00,0x87,0xf3, 16 | 0x7f,0x80,0x00,0x00,0x00,0x00,0x83,0x73,0xc0,0xff,0x00,0x00,0x00,0x00,0xc3, 17 | 0x33,0xc0,0x97,0x01,0x00,0x00,0x00,0x43,0x33,0x80,0x0d,0x01,0x00,0x00,0x80, 18 | 0x03,0x31,0x00,0x07,0x01,0x00,0x00,0x80,0x03,0x30,0x00,0x07,0x01,0x00,0x00, 19 | 0x80,0x02,0x60,0x80,0x03,0x01,0x00,0x00,0x80,0x04,0xe0,0xc0,0x03,0x01,0x00, 20 | 0x00,0x00,0x08,0xc0,0xe1,0x03,0x01,0x00,0x00,0x80,0x00,0x80,0xbf,0x82,0x01, 21 | 0x00,0x00,0x80,0x00,0x00,0x9e,0xc6,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x7c, 22 | 0x00,0x00,0x00,0x80,0x00,0x00,0x80,0x20,0x00,0x00,0x00,0x00,0x00,0x00,0x80, 23 | 0x00,0x00,0x00,0x00,0x40,0x00,0x00,0x80,0x10,0x00,0x00,0x00,0x40,0x00,0x00, 24 | 0x80,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00,0x00,0x00,0x40,0x00, 25 | 0x00,0x00,0x00,0x00,0x00,0x00,0x40,0x00,0x00,0x03,0x04,0x00,0x00,0x00,0x20, 26 | 0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x20,0x00,0x00,0x00,0x02,0x00,0x00,0x00, 27 | 0x20,0x00,0x00,0x10,0x01,0x00,0x00,0x00,0x10,0x40,0x00,0x80,0x00,0x00,0x00, 28 | 0x00,0x18,0x80,0x00,0x40,0x00,0x00,0x00,0x00,0x08,0x00,0x03,0x20,0x00,0x00, 29 | 0x00,0x00,0x06,0x80,0x3c,0x10,0x00,0x00,0x00,0x00,0x03,0xc0,0xe0,0x0f,0x00, 30 | 0x00,0x00,0x80,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x80,0x02,0x40,0x01,0x00, 31 | 0x00,0x00,0x00,0x60,0x01,0x80,0x02,0x00,0x00,0x00,0x00,0x10,0x01,0x80,0x0c, 32 | 0x00,0x00,0x00,0x00,0x00,0x01,0x80,0x11,0x00,0x00,0x00,0x00,0x00,0x01,0x00, 33 | 0xc5,0x00,0x00,0x00,0x00,0x00,0x01,0x00,0x02,0x05,0x00,0x00,0x00,0x00,0x01, 34 | 0x00,0x02,0x10,0x00,0x00,0x00,0x00,0x03,0x00,0x01,0x00,0x00,0x00,0x00,0x00, 35 | 0x01,0x80,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00, 36 | 0x00,0x0c,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0x0f,0x00,0x00,0x00,0x00, 37 | 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 38 | 0x00,0x00}; 39 | -------------------------------------------------------------------------------- /names.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | namespace eval names { 6 | 7 | namespace export names procs vars prototype value exports 8 | 9 | proc unqualify s { 10 | regsub -all "(^| ):+" $s {\1} result 11 | return $result 12 | } 13 | 14 | proc names {target {name ::}} { 15 | set result $name 16 | foreach n [send $target ::namespace children $name] { 17 | append result " " [names $target $n] 18 | } 19 | return $result 20 | } 21 | 22 | proc procs {target {names ""}} { 23 | if {$names == ""} { 24 | set names [names $target] 25 | } 26 | set result {} 27 | foreach n $names { 28 | foreach p [send $target ::namespace eval $n ::info procs] { 29 | lappend result "$n\::$p" 30 | } 31 | } 32 | return [unqualify $result] 33 | } 34 | 35 | # pinched from globals_list.tcl 36 | proc prototype {target proc} { 37 | set result {} 38 | set args [send $target [list ::info args $proc]] 39 | set defaultvar "__tkinspect:default_arg__" 40 | foreach arg $args { 41 | if [send $target [list ::info default $proc $arg $defaultvar]] { 42 | lappend result [list $arg [send $target \ 43 | [list ::set $defaultvar]]] 44 | } else { 45 | lappend result $arg 46 | } 47 | } 48 | 49 | send $target ::catch ::unset $defaultvar 50 | 51 | return [list proc [namespace tail $proc] $result {} ] 52 | } 53 | 54 | proc vars {target {names ""}} { 55 | if {$names == ""} { 56 | set names [names $target] 57 | } 58 | set result {} 59 | foreach n $names { 60 | foreach v [send $target ::info vars ${n}::*] { 61 | lappend result $v 62 | } 63 | } 64 | return [unqualify $result] 65 | } 66 | 67 | proc value {target var} { 68 | set tail [namespace tail $var] 69 | if {[send $target [list ::array exists $var]]} { 70 | return "variable $tail ; # $var is an array\n" ; # dump it out? 71 | } 72 | set cmd [list ::set $var] 73 | set retcode [catch [list send $target $cmd] msg] 74 | if {$retcode != 0} { 75 | return "variable $tail ; # $var not defined\n" 76 | } else { 77 | return "variable $tail \"$msg\"\n" 78 | } 79 | } 80 | 81 | proc exports {target namespace} { 82 | set result [send $target ::namespace eval $namespace ::namespace export] 83 | return [unqualify $result] 84 | } 85 | 86 | # dump [tk appname] 87 | proc dump appname { 88 | puts "names: [names $appname]" 89 | puts "" 90 | puts "procs: [procs $appname]" 91 | puts "" 92 | puts "vars: [vars $appname]" 93 | puts "" 94 | puts "exports: [exports $appname]" 95 | } 96 | } 97 | 98 | -------------------------------------------------------------------------------- /WhatsNew.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | What's New? 5 | 6 | 7 | 8 | 9 |

What's New?

10 | 11 | See the ChangeLog for more details. 12 | 13 |

Changes in release 5.1.6p10 (21 Jun 2003)

14 | 15 |

Fixed a bug in tracing variables with dde and winsend
Fixed a bug in the windows view that garbled the display.
Always namespace qualify commands sent to the target.
Fixed a problem formatting the ChangeLog view. 20 |

21 | 22 |

Changes in release 5.1.6p9 (10 Oct 2002)

23 | 24 |

Support for use in scripted documents (tclkit).
Support 'trace' when using alternative 'send' implementations
Fix array checking. 28 |

29 | 30 |

Changes in release 5.1.6p8 (04 Apr 2002)

31 | 32 |

Merged in Paul Healy's p4 patch which provides 34 | namespaces and afters windows for examining entire 35 | namespaces or the after event timers.
Fixed array checking. array size was use instead of 37 | array exists in some places which can cause an empty 38 | array to be treated as if it is a normal variable.
Merged in Steve Landers code for Scripted Document 40 | support

42 | 43 |

Changes in release 5.1.6p7 (22 Mar 2002)

44 | 45 |

A raft of bugs have been fixed - see the 47 | ChangeLog for just what.
Added a DDE implementation of send for use on 49 | Windows.

51 | 52 |

Changes in release 5.1.6p6 (14 Mar 2002)

53 | 54 |

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

59 | 60 |

Changes in release 5.1.6 (23 June 1995)

61 | 62 |

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

64 | 65 |

Changes in release 5.1.4 (21 June 1995)

66 | 67 | 5.1.4 adds more browsing lists, and has a few refinements. 68 | 69 |

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

85 | 86 |

Changes in release 5.1 (5 June 1995)

87 | 88 | 5.1 fills in the missing holes of 5.0, fixes a few bugs, and adds some 89 | features. 90 | 91 |

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

104 | 105 | 106 |

Changes in release 5.0 (February 1995)

107 | 108 | Release 5.0 was a complete rewrite of previous versions of 109 | tkinspect. This version runs only with Tk 4.0. 110 | 111 |

112 | 113 | Last modified: Thu Mar 14 23:34:01 GMT 2002 114 | 115 | 116 | 117 | 118 | -------------------------------------------------------------------------------- /help.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | dialog help_window { 6 | param topics {} 7 | param width 100 8 | param height 35 9 | param helpdir . 10 | member history {} 11 | member history_ndx -1 12 | member history_len 0 13 | member rendering 0 14 | method create {} { 15 | ttk::frame $self.menu 16 | ttk::menubutton $self.menu.topics -text "Topics" -underline 0 \ 17 | -menu $self.menu.topics.m 18 | pack $self.menu.topics -in $self.menu -side left 19 | set m [menu $self.menu.topics.m] 20 | ttk::menubutton $self.menu.navigate -text "Navigate" -underline 0 \ 21 | -menu $self.menu.navigate.m 22 | pack $self.menu.navigate -in $self.menu -side left 23 | set m [menu $self.menu.navigate.m] 24 | $m add command -label "Forward" -underline 0 -state disabled \ 25 | -command "$self forward" -accelerator f 26 | $m add command -label "Back" -underline 0 -state disabled \ 27 | -command "$self back" -accelerator b 28 | $m add cascade -label "Go" -underline 0 -menu $m.go 29 | menu $m.go -postcommand "$self fill_go_menu" 30 | ttk::frame $self.text 31 | ttk::scrollbar $self.text.sb -command "$self.text.t yview" 32 | text $self.text.t -yscrollcommand "$self.text.sb set" \ 33 | -wrap word -setgrid 1 -background white 34 | set t $self.text.t 35 | pack $self.text.sb -in $self.text -side right -fill y 36 | pack $self.text.t -in $self.text -side left -fill both -expand yes 37 | pack $self.menu -in $self -side top -fill x 38 | pack $self.text -in $self -side bottom -fill both -expand yes 39 | bind $self "$self forward" 40 | bind $self "$self back" 41 | bind $self "$self forward" 42 | bind $self "$self back" 43 | bind $self "$self page_forward" 44 | bind $self "$self page_forward" 45 | bind $self "$self page_back" 46 | bind $self "$self page_back" 47 | bind $self "$self page_back" 48 | bind $self "$self line_forward" 49 | bind $self "$self line_back" 50 | } 51 | method reconfig {} { 52 | set m $self.menu.topics.m 53 | $m delete 0 last 54 | foreach topic $slot(topics) { 55 | $m add radiobutton -variable [object_slotname topic] \ 56 | -value $topic \ 57 | -label $topic \ 58 | -command [list $self show_topic $topic] 59 | } 60 | $m add separator 61 | $m add command -label "Close Help" -underline 0 \ 62 | -command "destroy $self" 63 | $self.text.t config -width $slot(width) -height $slot(height) 64 | } 65 | method show_topic {topic} { 66 | incr slot(history_ndx) 67 | set slot(history) [lrange $slot(history) 0 $slot(history_ndx)] 68 | set slot(history_len) [expr $slot(history_ndx) + 1] 69 | lappend slot(history) $topic 70 | $self read_topic $topic 71 | } 72 | method read_topic {topic} { 73 | # probably should use uri::geturl from tcllib 74 | set slot(topic) $topic 75 | wm title $self "Help: $topic" 76 | set filename [file join $slot(helpdir) $topic] 77 | if {![file exist $filename]} { 78 | append filename .html 79 | } 80 | set f [open $filename r] 81 | set txt [read $f] 82 | close $f 83 | 84 | # Fix for 85 | if [string match -nocase "*ChangeLog" $filename] { 86 | set txt "

$txt

" 87 | } 88 | 89 | feedback .help_feedback -steps [set slot(len) [string length $txt]] \ 90 | -title "Rendering HTML" 91 | .help_feedback grab 92 | set slot(remaining) $slot(len) 93 | set slot(rendering) 1 94 | tkhtml_set_render_hook "$self update_feedback" 95 | tkhtml_set_command "$self follow_link" 96 | tkhtml_render $self.text.t $txt 97 | destroy .help_feedback 98 | set slot(rendering) 0 99 | set m $self.menu.navigate.m 100 | if {($slot(history_ndx)+1) < $slot(history_len)} { 101 | $m entryconfig 1 -state normal 102 | } else { 103 | $m entryconfig 1 -state disabled 104 | } 105 | if {$slot(history_ndx) > 0} { 106 | $m entryconfig 2 -state normal 107 | } else { 108 | $m entryconfig 2 -state disabled 109 | } 110 | } 111 | method follow_link {link} { 112 | $self show_topic $link 113 | } 114 | method forward {} { 115 | if {$slot(rendering) || ($slot(history_ndx)+1) >= $slot(history_len)} return 116 | incr slot(history_ndx) 117 | $self read_topic [lindex $slot(history) $slot(history_ndx)] 118 | } 119 | method back {} { 120 | if {$slot(rendering) || $slot(history_ndx) <= 0} return 121 | incr slot(history_ndx) -1 122 | $self read_topic [lindex $slot(history) $slot(history_ndx)] 123 | } 124 | method fill_go_menu {} { 125 | set m $self.menu.navigate.m.go 126 | catch {$m delete 0 last} 127 | for {set i [expr [llength $slot(history)]-1]} {$i >= 0} {incr i -1} { 128 | set topic [lindex $slot(history) $i] 129 | $m add command -label $topic \ 130 | -command [list $self show_topic $topic] 131 | } 132 | } 133 | method update_feedback {n} { 134 | if {($slot(remaining) - $n) > .1*$slot(len)} { 135 | .help_feedback step [expr $slot(remaining) - $n] 136 | update idletasks 137 | set slot(remaining) $n 138 | } 139 | } 140 | method page_forward {} { 141 | $self.text.t yview scroll 1 pages 142 | } 143 | method page_back {} { 144 | $self.text.t yview scroll -1 pages 145 | } 146 | method line_forward {} { $self.text.t yview scroll 1 units } 147 | method line_back {} { $self.text.t yview scroll -1 units } 148 | } 149 | -------------------------------------------------------------------------------- /cmdline.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Provide a command line interface to an application (much of the 5 | # code is lifted out of the Tk demo rmt). 6 | # 7 | # [PT]: this should be replaced by tkcon... 8 | 9 | dialog command_line { 10 | param main 11 | param target "" 12 | member executing 0 13 | member last_command "" 14 | method create {} { 15 | frame $self.menu -bd 2 -relief raised 16 | pack $self.menu -side top -fill x 17 | menubutton $self.menu.file -text "File" -menu $self.menu.m \ 18 | -underline 0 -menu $self.menu.file.m 19 | pack $self.menu.file -side left 20 | set m [menu $self.menu.file.m] 21 | $m add command -label "Close Window" -underline 0 \ 22 | -command "destroy $self" 23 | text $self.t -yscroll "$self.sb set" 24 | scrollbar $self.sb -command "$self.t yview" 25 | pack $self.sb -side right -fill y 26 | pack $self.t -side left -fill both -expand 1 27 | 28 | # Create a binding to forward commands to the target application, 29 | # plus modify many of the built-in bindings so that only information 30 | # in the current command can be deleted (can still set the cursor 31 | # earlier in the text and select and insert; just can't delete). 32 | bindtags $self.t "$self.t Text . all" 33 | bind $self.t { 34 | %W mark set insert {end - 1c} 35 | %W insert insert "\n" 36 | regexp "(.*)\\.t$" %W dummy self 37 | command_line:invoke $self 38 | break 39 | } 40 | bind $self.t { 41 | if {[%W tag nextrange sel 1.0 end] != ""} { 42 | %W tag remove sel sel.first promptEnd 43 | } else { 44 | if [%W compare insert < promptEnd] { 45 | break 46 | } 47 | } 48 | } 49 | bind $self.t { 50 | if {[%W tag nextrange sel 1.0 end] != ""} { 51 | %W tag remove sel sel.first promptEnd 52 | } else { 53 | if [%W compare insert <= promptEnd] { 54 | break 55 | } 56 | } 57 | } 58 | bind $self.t { 59 | if [%W compare insert < promptEnd] { 60 | break 61 | } 62 | } 63 | bind $self.t { 64 | if [%W compare insert < promptEnd] { 65 | %W mark set insert promptEnd 66 | } 67 | } 68 | bind $self.t { 69 | if [%W compare insert < promptEnd] { 70 | break 71 | } 72 | } 73 | bind $self.t { 74 | if [%W compare insert < promptEnd] { 75 | break 76 | } 77 | } 78 | bind $self.t { 79 | if [%W compare insert <= promptEnd] { 80 | break 81 | } 82 | } 83 | bind $self.t { 84 | if [%W compare insert <= promptEnd] { 85 | break 86 | } 87 | } 88 | bind $self.t { 89 | %W tag remove sel sel.first promptEnd 90 | } 91 | bind $self.t "command_line:text_insert $self %A; break" 92 | $self.t tag configure bold \ 93 | -font {Courier 12 bold} 94 | #-font -*-Courier-Bold-R-Normal-*-120-*-*-*-*-*-* 95 | $self prompt 96 | } 97 | method destroy {} { 98 | $slot(main) delete_cmdline $self 99 | } 100 | method reconfig {} { 101 | } 102 | 103 | # The procedure below is used to print out a prompt at the 104 | # insertion point (which should be at the beginning of a line 105 | # right now). 106 | method prompt {} { 107 | $self.t insert insert "$slot(target): " 108 | $self.t mark set promptEnd {insert} 109 | $self.t mark gravity promptEnd left 110 | $self.t tag add bold {promptEnd linestart} promptEnd 111 | } 112 | 113 | # The procedure below executes a command (it takes everything on the 114 | # current line after the prompt and either sends it to the remote 115 | # application or executes it locally, depending on "app"). 116 | method invoke {} { 117 | set cmd [$self.t get promptEnd insert] 118 | incr slot(executing) 1 119 | if [info complete $cmd] { 120 | if {$cmd == "!!\n"} { 121 | set cmd $slot(last_command) 122 | } else { 123 | set slot(last_command) $cmd 124 | } 125 | if {$slot(target) == "local"} { 126 | set result [catch [list uplevel #0 $cmd] msg] 127 | } else { 128 | set result [catch [list send $slot(target) $cmd] msg] 129 | } 130 | if {$result != 0} { 131 | $self.t insert insert "Error: $msg\n" 132 | } else { 133 | if {$msg != ""} { 134 | $self.t insert insert $msg\n 135 | } 136 | } 137 | $self prompt 138 | $self.t mark set promptEnd insert 139 | } 140 | incr slot(executing) -1 141 | $self.t yview -pickplace insert 142 | } 143 | 144 | # The following procedure is invoked to change the application that 145 | # we're talking to. It also updates the prompt for the current 146 | # command, unless we're in the middle of executing a command from 147 | # the text item (in which case a new prompt is about to be output 148 | # so there's no need to change the old one). 149 | method set_target {target} { 150 | if ![string length $target] { 151 | set target local 152 | } 153 | set slot(target) $target 154 | if !$slot(executing) { 155 | $self.t mark gravity promptEnd right 156 | $self.t delete "promptEnd linestart" promptEnd 157 | $self.t insert promptEnd "$target: " 158 | $self.t tag add bold "promptEnd linestart" promptEnd 159 | $self.t mark gravity promptEnd left 160 | } 161 | wm title $self "Command Line: $target" 162 | return {} 163 | } 164 | 165 | method text_insert {s} { 166 | if {$s == ""} { 167 | return 168 | } 169 | catch { 170 | if {[$self.t compare sel.first <= insert] 171 | && [$self.t compare sel.last >= insert]} { 172 | $self.t tag remove sel sel.first promptEnd 173 | $self.t delete sel.first sel.last 174 | } 175 | } 176 | $self.t insert insert $s 177 | $self.t see insert 178 | } 179 | } 180 | -------------------------------------------------------------------------------- /value.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | set value_priv(counter) -1 6 | 7 | proc value_no_filter {text} { 8 | return $text 9 | } 10 | 11 | widget value { 12 | param width 100 13 | param height 20 14 | param main 15 | param savehist 15 16 | param searchbackground indianred 17 | param searchforeground white 18 | member hist_no 0 19 | member send_filter value_no_filter 20 | method create {} { 21 | #$self config -bd 0 -relief flat -highlightthickness 0 22 | pack [ttk::frame $self.title] -side top -fill x 23 | pack [ttk::label $self.title.l -text "Value: "] -side left 24 | ttk::menubutton $self.title.vname -menu $self.title.vname.m -state disabled 25 | menu $self.title.vname.m -postcommand "$self fill_vname_menu" 26 | pack $self.title.vname -fill x 27 | ttk::scrollbar $self.sb -command "$self.t yview" 28 | text $self.t -yscroll "$self.sb set" -background white 29 | pack $self.sb -side right -fill y 30 | pack $self.t -side right -fill both -expand 1 31 | bind $self.t

"$self send_value" 32 | bind $self.t "$self search_dialog" 33 | set m [$slot(main) add_menu Value] 34 | bind $self.t <3> "tk_popup $m %X %Y" 35 | $m add command -label "Send Value" -command "$self send_value" \ 36 | -underline 1 37 | $m add command -label "Find..." -command "$self search_dialog" \ 38 | -underline 0 39 | $m add command -label "Save Value..." -command "$self save" \ 40 | -underline 0 41 | $m add command -label "Load Value..." -command "$self load" \ 42 | -underline 0 43 | $m add command -label "Detach Window" -command "$self detach" \ 44 | -underline 0 45 | } 46 | method reconfig {} { 47 | $self.t config -width $slot(width) -height $slot(height) 48 | $self.t tag configure search -background $slot(searchbackground) \ 49 | -foreground $slot(searchforeground) 50 | } 51 | method set_value {name value redo_command} { 52 | $self.t delete 1.0 end 53 | $self.t insert 1.0 $value 54 | $self.title.vname config -text $name -state normal 55 | set slot(history.[incr slot(hist_no)]) [list $name $redo_command] 56 | if {($slot(hist_no) - $slot(savehist)) > 0} { 57 | unset slot(history.[expr $slot(hist_no)-$slot(savehist)]) 58 | } 59 | } 60 | method fill_vname_menu {} { 61 | set m $self.title.vname.m 62 | catch {$m delete 0 last} 63 | for {set i $slot(hist_no)} {[info exists slot(history.$i)]} {incr i -1} { 64 | $m add command -label [lindex $slot(history.$i) 0] \ 65 | -command [lindex $slot(history.$i) 1] 66 | } 67 | } 68 | method set_send_filter {command} { 69 | if {![string length $command]} { 70 | set command value_no_filter 71 | } 72 | set slot(send_filter) $command 73 | } 74 | method send_value {} { 75 | send [$slot(main) target] \ 76 | [eval $slot(send_filter) [list [$self.t get 1.0 end]]] 77 | $slot(main) status "Value sent" 78 | } 79 | method detach {} { 80 | set w [tkinspect_create_main_window \ 81 | -default_lists {} \ 82 | -target [$slot(main) cget -target]] 83 | $w.value copy $self 84 | } 85 | method copy {v} { 86 | $self.t insert 1.0 [$v.t get 1.0 end] 87 | } 88 | method search_dialog {} { 89 | if ![winfo exists $self.search] { 90 | value_search $self.search -value $self 91 | center_window $self.search 92 | } else { 93 | wm deiconify $self.search 94 | } 95 | } 96 | method search {type text} { 97 | $self.t tag remove search 0.0 end 98 | scan [$self.t index end] %d n_lines 99 | set start 1 100 | set end [expr $n_lines+1] 101 | set inc 1 102 | set l [string length $text] 103 | for {set i $start} {$i != $end} {incr i $inc} { 104 | if {[string first $text [$self.t get $i.0 $i.1000]] == -1} { 105 | continue 106 | } 107 | set line [$self.t get $i.0 $i.1000] 108 | set offset 0 109 | while 1 { 110 | set index [string first $text $line] 111 | if {$index < 0} { 112 | break 113 | } 114 | incr offset $index 115 | $self.t tag add search $i.[expr $offset] $i.[expr $offset+$l] 116 | incr offset $l 117 | set line [string range $line [expr $index+$l] 1000] 118 | } 119 | } 120 | if [catch {$self.t see [$self.t index search.first]}] { 121 | $slot(main) status "Search text not found." 122 | } 123 | } 124 | method save {} { 125 | #filechooser $self.fc -newfile 1 -title "Save Value" 126 | #set file [$self.fc run] 127 | set file [tk_getSaveFile -title "Save Value"] 128 | if ![string length $file] { 129 | $slot(main) status "Save cancelled." 130 | return 131 | } 132 | set fp [open $file w] 133 | puts $fp [$self.t get 1.0 end] 134 | close $fp 135 | $slot(main) status "Value saved to \"$file\"" 136 | } 137 | method load {} { 138 | #filechooser $self.fc -title "Load Value" 139 | #set file [$self.fc run] 140 | set file [tk_getOpenFile -title "Load Value"] 141 | if ![string length $file] { 142 | $slot(main) status "Load cancelled." 143 | return 144 | } 145 | $self.t delete 1.0 end 146 | set fp [open $file r] 147 | $self.t insert 1.0 [read $fp] 148 | close $fp 149 | $slot(main) status "Value read from \"$file\"" 150 | } 151 | } 152 | 153 | dialog value_search { 154 | param value 155 | member search_type exact 156 | method create {} { 157 | ttk::frame $self.top 158 | pack $self.top -side top -fill x 159 | ttk::label $self.l -text "Search for:" 160 | ttk::entry $self.e 161 | bind $self.e "$self search" 162 | pack $self.l -in $self.top -side left 163 | pack $self.e -in $self.top -fill x -expand 1 164 | ttk::checkbutton $self.re -variable [object_slotname search_type] \ 165 | -onvalue regexp -offvalue exact -text "Regexp search" 166 | pack $self.re -side top -anchor w 167 | ttk::button $self.go -text "Highlight" -command "$self search" 168 | ttk::button $self.close -text "Close" -command "destroy $self" 169 | pack $self.go $self.close -side left 170 | wm title $self "Find in Value.." 171 | wm iconname $self "Find in Value.." 172 | focus $self.e 173 | } 174 | method reconfig {} { 175 | } 176 | method search {} { 177 | set text [$self.e get] 178 | if ![string length $text] return 179 | $slot(value) search $slot(search_type) $text 180 | } 181 | } 182 | -------------------------------------------------------------------------------- /classes_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Written by: T. Schotanus 5 | # E-mail: sst@bouw.tno.nl 6 | # URL: http://huizen.dds.nl/~quintess 7 | # 8 | # Itcl 3.2 support by Pat Thoyts 9 | # We are hanging onto the older code to support old versions although 10 | # this needs testing. 11 | # 12 | 13 | widget class_list { 14 | object_include tkinspect_list 15 | param title "Classes" 16 | param itcl_version 0 17 | 18 | method get_item_name {} { 19 | return class 20 | } 21 | 22 | method update {target} { 23 | $self clear 24 | # Need info on older itcl version to do this properly. 25 | set cmd [list if {[::info command itcl_info] != {}} {::itcl_info classes}] 26 | set classes [lsort [send $target $cmd]] 27 | if {$classes != {}} { 28 | set slot(itcl_version) [send $target ::package provide Itcl] 29 | } 30 | foreach class $classes { 31 | $self append $class 32 | } 33 | } 34 | 35 | method retrieve {target class} { 36 | if {$slot(itcl_version) != {}} { 37 | if {$slot(itcl_version) >= 3} { 38 | return [$self retrieve_new $target $class] 39 | } else { 40 | return [$self retrieve_old $target $class] 41 | } 42 | } 43 | } 44 | 45 | method retrieve_old {target class} { 46 | set res "itcl_class $class {\n" 47 | 48 | set cmd [list $class :: info inherit] 49 | set inh [send $target $cmd] 50 | if {$inh != ""} { 51 | set res "$res\tinherit $inh\n\n" 52 | } else { 53 | set res "$res\n" 54 | } 55 | 56 | set pubs [send $target [list $class :: info public]] 57 | foreach arg $pubs { 58 | regsub {(.*)::} $arg {} a 59 | set res "$res\tpublic $a\n" 60 | } 61 | if {$pubs != ""} { 62 | set res "$res\n" 63 | } 64 | 65 | set prots [send $target [list $class :: info protected]] 66 | foreach arg $prots { 67 | regsub {(.*)::} $arg {} a 68 | if {$a != "this"} { 69 | set res "$res\tprotected $a\n" 70 | } 71 | } 72 | if {$prots != ""} { 73 | set res "$res\n" 74 | } 75 | 76 | set coms [send $target [list $class :: info common]] 77 | foreach arg $coms { 78 | regsub {(.*)::} $arg {} a 79 | set cmd [list $class :: info common $a] 80 | set com [send $target $cmd] 81 | set res "$res\tcommon $a [list [lindex $com 2]] (default: [list [lindex $com 1]])\n" 82 | } 83 | if {$coms != ""} { 84 | set res "$res\n" 85 | } 86 | 87 | set meths [send $target [list $class :: info method]] 88 | foreach arg $meths { 89 | if {[string first $class $arg] == 0} { 90 | regsub {(.*)::} $arg {} a 91 | set cmd [list $class :: info method $a] 92 | set meth [send $target $cmd] 93 | if {$a != "constructor" && $a != "destructor"} { 94 | set nm "method " 95 | } else { 96 | set nm "" 97 | } 98 | if {[lindex $meth 1] != ""} { 99 | set res "$res\t$nm$a [lrange $meth 1 end]\n\n" 100 | } 101 | } 102 | } 103 | 104 | set procs [send $target [list $class :: info proc]] 105 | foreach arg $procs { 106 | if {[string first $class $arg] == 0} { 107 | regsub {(.*)::} $arg {} a 108 | set cmd [list $class :: info proc $a] 109 | set proc [send $target $cmd] 110 | if {[lindex $proc 1] != ""} { 111 | set res "$res\tproc $a [lrange $proc 1 end]\n\n" 112 | } 113 | } 114 | } 115 | 116 | set res "$res}\n" 117 | return $res 118 | } 119 | 120 | method retrieve_new {target class} { 121 | set res "itcl::class $class {\n" 122 | 123 | set cmd [list ::namespace eval $class {info inherit}] 124 | set inh [send $target $cmd] 125 | if {$inh != ""} { 126 | append res " inherit $inh\n\n" 127 | } else { 128 | append res "\n" 129 | } 130 | 131 | set vars [send $target ::namespace eval $class {info variable}] 132 | foreach var $vars { 133 | set name [namespace tail $var] 134 | set cmd [list ::namespace eval $class \ 135 | [list info variable $name -protection -type -name -init]] 136 | set text [send $target $cmd] 137 | append res " $text\n" 138 | } 139 | append res "\n" 140 | 141 | 142 | set funcs [send $target [list ::namespace eval $class {info function}]] 143 | foreach func [lsort $funcs] { 144 | set qualclass "::[string trimleft $class :]" 145 | if {[string first $qualclass $func] == 0} { 146 | set name [namespace tail $func] 147 | set cmd [list ::namespace eval $class [list info function $name]] 148 | set text [send $target $cmd] 149 | 150 | if {![string match "@itcl-builtin*" [lindex $text 4]]} { 151 | switch -exact -- $name { 152 | constructor { 153 | append res " $name [lrange $text 3 end]\n" 154 | } 155 | destructor { 156 | append res " $name [lrange $text 4 end]\n" 157 | } 158 | default { 159 | append res " [lindex $text 0] [lindex $text 1] $name\ 160 | [lrange $text 3 end]\n" 161 | } 162 | } 163 | } 164 | } 165 | } 166 | 167 | append res "}\n" 168 | return $res 169 | } 170 | 171 | method send_filter {value} { 172 | return $value 173 | } 174 | } 175 | -------------------------------------------------------------------------------- /objects_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # Written by: T. Schotanus 5 | # E-mail: sst@bouw.tno.nl 6 | # URL: http://huizen.dds.nl/~quintess 7 | # 8 | # Itcl 3.2 support by Pat Thoyts 9 | # We are hanging onto the older code to support old versions although 10 | # this needs testing. 11 | # 12 | 13 | widget object_list { 14 | object_include tkinspect_list 15 | param title "Objects" 16 | param itcl_version 0 17 | 18 | method get_item_name {} { 19 | return object 20 | } 21 | 22 | method update {target} { 23 | $self clear 24 | set cmd [list if {[::info command itcl_info] != {}} {itcl_info objects}] 25 | set objects [lsort [send $target $cmd]] 26 | if {$objects != {}} { 27 | set slot(itcl_version) [send $target ::package provide Itcl] 28 | } 29 | foreach object $objects { 30 | $self append $object 31 | } 32 | } 33 | 34 | method retrieve {target object} { 35 | if {$slot(itcl_version) != {}} { 36 | if {$slot(itcl_version) >= 3} { 37 | return [$self retrieve_new $target $object] 38 | } else { 39 | return [$self retrieve_old $target $object] 40 | } 41 | } 42 | } 43 | 44 | method retrieve_old {target object} { 45 | set class [send $target [list $object info class]] 46 | set res "$class $object {\n" 47 | 48 | set cmd [list $class :: info inherit] 49 | set inh [send $target $cmd] 50 | if {$inh != ""} { 51 | set res "$res\tinherit $inh\n\n" 52 | } else { 53 | set res "$res\n" 54 | } 55 | 56 | set pubs [send $target [list $object info public]] 57 | foreach arg $pubs { 58 | regsub {(.*)::} $arg {} a 59 | set cmd [list $object info public $a] 60 | set pub [send $target $cmd] 61 | set res "$res\tpublic $a [list [lindex $pub 2] [lindex $pub 3]] (default: [list [lindex $pub 1]])\n" 62 | } 63 | if {$pubs != ""} { 64 | set res "$res\n" 65 | } 66 | 67 | set prots [send $target [list $object info protected]] 68 | foreach arg $prots { 69 | regsub {(.*)::} $arg {} a 70 | if {$a == "this"} { 71 | continue 72 | } 73 | set cmd [list $object info protected $a] 74 | set prot [send $target $cmd] 75 | set res "$res\tprotected $a [list [lindex $prot 2]] (default: [list [lindex $prot 1]])\n" 76 | } 77 | if {$prots != ""} { 78 | set res "$res\n" 79 | } 80 | 81 | set coms [send $target [list $object info common]] 82 | foreach arg $coms { 83 | regsub {(.*)::} $arg {} a 84 | set cmd [list $object info common $a] 85 | set com [send $target $cmd] 86 | set res "$res\tcommon $a [list [lindex $com 2]] (default: [list [lindex $com 1]])\n" 87 | } 88 | if {$coms != ""} { 89 | set res "$res\n" 90 | } 91 | 92 | set meths [send $target [list $object info method]] 93 | foreach arg $meths { 94 | if {[string first $class $arg] == 0} { 95 | regsub {(.*)::} $arg {} a 96 | set cmd [list $object info method $a] 97 | set meth [send $target $cmd] 98 | if {$a != "constructor" && $a != "destructor"} { 99 | set nm "method " 100 | } else { 101 | set nm "" 102 | } 103 | if {[lindex $meth 1] != ""} { 104 | set res "$res\t$nm$a [lrange $meth 1 end]\n\n" 105 | } 106 | } 107 | } 108 | 109 | set procs [send $target [list $object info proc]] 110 | foreach arg $procs { 111 | if {[string first $class $arg] == 0} { 112 | regsub {(.*)::} $arg {} a 113 | set cmd [list $object info proc $a] 114 | set proc [send $target $cmd] 115 | if {[lindex $proc 1] != ""} { 116 | set res "$res\tproc $a [lrange $proc 1 end]\n\n" 117 | } 118 | } 119 | } 120 | 121 | set res "$res}\n" 122 | return $res 123 | } 124 | 125 | method retrieve_new {target object} { 126 | set class [send $target [list $object info class]] 127 | set res "$class $object {\n" 128 | 129 | set cmd [list $object info inherit] 130 | set inh [send $target $cmd] 131 | if {$inh != ""} { 132 | append res " inherit $inh\n\n" 133 | } else { 134 | append res "\n" 135 | } 136 | 137 | set vars [send $target $object info variable] 138 | foreach var $vars { 139 | set name [namespace tail $var] 140 | set cmd [list $object info variable $name] 141 | set text [send $target $cmd] 142 | append res " $text\n" 143 | } 144 | append res "\n" 145 | 146 | 147 | set funcs [send $target [list $object info function]] 148 | foreach func [lsort $funcs] { 149 | set qualclass "::[string trimleft $class :]" 150 | if {[string first $qualclass $func] == 0} { 151 | set name [namespace tail $func] 152 | set cmd [list $object info function $name] 153 | set text [send $target $cmd] 154 | 155 | if {![string match "@itcl-builtin*" [lindex $text 4]]} { 156 | switch -exact -- $name { 157 | constructor { 158 | append res " $name [lrange $text 3 end]\n" 159 | } 160 | destructor { 161 | append res " $name [lrange $text 4 end]\n" 162 | } 163 | default { 164 | append res " [lindex $text 0] [lindex $text 1] $name\ 165 | [lrange $text 3 end]\n" 166 | } 167 | } 168 | } 169 | } 170 | } 171 | 172 | append res "}\n" 173 | return $res 174 | } 175 | 176 | method send_filter {value} { 177 | return $value 178 | } 179 | } 180 | -------------------------------------------------------------------------------- /stl-lite/filechsr.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # filechooser implements a simple file chooser. 5 | # 6 | # This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory. 7 | # 8 | # Redistribution and use in source and binary forms, with or without 9 | # modification, are permitted provided that: (1) source code distributions 10 | # retain the above copyright notice and this paragraph in its entirety, (2) 11 | # distributions including binary code include the above copyright notice and 12 | # this paragraph in its entirety in the documentation or other materials 13 | # provided with the distribution, and (3) all advertising materials mentioning 14 | # features or use of this software display the following acknowledgement: 15 | # ``This product includes software developed by the University of California, 16 | # Lawrence Berkeley Laboratory and its contributors.'' Neither the name of 17 | # the University nor the names of its contributors may be used to endorse 18 | # or promote products derived from this software without specific prior 19 | # written permission. 20 | # 21 | # THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED 22 | # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 23 | # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 24 | # 25 | set filechooser_shortTypes(file) " " 26 | set filechooser_shortTypes(directory) DIR 27 | set filechooser_shortTypes(characterSpecial) CHR 28 | set filechooser_shortTypes(blockSpecial) BLK 29 | set filechooser_shortTypes(fifo) PIP 30 | set filechooser_shortTypes(link) LNK 31 | set filechooser_shortTypes(socket) SOK 32 | set filechooser_modeMap(0) x 33 | set filechooser_modeMap(1) w 34 | set filechooser_modeMap(2) r 35 | 36 | option add *Filechooser*Listbox*font \ 37 | -adobe-courier-bold-r-*-*-*-120-*-*-*-*-iso8859-* 38 | option add *Filechooser*status1*font \ 39 | -adobe-courier-bold-r-*-*-*-120-*-*-*-*-iso8859-* 40 | option add *Filechooser*status2*font \ 41 | -adobe-courier-bold-r-*-*-*-120-*-*-*-*-iso8859-* 42 | option add *Filechooser*Listbox*geometry 45x20 43 | 44 | dialog filechooser { 45 | param title {} 46 | param filter * 47 | param dirok 0 ;# set to 1 if open should accept directories 48 | param newfile 0 ;# set to 1 if new files are ok 49 | method create {} { 50 | set w $self 51 | wm minsize $w 100 100 52 | ttk::frame $w.list 53 | pack $w.list -in $w -side top -fill both -expand yes 54 | ttk::scrollbar $w.list.sb -command "$w.list.l yview" 55 | listbox $w.list.l -yscroll "$w.list.sb set" \ 56 | -exportselection false -selectmode single 57 | pack $w.list.sb -in $w.list -side right -fill y 58 | pack $w.list.l -in $w.list -side left -fill both -expand 1 59 | set slot(list) $w.list.l 60 | bind $w.list.l "$self open 1" 61 | bind $w.list.l [bind Listbox ] 62 | foreach ev {

} { 63 | bind $w.list.l $ev "+$self update_selection" 64 | } 65 | set b [frame $w.bottom -bd 3 -relief ridge] 66 | pack $b -side top -fill both -pady 3 -padx 3 67 | ttk::label $b.status1 -anchor w 68 | ttk::label $b.status2 -anchor w 69 | pack $b.status1 $b.status2 -side top -fill x -padx 2 70 | simpleentry $b.filter -width 30 -label "Filter:" 71 | $b.filter bind "$self filter \[$b.filter entry get\]" 72 | $b.filter entry config -textvariable [object_slotname filter] 73 | pack $b.filter -side top -fill x -padx 5 74 | simpleentry $b.file -width 30 -label "File:" 75 | $b.file bind "$self open 1 \[$b.file entry get\]" 76 | pack $b.file -side top -fill x -pady 3 -padx 5 77 | ttk::button $b.up -command "cd ..; $self fill" -text "Up" 78 | ttk:button $b.open -command "$self open 0" -text "Open" 79 | ttk::button $b.cancel -command "object_delete $w" -text "Cancel" 80 | pack $b.open $b.up -in $b -side left -ipadx 5 -ipady 5 -padx 5 -pady 5 81 | pack $b.cancel -in $b -side right -ipadx 5 -ipady 5 -padx 5 -pady 5 82 | } 83 | method run {} { 84 | tkwait visibility $self 85 | $self fill 86 | set slot(result) "" 87 | set old_dir [pwd] 88 | while [catch {grab set $self}] {} 89 | tkwait variable [object_slotname result] 90 | grab release $self 91 | if ![info exists slot(result)] { 92 | cd $old_dir 93 | return "" 94 | } 95 | cd $old_dir 96 | after 0 [list object_delete $self] 97 | return $slot(result) 98 | } 99 | method reconfig {} { 100 | wm title $self $slot(title) 101 | wm iconname $self $slot(title) 102 | } 103 | method fill {} { 104 | global filechooser_shortTypes 105 | set list $slot(list) 106 | $list delete 0 end 107 | foreach f [lsort [glob -nocomplain $slot(filter)]] { 108 | if [catch {file size $f} size] { 109 | set size 0 110 | } 111 | $list insert end \ 112 | [format "%s %6.1fk %s" $filechooser_shortTypes([file type $f]) \ 113 | [expr $size / 1024.0] [file tail $f]] 114 | } 115 | $self update_selection 116 | } 117 | method filter {filter} { 118 | set slot(filter) $filter 119 | $self fill 120 | } 121 | method get_selection {} { 122 | set l $slot(list) 123 | set sel [$l curselection] 124 | if {$sel == {}} return 125 | set file [$l get $sel] 126 | if {[llength $file] == 2} { 127 | set file [lindex $file 1] 128 | } else { 129 | set file [lindex $file 2] 130 | } 131 | return $file 132 | } 133 | method update_selection {} { 134 | $self.bottom.file entry delete 0 end 135 | set f [$self get_selection] 136 | $self.bottom.file entry insert 0 [pwd]/$f 137 | if [string length $f] { 138 | global filechooser_shortTypes filechooser_modeMap 139 | file lstat $f stat 140 | for {set bit 8} {$bit >= 0} {incr bit -1} { 141 | if {$stat(mode) & (1 << $bit)} { 142 | append mode $filechooser_modeMap([expr $bit % 3]) 143 | } else { 144 | append mode - 145 | } 146 | } 147 | set msg1 \ 148 | [format "%s %6.1fk %s %5d %5d" \ 149 | $filechooser_shortTypes($stat(type)) \ 150 | [expr $stat(size) / 1024.0] $mode $stat(gid) $stat(uid)] 151 | set msg2 [file tail $f] 152 | if {$stat(type) == "link"} { 153 | append msg2 " -> [file readlink $f]" 154 | } 155 | } else { 156 | set msg1 "" 157 | set msg2 "" 158 | } 159 | $self.bottom.status1 config -text $msg1 160 | $self.bottom.status2 config -text $msg2 161 | } 162 | method open {is_click {file ""}} { 163 | if ![string length $file] { 164 | set file [$self get_selection] 165 | } 166 | if {$slot(newfile) && ![file exists $file]} { 167 | set slot(result) $file 168 | return 169 | } 170 | if {($is_click || !$slot(dirok)) && [file isdirectory $file]} { 171 | cd $file 172 | $self fill 173 | return 174 | } 175 | set slot(result) $file 176 | } 177 | } 178 | -------------------------------------------------------------------------------- /windows_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | widget windows_list { 6 | object_include tkinspect_list 7 | param title "Windows" 8 | param get_window_info 1 9 | param filter_empty_window_configs 1 10 | param filter_window_class_config 1 11 | param filter_window_pack_in 1 12 | member mode config 13 | method get_item_name {} { return window } 14 | method create {} { 15 | tkinspect_list:create $self 16 | $slot(menu) add separator 17 | $slot(menu) add radiobutton -variable [object_slotname mode] \ 18 | -value config -label "Window Configuration" -underline 7 \ 19 | -command "$self mode_changed" 20 | $slot(menu) add radiobutton -variable [object_slotname mode] \ 21 | -value packing -label "Window Packing" -underline 7 \ 22 | -command "$self mode_changed" 23 | $slot(menu) add radiobutton -variable [object_slotname mode] \ 24 | -value slavepacking -label "Slave Window Packing" -underline 1 \ 25 | -command "$self mode_changed" 26 | $slot(menu) add radiobutton -variable [object_slotname mode] \ 27 | -value bindtagsplus -label "Window Bindtags & Bindings" \ 28 | -command "$self mode_changed" -underline 16 29 | $slot(menu) add radiobutton -variable [object_slotname mode] \ 30 | -value bindtags -label "Window Bindtags" \ 31 | -command "$self mode_changed" -underline 11 32 | $slot(menu) add radiobutton -variable [object_slotname mode] \ 33 | -value bindings -label "Window Bindings" -underline 7 \ 34 | -command "$self mode_changed" 35 | $slot(menu) add radiobutton -variable [object_slotname mode] \ 36 | -value classbindings -label "Window Class Bindings" -underline 8 \ 37 | -command "$self mode_changed" 38 | $slot(menu) add separator 39 | $slot(menu) add checkbutton \ 40 | -variable [object_slotname filter_empty_window_configs] \ 41 | -label "Filter Empty Window Options" 42 | $slot(menu) add checkbutton \ 43 | -variable [object_slotname filter_window_class_config] \ 44 | -label "Filter Window -class Options" 45 | $slot(menu) add checkbutton \ 46 | -variable [object_slotname filter_window_pack_in] \ 47 | -label "Filter Pack -in Options" 48 | $slot(menu) add separator 49 | $slot(menu) add checkbutton \ 50 | -variable [object_slotname get_window_info] \ 51 | -label "Get Window Information" -underline 0 52 | } 53 | method update_self {target} { 54 | $slot(main) windows_info update $target 55 | $self update $target 56 | } 57 | method update {target} { 58 | if !$slot(get_window_info) return 59 | $self clear 60 | foreach w [$slot(main) windows_info get_windows] { 61 | $self append $w 62 | } 63 | } 64 | method set_mode {mode} { 65 | set slot(mode) $mode 66 | $self mode_changed 67 | } 68 | method clear {} { 69 | tkinspect_list:clear $self 70 | } 71 | method mode_changed {} { 72 | if {[$slot(main) last_list] == $self} { 73 | $slot(main) select_list_item $self $slot(current_item) 74 | } 75 | } 76 | method retrieve {target window} { 77 | set result [$self retrieve_$slot(mode) $target $window] 78 | set hasbg [lsearch -exact -index 0 [send $target [list $window configure]] -background] 79 | if {$hasbg != -1} { 80 | set old_bg [send $target [list $window cget -background]] 81 | send $target [list $window configure -background #ff69b4] 82 | send $target [list after 200 \ 83 | [list catch [list $window configure -background $old_bg]]] 84 | } else { 85 | # FIXME: for ttk items toggle state active? 86 | set restorestate [send $target [list $window state active]] 87 | send $target [list after 200 [list catch [list $window state $restorestate]]] 88 | } 89 | return $result 90 | } 91 | method retrieve_config {target window} { 92 | set result "# window configuration of [list $window]\n" 93 | append result "[list $window] configure" 94 | foreach spec [send $target [list $window configure]] { 95 | if {[llength $spec] == 2} continue 96 | append result " \\\n\t[lindex $spec 0] [list [lindex $spec 4]]" 97 | } 98 | append result "\n" 99 | return $result 100 | } 101 | method format_packing_info {result_var window info} { 102 | upvar $result_var result 103 | append result "pack configure [list $window]" 104 | set len [llength $info] 105 | for {set i 0} {$i < $len} {incr i 2} { 106 | append result " \\\n\t[lindex $info $i] [lindex $info [expr $i+1]]" 107 | } 108 | append result "\n" 109 | } 110 | method retrieve_packing {target window} { 111 | set result "# packing info for [list $window]\n" 112 | if [catch {send $target [list ::pack info $window]} info] { 113 | append result "# $info\n" 114 | } else { 115 | $self format_packing_info result $window $info 116 | } 117 | return $result 118 | } 119 | method retrieve_slavepacking {target window} { 120 | set result "# packing info for slaves of [list $window]\n" 121 | foreach slave [send $target [list ::pack slaves $window]] { 122 | $self format_packing_info result $slave \ 123 | [send $target [list ::pack info $slave]] 124 | } 125 | return $result 126 | } 127 | method retrieve_bindtags {target window} { 128 | set result "# bindtags of [list $window]\n" 129 | set tags [send $target [list ::bindtags $window]] 130 | append result [list bindtags $window $tags] 131 | append result "\n" 132 | return $result 133 | } 134 | method retrieve_bindtagsplus {target window} { 135 | set result "# bindtags of [list $window]\n" 136 | set tags [send $target [list ::bindtags $window]] 137 | append result [list bindtags $window $tags] 138 | append result "\n\n# bindings (in bindtag order)..." 139 | foreach tag $tags { 140 | foreach sequence [send $target [list ::bind $tag]] { 141 | append result "\nbind $tag $sequence " 142 | append result [list [send $target [list ::bind $tag $sequence]]] 143 | } 144 | } 145 | append result "\n" 146 | return $result 147 | } 148 | method retrieve_bindings {target window} { 149 | set result "# bindings of [list $window]" 150 | foreach sequence [send $target [list ::bind $window]] { 151 | append result "\nbind $window $sequence " 152 | append result [list [send $target [list ::bind $window $sequence]]] 153 | } 154 | append result "\n" 155 | return $result 156 | } 157 | method retrieve_classbindings {target window} { 158 | set class [$slot(main) windows_info get_class $target $window] 159 | set result "# class bindings for $window\n# class: $class" 160 | foreach sequence [send $target [list ::bind $class]] { 161 | append result "\nbind $class $sequence " 162 | append result [list [send $target [list ::bind $class $sequence]]] 163 | } 164 | append result "\n" 165 | return $result 166 | } 167 | method send_filter {value} { 168 | if $slot(filter_empty_window_configs) { 169 | regsub -all {[ \t]*-[^ \t]+[ \t]+{}([ \t]*\\?\n?)?} $value {\1} \ 170 | value 171 | } 172 | if $slot(filter_window_class_config) { 173 | regsub -all "(\n)\[ \t\]*-class\[ \t\]+\[^ \\\n\]*\n?" $value \ 174 | "\\1" value 175 | } 176 | if $slot(filter_window_pack_in) { 177 | regsub -all "(\n)\[ \t\]*-in\[ \t\]+\[^ \\\n\]*\n?" $value \ 178 | "\\1" value 179 | } 180 | return $value 181 | } 182 | } 183 | -------------------------------------------------------------------------------- /globals_list.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | set variable_trace_priv(counter) -1 6 | set variable_trace_priv(trace_text) { 7 | send %s 8 | } 9 | dialog variable_trace { 10 | param target "" 11 | param variable "" 12 | param width 50 13 | param height 5 14 | param savelines 50 15 | param main 16 | member is_array 0 17 | member trace_cmd "" 18 | method create {} { 19 | pack [ttk::frame $self.menu] -side top -fill x 20 | ttk::menubutton $self.menu.file -text "File" -underline 0 \ 21 | -menu $self.menu.file.m 22 | pack $self.menu.file -side left 23 | set m [menu $self.menu.file.m] 24 | $m add command -label "Save Trace..." -command "$self save" \ 25 | -underline 0 26 | $m add separator 27 | $m add command -label "Close Window" -command "destroy $self" \ 28 | -underline 0 29 | ttk::scrollbar $self.sb -command "$self.t yview" 30 | text $self.t -yscroll "$self.sb set" -setgrid 1 31 | pack $self.sb -side right -fill y 32 | pack $self.t -side right -fill both -expand 1 33 | set where [set ::[subst $slot(main)](target,self)] 34 | if {![send $slot(target) ::array exists $slot(variable)]} { 35 | set slot(trace_cmd) "send $where $self update_scalar" 36 | $self update_scalar "" "" w 37 | set slot(is_array) 0 38 | set title "Trace Scalar" 39 | } else { 40 | set slot(trace_cmd) "send $where $self update_array" 41 | set slot(is_array) 1 42 | set title "Trace Array" 43 | } 44 | $self check_remote_send 45 | send $slot(target) \ 46 | [list ::trace variable $slot(variable) wu $slot(trace_cmd)] 47 | wm title $self "$title: $slot(target)/$slot(variable)" 48 | wm iconname $self "$title: $slot(target)/$slot(variable)" 49 | } 50 | method reconfig {} { 51 | $self.t config -width $slot(width) -height $slot(height) 52 | } 53 | method destroy {} { 54 | send $slot(target) \ 55 | [list ::trace vdelete $slot(variable) wu $slot(trace_cmd)] 56 | } 57 | method update_scalar {args} { 58 | set op [lindex $args end] 59 | if {$op == "w"} { 60 | $self.t insert end-1c \ 61 | [list set $slot(variable) \ 62 | [send $slot(target) [list ::set $slot(variable)]]] 63 | } else { 64 | $self.t insert end-1c [list unset $slot(variable)] 65 | } 66 | $self.t insert end-1c "\n" 67 | $self scroll 68 | } 69 | method update_array {args} { 70 | if {[set len [llength $args]] == 3} { 71 | set n1 [lindex $args 0] 72 | set n2 [lindex $args 1] 73 | set op [lindex $args 2] 74 | } else { 75 | set n1 [lindex $args 0] 76 | set op [lindex $args 1] 77 | } 78 | if {$op == "w"} { 79 | $self.t insert end-1c \ 80 | [list set [set slot(variable)]([set n2]) \ 81 | [send $slot(target) [list ::set [set slot(variable)]([set n2])]]] 82 | } elseif {[info exists n2]} { 83 | $self.t insert end-1c [list unset [set slot(variable)]([set n2])] 84 | } else { 85 | $self.t insert end-1c [list unset $slot(variable)] 86 | } 87 | $self.t insert end-1c "\n" 88 | $self scroll 89 | } 90 | method scroll {} { 91 | scan [$self.t index end] "%d.%d" line col 92 | if {$line > $slot(savelines)} { 93 | $self.t delete 1.0 2.0 94 | } 95 | $self.t see end 96 | } 97 | method save {} { 98 | #filechooser $self.save -title "Save $slot(variable) Trace" -newfile 1 99 | #set file [$self.save run] 100 | set file [tk_getSaveFile -title "Save $slot(variable) Trace"] 101 | if {![string length $file]} return 102 | set fp [open $file w] 103 | puts $fp [$self.t get 1.0 end] 104 | close $fp 105 | $slot(main) status "Trace saved to \"$file\"." 106 | } 107 | method check_remote_send {} { 108 | # ensure that the current target has a valid send command 109 | # This is commonly not the case under Windows. 110 | set cmd [send $slot(target) [list ::info commands ::send]] 111 | set type [set ::[subst $slot(main)](target,type)] 112 | 113 | # If we called in using 'comm' then even if we do have a built 114 | # in send we need to also support using comm. 115 | if {[string match $type "comm"]} { 116 | set script { 117 | if [string match ::send [info command ::send]] { 118 | rename ::send ::tk_send 119 | } 120 | proc send {app args} { 121 | if [string match {[0-9]*} $app] { 122 | eval ::comm::comm send [list $app] $args 123 | } else { 124 | eval ::tk_send [list $app] $args 125 | } 126 | } 127 | } 128 | set cmd [send $slot(target) $script] 129 | $slot(main) status "comm: $cmd" 130 | } 131 | 132 | if {$cmd == {}} { 133 | switch -exact -- $type { 134 | winsend { 135 | set script { 136 | ::proc ::send {app args} { 137 | eval winsend send [list $app] $args 138 | } 139 | } 140 | send $slot(target) $script 141 | } 142 | dde { 143 | set script { 144 | ::proc ::send {app args} { 145 | eval dde eval [list $app] $args 146 | } 147 | } 148 | send $slot(target) $script 149 | } 150 | default { 151 | $slot(main) status "Target requires \"send\" command." 152 | } 153 | } 154 | } 155 | return $cmd 156 | } 157 | } 158 | 159 | proc create_variable_trace {main target var} { 160 | global variable_trace_priv 161 | variable_trace .vt[incr variable_trace_priv(counter)] -target $target \ 162 | -variable $var -main $main 163 | } 164 | 165 | widget globals_list { 166 | object_include tkinspect_list 167 | param title "Globals" 168 | method get_item_name {} { return global } 169 | method create {} { 170 | tkinspect_list:create $self 171 | $slot(menu) add separator 172 | $slot(menu) add command -label "Trace Variable" -underline 0 \ 173 | -command "$self trace_variable" 174 | } 175 | method update {target} { 176 | $self clear 177 | foreach var [lsort [names::vars $target]] { 178 | $self append $var 179 | } 180 | } 181 | method retrieve {target var} { 182 | if ![send $target [list array exists $var]] { 183 | #return [list set $var [send $target [list set $var]]] 184 | set cmd [list set $var] 185 | set retcode [catch [list send $target $cmd] msg] 186 | if {$retcode != 0} { 187 | return "Info: $var has not been defined\n ($msg)\n" 188 | } else { 189 | return [list set $var $msg] 190 | } 191 | } 192 | set result {} 193 | set names [lsort [send $target [list ::array names $var]]] 194 | if {[llength $names] == 0} { 195 | append result "array set $var {}\n" 196 | } else { 197 | foreach elt $names { 198 | append result [list set [set var]($elt) \ 199 | [send $target [list ::set [set var]($elt)]]] 200 | append result "\n" 201 | } 202 | } 203 | return $result 204 | } 205 | method send_filter {value} { 206 | return $value 207 | } 208 | method trace_variable {} { 209 | set target [$slot(main) target] 210 | if ![string length $slot(current_item)] { 211 | tkinspect_failure \ 212 | "No global variable has been selected. Please select one first." 213 | } 214 | create_variable_trace $slot(main) $target $slot(current_item) 215 | } 216 | } 217 | -------------------------------------------------------------------------------- /install.tcl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # \ 3 | exec wish "$0" ${1+"$@"} 4 | # 5 | # $Id$ 6 | # 7 | # Installation script for Tkinspect release 5. To install: 8 | # 9 | # 1. Go to the tkinspect source directory. 10 | # 2. Type: wish -f install.tcl. 11 | # 3. Fill out the form. 12 | # 4. Hit the install button. If all goes well, the last line in 13 | # the log window should be "Installed finished." 14 | # 15 | 16 | if ![file exists tclIndex] { 17 | puts "Generating auto loader index..." 18 | auto_mkindex . *.tcl 19 | } 20 | 21 | set tkinspect_library . 22 | lappend auto_path . 23 | 24 | version_init 25 | stl_lite_init 26 | 27 | widget install_path { 28 | param label 29 | param variable 30 | method create {} { 31 | ttk::entry $self.e -width 60 32 | ttk::label $self.l 33 | pack $self.e -side right 34 | pack $self.l -side left 35 | } 36 | method reconfig {} { 37 | $self.l config -text $slot(label) 38 | $self.e config -textvariable $slot(variable) 39 | } 40 | } 41 | 42 | widget install_dir { 43 | object_include install_path 44 | method verify {} { 45 | upvar #0 $slot(variable) dir 46 | set dir [uplevel #0 [list subst $dir]] 47 | if ![file exists $dir] { 48 | set ans [tk_dialog .mkdir "Create Directory?" "The directroy $dir does not exists, should I create it?" question 0 "Yes" "Cancel Install"] 49 | if {$ans == 1} { 50 | return 0 51 | } 52 | if [catch {file mkdir $dir} msg] { 53 | tk_dialog .error "Error Making Directory" "Couldn't make directory $dir: $msg" error 0 "Ok" 54 | return 0 55 | } 56 | } 57 | return 1 58 | } 59 | } 60 | 61 | widget install_exec { 62 | object_include install_path 63 | method verify {} { 64 | upvar #0 $slot(variable) file 65 | set file [uplevel #0 [list subst $file]] 66 | if ![file executable $file] { 67 | tk_dialog .error "Error" "Executable $file isn't executable!" error 0 "Ok" 68 | return 0 69 | } 70 | return 1 71 | } 72 | } 73 | 74 | ttk::label .title -text "Tkinspect Installation" \ 75 | -font -adobe-helvetica-bold-r-*-*-*-180-*-*-*-*-*-* 76 | ttk::label .title2 -text "Release $tkinspect(release) ($tkinspect(release_date))" \ 77 | -font -*-helvetica-medium-r-*-*-12-* 78 | pack .title .title2 -side top 79 | 80 | text .instructions -width 20 -height 4 -wrap word \ 81 | -takefocus 0 -background white 82 | .instructions insert 1.0 \ 83 | {Fill out the pathnames below and press the install button. Any errors will appear in log window below. If you wish to demo tkinspect w/o installing it, try "wish -f tkinspect.tcl". 84 | } 85 | pack .instructions -side top -fill both -expand 1 86 | 87 | switch -exact -- $tcl_platform(platform) { 88 | unix { set prefix /usr/local } 89 | windows - 90 | macintosh { 91 | set prefix [eval file join [lrange \ 92 | [file split [info nameofexecutable]] 0 end-2]] 93 | } 94 | } 95 | set bindir \$prefix/bin 96 | set libdir \$prefix/lib/tkinspect 97 | 98 | install_dir .prefix -label Prefix: -variable prefix 99 | install_dir .bindir -label "Bin dir:" -variable bindir 100 | install_dir .libdir -label "Library dir:" -variable libdir 101 | 102 | 103 | install_exec .wish -label "Wish executable:" -variable wish 104 | pack .prefix .bindir .libdir .wish -side top -fill x 105 | 106 | text .log -width 70 -height 10 -takefocus 0 107 | pack .log -side top -fill both -expand 1 108 | 109 | ttk::frame .buttons 110 | pack .buttons -side top 111 | ttk::button .install -text "Install" -command do_install 112 | ttk::button .cancel -text "Exit" -command "destroy ." 113 | pack .install .cancel -in .buttons -side left -padx .1c 114 | 115 | wm title . "Tkinspect Installation" 116 | center_window . 117 | 118 | proc log {msg} { 119 | .log insert end "$msg" 120 | .log see end 121 | update 122 | } 123 | 124 | set wish [info nameofexecutable] 125 | 126 | #foreach name {wish8.4 wish8.3 wish8.0 wish4.0 wish} { 127 | # log "Searching for $name..." 128 | # foreach dir [split $env(PATH) :] { 129 | # if [file executable [file join $dir $name]] { 130 | # set wish [file join $dir $name] 131 | # break 132 | # } 133 | # } 134 | # if ![info exists wish] { 135 | # log "not found!\n" 136 | # continue 137 | # } 138 | # break 139 | #} 140 | if [info exists wish] { 141 | log "using $wish\n" 142 | } else { 143 | set wish /usr/local/bin/wish8.3 144 | log "Hmm, using $wish anyways...\n" 145 | } 146 | 147 | proc install_files {dir files} { 148 | global tcl_platform 149 | foreach file $files { 150 | log "Copying $file to $dir..." 151 | if {[catch { 152 | set dest [file join $dir [file tail $file]] 153 | file copy -force $file $dest 154 | switch -exact -- $tcl_platform(platform) { 155 | unix { file attributes $dest -permissions 0444 } 156 | windows - 157 | macintosh { file attributes $dest -readonly 1 } 158 | default { 159 | error "platform $tcl_platform(platform) not recognised" 160 | } 161 | } 162 | } errmsg]} { 163 | log "whoops: $errmsg, install aborted.\n" 164 | return 0 165 | } 166 | log "ok.\n" 167 | } 168 | return 1 169 | } 170 | 171 | proc regsub_quote {string} { 172 | regsub -all {\\([0-9])} $string {\\\\\1} string 173 | regsub -all "&" $string {\\&} string 174 | return $string 175 | } 176 | 177 | proc install {} { 178 | global prefix libdir bindir wish tcl_platform 179 | foreach w {.prefix .bindir .libdir .wish} { 180 | log "Checking [$w cget -variable]..." 181 | if ![$w verify] { 182 | log "install aborted\n" 183 | return 184 | } 185 | log "ok.\n" 186 | } 187 | if ![file isdirectory [file join $libdir stl-lite]] { 188 | log "Making $libdir/stl-lite directory..." 189 | if [catch {file mkdir [file join $libdir stl-lite]} error] { 190 | log "whoops: $error, install aborted.\n" 191 | return 192 | } 193 | log "ok.\n" 194 | } 195 | if ![install_files $libdir { 196 | about.tcl defaults.tcl windows_info.tcl lists.tcl globals_list.tcl 197 | procs_list.tcl windows_list.tcl images_list.tcl menus_list.tcl 198 | canvas_list.tcl value.tcl stl.tcl sls.ppm version.tcl help.tcl 199 | cmdline.tcl interface.tcl tclIndex ChangeLog 200 | names.tcl classes_list.tcl objects_list.tcl 201 | afters_list.tcl namespaces_list.tcl 202 | Intro.html Lists.html Procs.html Globals.html Windows.html 203 | Images.html Canvases.html Menus.html Classes.html 204 | Value.html Miscellany.html Notes.html WhatsNew.html 205 | }] { 206 | return 207 | } 208 | 209 | if ![install_files $libdir/stl-lite { 210 | stl-lite/filechsr.tcl stl-lite/simpleentry.tcl stl-lite/object.tcl 211 | stl-lite/tk_util.tcl stl-lite/feedback.tcl stl-lite/tkhtml.tcl 212 | }] { 213 | return 214 | } 215 | log "Making tkinspect shell script..." 216 | if [catch { 217 | set progname tkinspect 218 | if {$tcl_platform(platform) == "windows"} { 219 | append progname .tcl 220 | } 221 | file delete -force [file join $bindir $progname] 222 | set fp [open tkinspect.tcl r] 223 | set text [read $fp] 224 | close $fp 225 | regsub -all @tkinspect_library@ $text [regsub_quote $libdir] text 226 | regsub -all @wish@ $text [regsub_quote $wish] text 227 | set fp [open [file join $bindir $progname] w] 228 | puts $fp $text 229 | close $fp 230 | if {$tcl_platform(platform) == "unix"} { 231 | file attributes [file join $bindir $progname] -permissions 0555 232 | } 233 | } error] { 234 | log "whoops: $error, install aborted.\n" 235 | return 236 | } 237 | log "ok.\n" 238 | log "Install finished.\n" 239 | } 240 | 241 | proc do_install {} { 242 | toplevel .grab 243 | wm withdraw .grab 244 | while [catch {grab set .grab}] {} 245 | set old_focus [focus -lastfor .grab] 246 | focus .grab 247 | install 248 | grab release .grab 249 | focus $old_focus 250 | destroy .grab 251 | } 252 | -------------------------------------------------------------------------------- /stl-lite/object.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory. 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that: (1) source code distributions 8 | # retain the above copyright notice and this paragraph in its entirety, (2) 9 | # distributions including binary code include the above copyright notice and 10 | # this paragraph in its entirety in the documentation or other materials 11 | # provided with the distribution, and (3) all advertising materials mentioning 12 | # features or use of this software display the following acknowledgement: 13 | # ``This product includes software developed by the University of California, 14 | # Lawrence Berkeley Laboratory and its contributors.'' Neither the name of 15 | # the University nor the names of its contributors may be used to endorse 16 | # or promote products derived from this software without specific prior 17 | # written permission. 18 | # 19 | # THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED 20 | # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 21 | # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 22 | 23 | set object_priv(currentClass) {} 24 | set object_priv(objectCounter) 0 25 | 26 | proc object_class {name spec} { 27 | global object_priv 28 | set object_priv(currentClass) $name 29 | lappend object_priv(objects) $name 30 | upvar #0 ${name}_priv class 31 | set class(members) {} 32 | set class(params) {} 33 | eval $spec 34 | proc $name:config args "uplevel \[concat object_config \$args]" 35 | proc $name:configure args "uplevel \[concat object_config \$args]" 36 | proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]" 37 | } 38 | 39 | proc method {name args body} { 40 | global object_priv 41 | set className $object_priv(currentClass) 42 | upvar #0 ${className}_priv class 43 | lappend class(methods) $name 44 | set methodArgs self 45 | append methodArgs " " $args 46 | proc $className:$name $methodArgs "upvar #0 \$self slot\n$body" 47 | } 48 | 49 | proc member {name {defaultValue {}}} { 50 | global object_priv 51 | set className $object_priv(currentClass) 52 | upvar #0 ${className}_priv class 53 | if ![info exists class(member_info/$name)] { 54 | lappend class(members) [list $name $defaultValue] 55 | } 56 | set class(member_info/$name) {} 57 | } 58 | 59 | proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} { 60 | global object_priv 61 | set className $object_priv(currentClass) 62 | upvar #0 ${className}_priv class 63 | if {$resourceClass == ""} { 64 | set resourceClass \ 65 | [string toupper [string index $name 0]][string range $name 1 end] 66 | } 67 | if ![info exists class(param_info/$name)] { 68 | lappend class(params) $name 69 | } 70 | set class(param_info/$name) [list $defaultValue $resourceClass] 71 | if {$configCode != {}} { 72 | proc $className:config:$name self $configCode 73 | } 74 | } 75 | 76 | proc object_include {super_class_name} { 77 | global object_priv 78 | set className $object_priv(currentClass) 79 | upvar #0 ${className}_priv class 80 | upvar #0 ${super_class_name}_priv super_class 81 | foreach p $super_class(params) { 82 | lappend class(params) $p 83 | set class(param_info/$p) $super_class(param_info/$p) 84 | } 85 | set class(members) [concat $super_class(members) $class(members)] 86 | foreach m $super_class(methods) { 87 | set formals {} 88 | set proc $super_class_name:$m 89 | foreach arg [info args $proc] { 90 | if [info default $proc $arg def] { 91 | lappend formals [list $arg $def] 92 | } else { 93 | lappend formals $arg 94 | } 95 | } 96 | proc $className:$m $formals [info body $proc] 97 | } 98 | } 99 | 100 | proc object_new {className {name {}}} { 101 | if {$name == {}} { 102 | global object_priv 103 | set name O_[incr object_priv(objectCounter)] 104 | } 105 | upvar #0 $name object 106 | upvar #0 ${className}_priv class 107 | set object(__class) $className 108 | foreach var $class(params) { 109 | set info $class(param_info/$var) 110 | set resourceClass [lindex $info 1] 111 | if ![catch {set val [option get $name $var $resourceClass]}] { 112 | if {$val == ""} { 113 | set val [lindex $info 0] 114 | } 115 | } else { 116 | set val [lindex $info 0] 117 | } 118 | set object($var) $val 119 | } 120 | foreach var $class(members) { 121 | set object([lindex $var 0]) [lindex $var 1] 122 | } 123 | proc $name {method args} [format { 124 | upvar #0 %s object 125 | uplevel [concat $object(__class):$method %s $args] 126 | } $name $name] 127 | return $name 128 | } 129 | 130 | proc object_define_creator {windowType name spec} { 131 | object_class $name $spec 132 | if {[info procs $name:create] == {}} { 133 | error "widget \"$name\" must define a create method" 134 | } 135 | if {[info procs $name:reconfig] == {}} { 136 | error "widget \"$name\" must define a reconfig method" 137 | } 138 | proc $name {window args} [format { 139 | %s $window -class %s 140 | rename $window object_window_of$window 141 | upvar #0 $window object 142 | set object(__window) $window 143 | object_new %s $window 144 | proc %s:frame {self args} \ 145 | "uplevel \[concat object_window_of$window \$args]" 146 | uplevel [concat $window config $args] 147 | if {[winfo toplevel $window] eq $window} { 148 | ttk::frame $window.pave 149 | place $window.pave -x 0 -y 0 -relwidth 1.0 -relheight 1.0 150 | lower $window.pave 151 | } 152 | $window create 153 | set object(__created) 1 154 | bind $window \ 155 | "if !\[string compare %%W $window\] { object_delete $window }" 156 | $window reconfig 157 | return $window 158 | } $windowType \ 159 | [string toupper [string index $name 0]][string range $name 1 end] \ 160 | $name $name] 161 | } 162 | 163 | proc widget {name spec} { 164 | object_define_creator ttk::frame $name $spec 165 | } 166 | 167 | proc dialog {name spec} { 168 | object_define_creator toplevel $name $spec 169 | } 170 | 171 | proc object_config {self args} { 172 | upvar #0 $self object 173 | set len [llength $args] 174 | if {$len == 0} { 175 | upvar #0 $object(__class)_priv class 176 | set result {} 177 | foreach param $class(params) { 178 | set info $class(param_info/$param) 179 | lappend result \ 180 | [list -$param $param [lindex $info 1] [lindex $info 0] \ 181 | $object($param)] 182 | } 183 | if [info exists object(__window)] { 184 | set result [concat $result [object_window_of$object(__window) config]] 185 | } 186 | return $result 187 | } 188 | if {$len == 1} { 189 | upvar #0 $object(__class)_priv class 190 | if {[string index $args 0] != "-"} { 191 | error "param '$args' didn't start with dash" 192 | } 193 | set param [string range $args 1 end] 194 | if {[set ndx [lsearch -exact $class(params) $param]] == -1} { 195 | if [info exists object(__window)] { 196 | return [object_window_of$object(__window) config -$param] 197 | } 198 | error "no param '$args'" 199 | } 200 | set info $class(param_info/$param) 201 | return [list -$param $param [lindex $info 1] [lindex $info 0] \ 202 | $object($param)] 203 | } 204 | # accumulate commands and eval them later so that no changes will take 205 | # place if we find an error 206 | set cmds "" 207 | while {$args != ""} { 208 | set fieldId [lindex $args 0] 209 | if {[string index $fieldId 0] != "-"} { 210 | error "param '$fieldId' didn't start with dash" 211 | } 212 | set fieldId [string range $fieldId 1 end] 213 | if ![info exists object($fieldId)] { 214 | if {[info exists object(__window)]} { 215 | if [catch [list object_window_of$object(__window) config -$fieldId]] { 216 | error "tried to set param '$fieldId' which did not exist." 217 | } else { 218 | lappend cmds \ 219 | [list object_window_of$object(__window) config -$fieldId [lindex $args 1]] 220 | set args [lrange $args 2 end] 221 | continue 222 | } 223 | } 224 | 225 | } 226 | if {[llength $args] == 1} { 227 | return $object($fieldId) 228 | } else { 229 | lappend cmds [list set object($fieldId) [lindex $args 1]] 230 | if {[info procs $object(__class):config:$fieldId] != {}} { 231 | lappend cmds [list $self config:$fieldId] 232 | } 233 | set args [lrange $args 2 end] 234 | } 235 | } 236 | foreach cmd $cmds { 237 | eval $cmd 238 | } 239 | if {[info exists object(__created)] && [info procs $object(__class):reconfig] != {}} { 240 | $self reconfig 241 | } 242 | } 243 | 244 | proc object_cget {self var} { 245 | upvar #0 $self object 246 | return [lindex [object_config $self $var] 4] 247 | } 248 | 249 | proc object_delete self { 250 | upvar #0 $self object 251 | if {[info exists object(__class)] && [info commands $object(__class):destroy] != ""} { 252 | $object(__class):destroy $self 253 | } 254 | if [info exists object(__window)] { 255 | if [string length [info commands object_window_of$self]] { 256 | catch {rename $self {}} 257 | rename object_window_of$self $self 258 | } 259 | destroy $self 260 | } 261 | catch {unset object} 262 | } 263 | 264 | proc object_slotname slot { 265 | upvar self self 266 | return [set self]($slot) 267 | } 268 | -------------------------------------------------------------------------------- /lists.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | 5 | dialog filter_editor { 6 | param list 7 | member patterns 8 | member filter_type exclude 9 | method create {} { 10 | ttk::frame $self.top 11 | ttk::label $self.l -text "Pattern:" 12 | ttk::entry $self.e -width 40 13 | bind $self.e "$self add_pattern" 14 | pack $self.l -in $self.top -side left 15 | pack $self.e -in $self.top -side left -fill x 16 | pack $self.top -side top -fill x -pady .25c 17 | ttk::frame $self.buttons 18 | ttk::button $self.ok -text "Apply" -command "$self apply" 19 | ttk::button $self.close -text "Cancel" -command "wm withdraw $self" 20 | ttk::button $self.add -text "Add Pattern" \ 21 | -command "$self add_pattern" 22 | ttk::button $self.del -text "Delete Pattern(s)" \ 23 | -command "$self delete_patterns" 24 | ttk::radiobutton $self.inc -variable [object_slotname filter_type] \ 25 | -value include -text "Include Patterns" 26 | ttk::radiobutton $self.exc -variable [object_slotname filter_type] \ 27 | -value exclude -text "Exclude Patterns" 28 | pack $self.inc $self.exc $self.add $self.del -in $self.buttons \ 29 | -side top -fill x -pady .1c -anchor w 30 | pack $self.close $self.ok -in $self.buttons \ 31 | -side bottom -fill x -pady .1c 32 | pack $self.buttons -in $self -side left -fill y 33 | ttk::frame $self.lframe 34 | ttk::scrollbar $self.sb -command "$self.list yview" 35 | listbox $self.list -yscroll "$self.sb set" -relief raised \ 36 | -width 40 -height 10 -selectmode multiple -background white 37 | pack $self.sb -in $self.lframe -side right -fill y 38 | pack $self.list -in $self.lframe -side right -fill both -expand yes 39 | pack $self.lframe -in $self -side right -fill both -expand yes 40 | set title "Edit [$slot(list) cget -title] Filter" 41 | wm title $self $title 42 | foreach pat [$slot(list) cget -patterns] { 43 | $self.list insert end $pat 44 | lappend slot(patterns) $pat 45 | } 46 | } 47 | method reconfig {} { 48 | } 49 | method apply {} { 50 | $slot(list) config -patterns $slot(patterns) \ 51 | -filter_type $slot(filter_type) 52 | $slot(list) update_needed 53 | wm withdraw $self 54 | } 55 | method add_pattern {} { 56 | set pat [$self.e get] 57 | if {[string length $pat]} { 58 | lappend slot(patterns) $pat 59 | $self.list insert end $pat 60 | } 61 | } 62 | method delete_patterns {} { 63 | while {[string length [set s [$self.list curselection]]]} { 64 | set pat [$self.list get [lindex $s 0]] 65 | set ndx [lsearch -exact $slot(patterns) $pat] 66 | set slot(patterns) [lreplace $slot(patterns) $ndx $ndx] 67 | $self.list delete [lindex $s 0] 68 | } 69 | } 70 | } 71 | 72 | dialog list_search { 73 | param list 74 | param search_type exact 75 | method create {} { 76 | ttk::frame $self.top 77 | pack $self.top -side top -fill x 78 | ttk::label $self.l -text "Search for:" 79 | ttk::entry $self.e 80 | bind $self.e "$self search" 81 | pack $self.l -in $self.top -side left 82 | pack $self.e -in $self.top -fill x -expand 1 83 | ttk::checkbutton $self.re -variable [object_slotname search_type] \ 84 | -onvalue regexp -offvalue exact -text "Regexp search" 85 | pack $self.re -side top -anchor w 86 | ttk::button $self.go -text "Find Next" -command "$self search" 87 | ttk::button $self.reset -text "Reset Search" -command "$self reset" 88 | ttk::button $self.close -text "Close" -command "destroy $self" 89 | pack $self.go $self.reset $self.close -side left 90 | set title "Find in [$slot(list) get_item_name] List..." 91 | wm title $self $title 92 | focus $self.e 93 | $slot(list) reset_search 94 | } 95 | method reconfig {} { 96 | } 97 | method reset {} { 98 | $slot(list) reset_search 1 99 | } 100 | method search {} { 101 | set text [$self.e get] 102 | if ![string length $text] return 103 | $slot(list) search $slot(search_type) $text 104 | } 105 | } 106 | 107 | dialog list_show { 108 | param list 109 | method create {} { 110 | ttk::frame $self.top 111 | pack $self.top -side top -fill x 112 | ttk::label $self.l -text "Show:" 113 | ttk::entry $self.e 114 | bind $self.e "$self show" 115 | pack $self.l -in $self.top -side left 116 | pack $self.e -in $self.top -fill x -expand 1 117 | ttk::button $self.show -text "Show" -command "$self show" 118 | ttk::button $self.close -text "Close" -command "destroy $self" 119 | pack $self.show $self.close -side left 120 | wm title $self "Show a [$slot(list) get_item_name]" 121 | focus $self.e 122 | } 123 | method reconfig {} { 124 | } 125 | method show {} { 126 | set item [$self.e get] 127 | $slot(list) run_command $item 128 | wm withdraw $self 129 | } 130 | } 131 | 132 | widget tkinspect_list { 133 | param command {} 134 | param title {} 135 | param width 15 136 | param height 12 137 | param main 138 | param patterns {} 139 | param filter_type exclude 140 | member current_item 141 | member menu 142 | member contents {} 143 | member search_index 0 144 | method create {} { 145 | $self configure -borderwidth 0 -relief raised 146 | pack [ttk::label $self.title -anchor w] -side top -fill x 147 | ttk::frame $self.frame 148 | pack $self.frame -side top -fill x 149 | ttk::scrollbar $self.sb -command "$self.list yview" 150 | ttk::scrollbar $self.sb2 -command "$self.list xview" -orient horizontal 151 | listbox $self.list -borderwidth 1 -relief groove -exportselection 0 \ 152 | -yscroll "$self.sb set" -selectmode single \ 153 | -xscroll "$self.sb2 set" -background white 154 | bind $self.list <1> "$self click %x %y; continue" 155 | bind $self.list "$self trigger; continue" 156 | pack $self.sb -in $self.frame -side right -fill y 157 | pack $self.list -in $self.frame -side right -fill both -expand yes 158 | pack $self.sb2 -side bottom -fill x 159 | set slot(menu) [$slot(main) add_menu $slot(title)] 160 | bind $self.list <3> "tk_popup $slot(menu) %X %Y" 161 | $slot(menu) add command \ 162 | -label "Show a [$self get_item_name]..." -underline 0 \ 163 | -command "$self show_dialog" 164 | $slot(menu) add command -label "Find $slot(title)..." -underline 0 \ 165 | -command "$self search_dialog" 166 | $slot(menu) add command -label "Edit Filter..." -underline 0 \ 167 | -command "$self edit_filter" 168 | $slot(menu) add command -label "Update This List" -underline 0 \ 169 | -command "$self do_update_self" 170 | $slot(menu) add command -label "Remove This List" -underline 0 \ 171 | -command "$self remove" 172 | } 173 | method reconfig {} { 174 | $self.title config -text "$slot(title):" 175 | $self.list config -width $slot(width) -height $slot(height) 176 | } 177 | method clear {} { 178 | set slot(contents) "" 179 | $self update_needed 180 | } 181 | method append {item} { 182 | lappend slot(contents) $item 183 | $self update_needed 184 | } 185 | method update_needed {} { 186 | if ![info exists slot(update_pending)] { 187 | set slot(update_pending) 1 188 | after idle "if \[winfo exists $self\] \"$self do_update\"" 189 | } 190 | } 191 | method do_update {} { 192 | unset slot(update_pending) 193 | $self.list delete 0 end 194 | if {$slot(filter_type) == "exclude"} { 195 | set x 1 196 | } else { 197 | set x 0 198 | } 199 | foreach item $slot(contents) { 200 | set include $x 201 | foreach pattern $slot(patterns) { 202 | if [regexp -- $pattern $item] { 203 | set include [expr !$x] 204 | break 205 | } 206 | } 207 | if $include { 208 | $self.list insert end $item 209 | } 210 | } 211 | } 212 | # lists will have 2 methods, update and update_self. update will 213 | # be called when all the lists are updated. update_self will be 214 | # called when just this list is updated. update_self defaults 215 | # to being just update. 216 | method update_self {target} { $self update $target } 217 | method do_update_self {} { $self update_self [$slot(main) target] } 218 | method click {x y} { 219 | $self run_command [$self.list get @$x,$y] 220 | } 221 | method trigger {} { 222 | set selection [$self.list curselection] 223 | if ![llength $selection] return 224 | $self run_command [$self.list get [lindex $selection 0]] 225 | } 226 | method run_command {item} { 227 | if [string length $slot(command)] { 228 | set slot(current_item) $item 229 | if [string length $slot(current_item)] { 230 | uplevel #0 [concat $slot(command) [list $slot(current_item)]] 231 | } 232 | } 233 | } 234 | method remove {} { 235 | $slot(main) delete_menu $slot(title) 236 | $slot(main) delete_list $self 237 | object_delete $self 238 | } 239 | method edit_filter {} { 240 | if [winfo exists $self.editor] { 241 | wm deiconify $self.editor 242 | } else { 243 | filter_editor $self.editor -list $self 244 | center_window $self.editor 245 | } 246 | } 247 | method search_dialog {} { 248 | if ![winfo exists $self.search] { 249 | list_search $self.search -list $self 250 | center_window $self.search 251 | } else { 252 | wm deiconify $self.search 253 | } 254 | } 255 | method reset_search {{set_see 0}} { 256 | set slot(search_index) 0 257 | if $set_see { 258 | $self.list see 0 259 | } 260 | } 261 | method search {search_type text} { 262 | foreach item [$self.list get $slot(search_index) end] { 263 | set found 0 264 | if {$search_type == "regexp" && [regexp $text $item]} { 265 | set found 1 266 | } elseif {[string first $text $item] != -1} { 267 | set found 1 268 | } 269 | if $found { 270 | $self.list selection clear 0 end 271 | $self.list selection set $slot(search_index) 272 | $self.list see $slot(search_index) 273 | incr slot(search_index) 274 | $self run_command $item 275 | break 276 | } 277 | incr slot(search_index) 278 | } 279 | if !$found { 280 | $slot(main) status "Didn't find \"$text\"" 281 | $self reset_search 282 | } 283 | } 284 | method show_dialog {} { 285 | if ![winfo exists $self.show] { 286 | list_show $self.show -list $self 287 | center_window $self.show 288 | } else { 289 | wm deiconify $self.show 290 | } 291 | } 292 | } 293 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | Sun Jun 22 22:15:38 2003 Pat Thoyts 2 | 3 | * tkinspect.tcl: Ensure the correct name is registered under X 4 | Windows Tk so that traces work here too. 5 | 6 | Sat Jun 21 22:35:03 2003 Pat Thoyts 7 | 8 | * tkinspect.tcl: Merged in patch for paned views suppplied by 9 | Alexander Caldwell . 10 | * lists.tcl: Also from AC's patch - added a horizontal scroll bar 11 | to the view windows. 12 | * tkinspect.tcl: Flattened various GUI items to improve the appearence 13 | 14 | Fri Jun 20 23:59:01 2003 Pat Thoyts 15 | 16 | * tkinspect.tcl: Fix for bug #757926 to fix traces. 17 | * version.tcl: Set version to 5.1.6p10 18 | * about.tcl: Added a list of contributors to the dialog. 19 | * windows_info.tcl: Namespace qualify more sent commands. 20 | 21 | Thu Mar 20 10:01:59 2003 Pat Thoyts 22 | 23 | * windows_list.tcl: Applied patch from bug #684608 by Achim Bursian 24 | for garbled bindings display in the window view. 25 | 26 | Mon Oct 21 22:42:34 2002 Pat Thoyts 27 | 28 | * afters_list.tcl: 29 | * classes_list.tcl: 30 | * globals_list.tcl: 31 | * images_list.tcl: 32 | * names.tcl: 33 | * objects_list.tcl: 34 | * procs_list.tcl: 35 | * windows_list.tcl: bug # 624268 - always namespace qualify commands 36 | sent to the inspectee to avoid name clashes. 37 | * help.tcl: Fixed bug #624634 - formatting of ChangeLog view. 38 | 39 | Wed Oct 09 01:27:43 2002 Pat Thoyts 40 | 41 | * tkinspect.tcl: 42 | * globals_list.tcl: Implemented trace for all the supported 'send' 43 | varieties. This fixes bug #533493. 44 | 45 | Sat Apr 20 01:27:46 2002 Pat Thoyts 46 | 47 | * windows_list.tcl: Fixed bug #546259: erroneous use of 'config' 48 | 49 | Thu Apr 04 22:38:44 2002 Pat Thoyts 50 | 51 | * globals_list.tcl: 52 | * names.tcl: fix array checking (use array exists). 53 | * tkinspect.tcl: merged in support for scripted documents (patch 54 | by Steve Landers). Use the winsend package if available. 55 | 56 | Mon Mar 25 12:05:22 2002 Pat Thoyts 57 | 58 | * Bug #533899: Found and merged Paul Healy's 1997 p4 patch which adds 59 | a 'namespaces' and an 'after' viewer. Comments from the patch: 60 | - fix the `Value:' history menu so that it respects changes to target 61 | interpreters. The `clear' method is broken? 62 | - snapshot afters so that you (nearly would) always to get to see the 63 | scripts associated with an after id at a particular time. Also make 64 | the afters menu more meaningful. 65 | * classes_list.tcl: 66 | * objects_list.tcl: Improved the incr Tcl support. 67 | * README: modernised the README file. 68 | 69 | Sun Mar 24 23:50:29 2002 Pat Thoyts 70 | 71 | * Bug #533899: gracefully handle unavailable 'comm' package 72 | * Bug #532905: fix the installer. 73 | 74 | Fri Mar 22 15:53:54 2002 Pat Thoyts 75 | 76 | * names.tcl: Bug #533642: send ::info in case info is redefined. 77 | * help.tcl: Get the html help viewer to accept non-html filenames. 78 | * windows_info.tcl: handle interps without Tk commands 79 | * images_list.tcl: handle interps without Tk commands 80 | 81 | Fri Mar 22 01:04:59 2002 Pat Thoyts 82 | 83 | * version.tcl: Released version 5.1.6p7 84 | * globals_list.tcl: 85 | * value.tcl: Bug #533367: use default Tk file selection dialogs. 86 | 87 | Thu Mar 21 15:27:53 2002 Pat Thoyts 88 | 89 | * tkinspect.tcl: Improved the dde send implementation and fixed 90 | the window title to show the application name. 91 | * globals_list.tcl: Bug #533164: Fixed the retrieve for empty 92 | arrays. 93 | * windows_info.tcl: Bug #532909: Fixed 'winfo' error handling for 94 | non-Tk applications when using 'comm' 95 | 96 | Thu Mar 21 00:32:17 2002 Pat Thoyts 97 | 98 | * tkinspect.tcl: Fixed problem with application not closing 99 | properly if not closed via the menu item. 100 | * tkinspect.tcl: Added OK and Cancel buttons to improve the 101 | handling of the comm connection dialog. 102 | 103 | Tue Mar 19 09:12:54 2002 Pat Thoyts 104 | 105 | * tkinspect.tcl: Added a dde implementation of 'send' for use on 106 | Windows. 107 | 108 | Thu Mar 14 12:09:24 2002 Pat Thoyts 109 | 110 | * classes_list.tcl: Updated to support itcl 3.2 info syntax 111 | * objects_list.tcl: Updated to support itcl 3.2 info syntax 112 | * Classes.html: new page to describe the classes list window. 113 | * tkinspect.tcl: fixed the About help menu item. 114 | * version.tcl: incremented version to p6. 115 | 116 | Fri Mar 2 00:13:08 2002 Pat Thoyts 117 | 118 | * tkinspect: applied T. Schotanus incr Tcl support patch. This 119 | provides itcl support for older (pre 3.x?) itcl versions. 120 | 121 | Fri Mar 1 23:37:21 2002 Pat Thoyts 122 | 123 | * tkinspect: applied John LoVerso's 1996 comm patch to support 124 | systems without the Tk send command. 125 | 126 | Sun Dec 14 19:46:05 1997 Paul Healy 127 | 128 | * tkinspect: describe patch procedure to get around diff/patch/RCS 129 | interaction. Released p3. 130 | 131 | Sun Nov 23 22:14:36 1997 Paul Healy 132 | 133 | * tkinspect: handle procedures and variables inside namespaces 134 | 135 | Sun Oct 5 20:09:10 1997 Paul Healy 136 | 137 | * tkinspect: handle the disappearance of the tkerror proc in tk8.0 138 | Released p2. 139 | 140 | Fri Jun 23 00:20:15 1995 Sam Shen 141 | 142 | * version.tcl: Bump to 5.1.6. 143 | 144 | * README: Update to 5.1.6. 145 | 146 | * WhatsNew.html: Note changes in 5.1.6. 147 | 148 | * Miscellany.html: Fix typo (wrote .tkinspect_opts instead of 149 | .tkinspect_init). 150 | 151 | * version.tcl: Whoops, forgot to bump to release date. 152 | 153 | * version.tcl: Bump to 5.1.5. 154 | 155 | * lists.tcl (run_command): preserve special characters in command 156 | invocation. 157 | 158 | * windows_info.tcl: Handle windows with special characters in 159 | them. 160 | 161 | * windows_list.tcl: Handle windows with special characters in 162 | them. 163 | 164 | Wed Jun 21 01:57:59 1995 Sam Shen 165 | 166 | * lists.tcl: Mark update_needed after a clear. 167 | 168 | * globals_list.tcl (update_scalar): silly bug fix. 169 | 170 | * README: Whoops, fix install instruction. 171 | 172 | * README: Update for 5.1.4. 173 | 174 | * version.tcl: Bump version to 5.1.4. 175 | 176 | * Value.html: Note new list types. 177 | 178 | * install.tcl: Add new help files. Search for both wish and 179 | wish4.0. 180 | 181 | * WhatsNew.html: Note additional interface functions. 182 | 183 | * tkinspect.tcl: Add new help files. 184 | 185 | * Notes.html: Small changes. 186 | 187 | * Intro.html: Add images, canvases, and menus list documentation. 188 | 189 | * Miscellany.html: Note that tkinspect_select can select menus, 190 | images, and canvases. 191 | 192 | * WhatsNew.html: Document 5.1.4 changes. 193 | 194 | * Miscellany.html: Document changes to interface.tcl. 195 | 196 | * Images.html: Say what selecting an image does. 197 | 198 | * Lists.html: Document recent changes, add image, menus, and 199 | canvases lists. 200 | 201 | * Menus.html: Change "item" to "entry". 202 | 203 | * install.tcl: Grab pointer and keyboard during install. Write 204 | messages about searching for wish4.0 in log window. Add 205 | canvas_list.tcl. 206 | 207 | * lists.tcl (create): Add "Remove This List" menu item. 208 | (update_needed): check to make sure window still exists before 209 | do_update. 210 | 211 | * interface.tcl: Add tkinspect_{show,remove}_list. Rename 212 | tkinspect_value_text_window to tkinspect_value_window. Add 213 | tkinspect_value_text_widget. Add tkinspect_display_image. 214 | 215 | * help.tcl: Add up/down bindings, page up/page down bindings. 216 | 217 | * tkinspect.tcl (toplevel): Add canvas_list. 218 | (add_list/remove_list): set list_class_is_on. 219 | 220 | * windows_info.tcl (get_class): check to make sure window still 221 | exists. 222 | 223 | * windows_info.tcl: Fix bug in windows_info:clear. 224 | 225 | * images_list.tcl: Rename "Show Image" to "Display Image". Add 226 | update_self method. 227 | 228 | * windows_list.tcl: Add update_self. 229 | 230 | * menus_list.tcl: Add update_self method. 231 | 232 | * lists.tcl: Reduce width to 15. Add "Update This List" menu item 233 | and required functionality. 234 | 235 | * version.tcl: Check patchlevel and warn about betas prior to 236 | 4.0b4. Bump version to 5.1.3. 237 | 238 | * install.tcl: Add menus_list.tcl and windows_info.tcl. 239 | 240 | * tkinspect.tcl: Use just plain "wish .." instead of "wish -f 241 | ...". Add menus_list. Add windows_info.tcl and appropriate 242 | hooks. 243 | 244 | * windows_list.tcl: Move maintenance of the list of windows to 245 | windows_info. 246 | 247 | * images_list.tcl: Add Show Image menu item and functionality. 248 | 249 | * Value.html, Lists.html: Document use of button 3. 250 | 251 | * value.tcl, lists.tcl: Bring menu up on button 3. 252 | 253 | Tue Jun 20 15:28:39 1995 Sam Shen 254 | 255 | * install.tcl: Search path for a wish4.0, otherwise use 256 | /usr/local/bin/wish4.0. 257 | 258 | Fri Jun 16 01:18:26 1995 Sam Shen 259 | 260 | * install.tcl: For some reason "update idletasks" isn't good 261 | enough to get the windows redrawn. Using "update". 262 | 263 | * version.tcl: Bump to 5.1.2. 264 | 265 | * install.tcl: Install sls.ppm instead of sls.xbm. 266 | 267 | * sls.ppm: initial revision. 268 | 269 | * about.tcl: Use a color photo. 270 | 271 | * help.tcl: Add netscape-like alt-left arrow/right arrow and 272 | space/backspace/delete bindings. 273 | 274 | * cmdline.tcl: Fix packing on text window so it resizes properly. 275 | 276 | * tkinspect.tcl: Add image_list, change tkinspect(list_classes) so 277 | that lists have readable names. 278 | 279 | * images_list.tcl: initial revision (contributed by Gero Kohnert). 280 | 281 | * install.tcl: Add images_list. 282 | 283 | Sun Jun 11 02:11:52 1995 Sam Shen 284 | 285 | * Windows.html: Fix typo in ref to Lists.html. 286 | 287 | Mon Jun 5 01:46:41 1995 Sam Shen 288 | 289 | * README: update for 5.1.1. 290 | 291 | * Intro.html: Remove ref to command line page. 292 | 293 | * version.tcl: Bump to 5.1.1. 294 | 295 | * Notes.html: Add note about copyright status. 296 | 297 | * install.tcl: Add new help files, new source files. 298 | 299 | * windows_list.tcl: Group "get window info..." & "use feedback.." 300 | options together. Reorder window options. 301 | 302 | * lists.tcl: Get rid of remove list menu item (now using 303 | checkboxes on file menu.) 304 | 305 | * Lists.html: Fix note about removing lists. Add note about 306 | updating lists. 307 | 308 | * Intro.html: Rewrite some of it, fold table of contents into 309 | here. 310 | 311 | * tkinspect.tcl: Add new help topics, get rid of old ones. Add 312 | label to command entry. 313 | 314 | * WhatsNew.html: Note the interface. 315 | 316 | Sun Jun 4 01:05:37 1995 Sam Shen 317 | 318 | * Windows.html: Document remaining window options. 319 | 320 | * windows_list.tcl: Use .feedback grab to handle grab. 321 | 322 | * help.tcl: Disable forward & back during rendering. 323 | 324 | * tkinspect.tcl: Change New xxx_list menu items to checkbuttons. 325 | Raise help window. Add hack to get lists frame to collapse when 326 | there are no more lists. 327 | 328 | * help.tcl: Implement forward, back, and go. 329 | 330 | * windows_list.tcl: Add optional feedback when getting windows. 331 | 332 | * stl.tcl: Add tkhtml.tcl. 333 | 334 | * lists.tcl: Add trigger method and binding for space so keyboard 335 | usage works. 336 | 337 | * tkinspect.tcl: Get rid of options menu. Move "New x Window" 338 | stuff to file menu. 339 | 340 | Thu Jun 1 21:24:21 1995 Sam Shen 341 | 342 | * version.tcl: Bump to 5.1.0. 343 | 344 | * install.tcl: Add cmdline.tcl, stl-lite/tkhtml.tcl, and the html 345 | help files. 346 | 347 | * install.tcl: Remove tk 4.0b2 focus work-arounds. 348 | 349 | * defaults.tcl: Add defs for command line. 350 | 351 | * cmdline.tcl: initial revision. 352 | 353 | * tkinspect.tcl: Add command line interface. Source 354 | .tkinspect_init in current directory (if it exists.) 355 | 356 | * tkinspect.tcl: Fix invocation of interpreter menu so things work 357 | with Tk 4.0b3. 358 | 359 | Wed Mar 22 22:55:51 1995 Sam Shen 360 | 361 | * stl.tcl: Add feedback.tcl. 362 | 363 | * lists.tcl: Clean up behavoir of filter_editor buttons. 364 | 365 | * install.tcl: Install help.tcl. 366 | 367 | * tkinspect.tcl: Add help. 368 | 369 | Wed Feb 15 16:09:10 1995 Sam Shen (sls@gainful.lbl.gov) 370 | 371 | * version.tcl: Add a Tk version check. Bump version to 5.0.5. 372 | 373 | * sls.xbm: initial revision. 374 | 375 | * install.tcl: Add version_init call, add title. Pack buttons 376 | with some padding. 377 | 378 | Tue Feb 14 18:55:40 1995 Sam Shen (sls@gainful.lbl.gov) 379 | 380 | * install.tcl: Add version.tcl. 381 | 382 | * version.tcl: initial revision, version number 5.0.4. 383 | 384 | * lists.tcl: Make return in filter_editor add a pattern. Add 385 | list_show dialog. Add underlines. 386 | 387 | * stl.tcl: Source files at global level. 388 | 389 | * value.tcl: Add underlines. 390 | 391 | * tkinspect.tcl: Move version info to version.tcl. Add 392 | underlines. 393 | 394 | * windows_list.tcl: Add underlines. 395 | 396 | * globals_list.tcl: Add underlines. Add a menu to variable trace 397 | dialog, add saving. 398 | 399 | * defaults.tcl: Set all menubutton borderwidth's to 0. 400 | 401 | Mon Feb 13 18:52:49 1995 Sam Shen 402 | 403 | * install.tcl: Change close button name to Exit. 404 | 405 | * windows_list.tcl: Change bindtags to bindtagsplus, add bindtags. 406 | 407 | * tkinspect.tcl: Fix send command button. 408 | 409 | Fri Feb 10 02:59:10 1995 Sam Shen 410 | 411 | * First public release: version 5.0.2 412 | 413 | * README, stl.tcl: initial revision. 414 | 415 | * tkinspect.tcl: Use stl-lite instead of the real thing. Update 416 | for install.tcl. 417 | 418 | * tkinspect.tcl: Use uniform add_foo/delete_foo names. Add 419 | delete_list. Pack lists with -fill both. Bump version to 5.0.2. 420 | 421 | * value.tcl: Add save & load. 422 | 423 | * lists.tcl: Remove now tells the main window that it's gone. 424 | Also, fix small typo in click. 425 | 426 | * defaults.tcl: Remove font defs. 427 | 428 | * windows_list.tcl: Get rid of "all" hacks, add bindtags 429 | retrieval. 430 | 431 | * value.tcl: Get rid of unimplemented search options. 432 | 433 | * lists.tcl: Add searching. 434 | 435 | * globals_list.tcl: Delete scrolled off lines correctly. Make 436 | sure we use the right name in array variable trace. 437 | 438 | Tue Feb 7 00:26:12 1995 Sam Shen 439 | 440 | * windows_list.tcl: Add classbindings "all" hack. 441 | 442 | * tkinspect.tcl: Change to 5.x.y version numbering (5.0.1 now.) 443 | Check to make sure a target has been selected when clicking. 444 | 445 | * value.tcl: Add searching (partially stolen from 446 | demos/mkTextWind.tcl). 447 | 448 | * value.tcl: Add menu entries. Allow detaching of value. 449 | 450 | * tkinspect.tcl: Allow lists and other widgets to add their own 451 | menus. Add tkinspect_failure. Check to see if there is a target. 452 | 453 | * lists.tcl: Move implementation of various lists to separate 454 | files. Implement filter editing. Add menus. Move menu defs that 455 | were in tkinspect.tcl to here. 456 | 457 | * defaults.tcl: Add more options. 458 | 459 | Mon Feb 6 02:45:44 1995 Sam Shen 460 | 461 | * lists.tcl: Flash windows for all retreive types. Format packing 462 | results nicely. Add filtering of pack -in. 463 | 464 | * value.tcl: Add history. 465 | 466 | * tkinspect.tcl: Change value when window option changes. Add 467 | filtering of pack -in options. Add buttons, command entry. 468 | 469 | -------------------------------------------------------------------------------- /tkinspect.tcl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #\ 3 | exec wish "$0" ${1+"$@"} 4 | # 5 | # $Id$ 6 | # 7 | 8 | package require Tk 9 | 10 | set tkinspect(title) "Tkinspect" 11 | set tkinspect(counter) -1 12 | set tkinspect(main_window_count) 0 13 | set tkinspect(list_classes) { 14 | "namespaces_list Namespaces" 15 | "procs_list Procs" 16 | "globals_list Globals" 17 | "class_list Classes" 18 | "object_list Objects" 19 | "windows_list Windows" 20 | "images_list Images" 21 | "menus_list Menus" 22 | "canvas_list Canvases" 23 | "afters_list Afters" 24 | } 25 | set tkinspect(list_class_files) { 26 | lists.tcl procs_list.tcl globals_list.tcl windows_list.tcl 27 | images_list.tcl about.tcl value.tcl help.tcl cmdline.tcl 28 | windows_info.tcl menus_list.tcl canvas_list.tcl classes_list.tcl 29 | objects_list.tcl names.tcl afters_list.tcl namespaces_list.tcl 30 | } 31 | set tkinspect(help_topics) { 32 | Intro Value Lists Procs Globals Windows Images Canvases Menus 33 | Classes Value Miscellany Notes WhatsNew ChangeLog 34 | } 35 | 36 | if {[info commands itcl_info] != ""} { 37 | set tkinspect(default_lists) "object_list procs_list globals_list windows_list" 38 | } else { 39 | set tkinspect(default_lists) "namespaces_list procs_list globals_list windows_list" 40 | } 41 | 42 | wm withdraw . 43 | 44 | # Find the tkinspect library - support scripted documents (Steve Landers) 45 | # also supports starkits (Pat Thoyts). 46 | if {[info exists ::starkit::topdir]} { 47 | set tkinspect_library [file join $::starkit::topdir lib tkinspect] 48 | lappend auto_path $tkinspect_library 49 | } elseif {[info exists ::scripdoc::self]} { 50 | lappend auto_path [file join $::scripdoc::self lib] 51 | set tkinspect_library [file join $::scripdoc::self lib tkinspect] 52 | lappend auto_path $tkinspect_library 53 | } elseif [file exists @tkinspect_library@/tclIndex] { 54 | lappend auto_path [set tkinspect_library @tkinspect_library@] 55 | } else { 56 | lappend auto_path [set tkinspect_library [file dirname [info script]]] 57 | } 58 | 59 | # If we have Tk send - use it (on windows this has no effect) 60 | if {[info command tk] != {}} { 61 | ::tk appname $tkinspect(title) 62 | } 63 | 64 | # Use the winsend package if available. 65 | if {[info command send] == {}} { 66 | if {![catch {package require winsend}]} { 67 | set tkinspect(title) [winsend appname] 68 | 69 | proc send {app args} { 70 | eval winsend send [list $app] $args 71 | } 72 | } 73 | } 74 | 75 | # Emulate the 'send' command using the dde package if available. 76 | if {[info command send] == {} || [package provide winsend] != {}} { 77 | if {![catch {package require dde}]} { 78 | array set dde [list count 0 topic $tkinspect(title)] 79 | while {[dde services TclEval $dde(topic)] != {}} { 80 | incr dde(count) 81 | set dde(topic) "$tkinspect(title) #$dde(count)" 82 | } 83 | dde servername $dde(topic) 84 | set tkinspect(title) $dde(topic) 85 | unset dde 86 | if {[package provide winsend] != {}} { 87 | proc send {app args} { 88 | if {[string match {!*} $app]} { 89 | eval dde eval [list [string range $app 1 end]] $args 90 | } else { 91 | eval winsend send [list $app] $args 92 | } 93 | } 94 | } else { 95 | proc send {app args} { 96 | eval dde eval [list $app] $args 97 | } 98 | } 99 | } 100 | } 101 | 102 | # Provide non-send based support using tklib's comm package. 103 | if {![catch {package require comm}]} { 104 | # defer the cleanup for 2 seconds to allow other events to process 105 | comm::comm hook lost {after 2000 set x 1; vwait x} 106 | 107 | # 108 | # replace send with version that does both send and comm 109 | # 110 | if [string match send [info command send]] { 111 | rename send tk_send 112 | } else { 113 | proc tk_send args {} 114 | } 115 | proc send {app args} { 116 | if [string match {[0-9]*} $app] { 117 | eval comm::comm send [list $app] $args 118 | } else { 119 | eval tk_send [list $app] $args 120 | } 121 | } 122 | } 123 | 124 | stl_lite_init 125 | version_init 126 | 127 | proc tkinspect_exit {} { 128 | destroy . 129 | exit 0 130 | } 131 | 132 | proc tkinspect_widgets_init {} { 133 | global tkinspect_library 134 | global tkinspect 135 | 136 | foreach file $tkinspect(list_class_files) { 137 | uplevel #0 source $tkinspect_library/$file 138 | } 139 | } 140 | 141 | proc tkinspect_about {parent} { 142 | catch {destroy .about} 143 | about .about 144 | wm transient .about $parent 145 | .about run 146 | } 147 | 148 | dialog tkinspect_main { 149 | param target "" 150 | member last_list {} 151 | member lists "" 152 | member cmdline_counter -1 153 | member cmdlines "" 154 | member windows_info 155 | method create {} { 156 | global tkinspect 157 | pack [frame $self.menu -bd 2 -relief flat] -side top -fill x 158 | menubutton $self.menu.file -menu $self.menu.file.m -text "File" \ 159 | -underline 0 160 | pack $self.menu.file -side left 161 | set m [menu $self.menu.file.m] 162 | $m add cascade -label "Select Interpreter (send)" -underline 0 \ 163 | -menu $self.menu.file.m.interps 164 | if {[package provide comm] != {}} { 165 | $m add cascade -label "Select Interpreter (comm)" -underline 21 \ 166 | -menu $self.menu.file.m.comminterps 167 | $m add command -label "Connect to (comm)" -underline 0 \ 168 | -command "$self connect_dialog" 169 | } 170 | $m add command -label "Update Lists" -underline 0 \ 171 | -command "$self update_lists" 172 | $m add separator 173 | $m add command -label "New Tkinspect Window" -underline 0 \ 174 | -command tkinspect_create_main_window 175 | $m add command -label "New Command Line" -underline 12 \ 176 | -command "$self add_cmdline" 177 | foreach list_class $tkinspect(list_classes) { 178 | $m add checkbutton -label "[lindex $list_class 1] List" \ 179 | -variable [object_slotname [lindex $list_class 0]_is_on] \ 180 | -command "$self toggle_list [lindex $list_class 0]" 181 | } 182 | $m add separator 183 | $m add command -label "Close Window" -underline 0 \ 184 | -command "$self close" 185 | $m add command -label "Exit Tkinspect" -underline 1 \ 186 | -command tkinspect_exit 187 | menu $self.menu.file.m.interps -tearoff 0 \ 188 | -postcommand "$self fill_interp_menu" 189 | if {[package provide comm] != {}} { 190 | menu $self.menu.file.m.comminterps -tearoff 0 \ 191 | -postcommand "$self fill_comminterp_menu" 192 | } 193 | menubutton $self.menu.help -menu $self.menu.help.m -text "Help" \ 194 | -underline 0 195 | pack $self.menu.help -side right 196 | set m [menu $self.menu.help.m] 197 | $m add command -label "About..." -command [list tkinspect_about $self]\ 198 | -underline 0 199 | foreach topic $tkinspect(help_topics) { 200 | $m add command -label $topic -command [list $self help $topic] \ 201 | -underline 0 202 | } 203 | 204 | foreach w [winfo children $self.menu] { 205 | $w configure -relief flat -bd 1 206 | bind $w {%W configure -relief raised -bd 1} 207 | bind $w {%W configure -relief flat -bd 1} 208 | } 209 | 210 | pack [set f [ttk::frame $self.buttons]] -side top -fill x 211 | ttk::label $f.cmd_label -text "Command:" 212 | pack $f.cmd_label -side left 213 | ttk::entry $f.command 214 | bind $f.command "$self send_command \[%W get\]" 215 | pack $f.command -side left -fill x -expand 1 216 | ttk::button $f.send_command -text "Send Command" \ 217 | -command "$self send_command \[$f.command get\]" 218 | ttk::button $f.send_value -text "Send Value" \ 219 | -command "$self.value send_value" 220 | pack $f.send_command $f.send_value -side left 221 | 222 | # change to use a panedwindow instead of a frame - Alex Caldwell 223 | if {[package vcompare [package provide Tk] 8.3] == 1} { 224 | pack [ttk::panedwindow $self.lists -orient horizontal] -side top -fill both 225 | } else { 226 | pack [ttk::frame $self.lists] -side top -fill both 227 | } 228 | 229 | value $self.value -main $self 230 | pack $self.value -side top -fill both -expand 1 231 | foreach list_class $tkinspect(default_lists) { 232 | $self add_list $list_class 233 | set slot(${list_class}_is_on) 1 234 | } 235 | pack [ttk::frame $self.status] -side top -fill x 236 | ttk::label $self.status.l -anchor w 237 | pack $self.status.l -side left -fill x -expand 1 238 | set slot(windows_info) [object_new windows_info] 239 | wm iconname $self $tkinspect(title) 240 | wm title $self "$tkinspect(title): $slot(target)" 241 | $self status "Ready." 242 | } 243 | method reconfig {} { 244 | } 245 | method destroy {} { 246 | global tkinspect 247 | object_delete $slot(windows_info) 248 | if {[incr tkinspect(main_window_count) -1] == 0} tkinspect_exit 249 | } 250 | method close {} { 251 | after 0 destroy $self 252 | } 253 | method set_target {target {type send}} { 254 | global tkinspect 255 | set slot(target) $target 256 | set slot(target,type) $type 257 | if {$type == "comm"} { 258 | set slot(target,self) [comm::comm self] 259 | } else { 260 | set slot(target,self) $tkinspect(title) 261 | } 262 | $self update_lists 263 | foreach cmdline $slot(cmdlines) { 264 | $cmdline set_target $target 265 | } 266 | set name [file tail [send $target ::set argv0]] 267 | $self status "Remote interpreter is \"$target\" ($name)" 268 | wm title $self "$tkinspect(title): $target ($name)" 269 | } 270 | method update_lists {} { 271 | if {$slot(target) == ""} return 272 | $slot(windows_info) update $slot(target) 273 | foreach list $slot(lists) { 274 | $list update $slot(target) 275 | } 276 | } 277 | method select_list_item {list item} { 278 | set slot(last_list) $list 279 | set target [$self target] 280 | $self.value set_value "[$list get_item_name] $item" \ 281 | [$list retrieve $target $item] \ 282 | [list $self select_list_item $list $item] 283 | $self.value set_send_filter [list $list send_filter] 284 | $self status "Showing \"$item\"" 285 | } 286 | method connect_dialog {} { 287 | if ![winfo exists $self.connect] { 288 | connect_interp $self.connect -value $self 289 | under_mouse $self.connect 290 | } else { 291 | wm deiconify $self.connect 292 | under_mouse $self.connect 293 | } 294 | } 295 | method fill_interp_menu {} { 296 | set m $self.menu.file.m.interps 297 | catch {$m delete 0 last} 298 | set winsend 0 299 | if {[package provide winsend] != {}} { 300 | set winsend 1 301 | foreach interp [winsend interps] { 302 | $m add command -label $interp \ 303 | -command [list $self set_target $interp winsend] 304 | } 305 | } 306 | if {[package provide dde] != {}} { 307 | foreach service [dde services TclEval {}] { 308 | if {$winsend} { 309 | set label "[lindex $service 1] (dde)" 310 | set app "![lindex $service 1]" 311 | } else { 312 | set label [lindex $service 1] 313 | set app $label 314 | } 315 | $m add command -label $label \ 316 | -command [list $self set_target $app dde] 317 | } 318 | } else { 319 | foreach interp [winfo interps] { 320 | $m add command -label $interp \ 321 | -command [list $self set_target $interp] 322 | } 323 | } 324 | } 325 | method fill_comminterp_menu {} { 326 | set m $self.menu.file.m.comminterps 327 | catch {$m delete 0 last} 328 | foreach interp [comm::comm interps] { 329 | if [string match [comm::comm self] $interp] { 330 | set label "$interp (self)" 331 | } else { 332 | set label "$interp ([file tail [send $interp ::set argv0]])" 333 | } 334 | $m add command -label $label \ 335 | -command [list $self set_target $interp comm] 336 | } 337 | } 338 | method status {msg} { 339 | $self.status.l config -text $msg 340 | } 341 | method target {} { 342 | if ![string length $slot(target)] { 343 | tkinspect_failure \ 344 | "No interpreter has been selected yet. Please select one first." 345 | } 346 | return $slot(target) 347 | } 348 | method last_list {} { return $slot(last_list) } 349 | method send_command {cmd} { 350 | set slot(last_list) "" 351 | set cmd [$self.buttons.command get] 352 | $self.value set_value [list command $cmd] [send $slot(target) $cmd] \ 353 | [list $self send_command $cmd] 354 | $self.value set_send_filter "" 355 | $self status "Command sent." 356 | } 357 | method toggle_list {list_class} { 358 | set list $self.lists.$list_class 359 | if !$slot(${list_class}_is_on) { 360 | $list remove 361 | } else { 362 | $self add_list $list_class 363 | if [string length $slot(target)] { 364 | $list update $slot(target) 365 | } 366 | } 367 | } 368 | method add_list {list_class} { 369 | set list $self.lists.$list_class 370 | if [winfo exists $list] return 371 | set slot(${list_class}_is_on) 1 372 | lappend slot(lists) $list 373 | $list_class $list -command "$self select_list_item $list" \ 374 | -main $self 375 | # change to use panedwindow widget instead of frame 376 | if {[package vcompare [package provide Tk] 8.3] == 1} { 377 | $self.lists add $list ;#-width 150 378 | } else { 379 | pack $list -side left -fill both -expand 1 380 | } 381 | } 382 | method delete_list {list} { 383 | global tk_patchLevel 384 | set ndx [lsearch -exact $slot(lists) $list] 385 | set slot(lists) [lreplace $slot(lists) $ndx $ndx] 386 | # changed to use a panedwindow widget instead of a frame 387 | if {[package vcompare [package provide Tk] 8.3] == 1} { 388 | $self.lists forget $list 389 | } else { 390 | pack forget $list 391 | 392 | # for some reason if all the lists get unpacked the 393 | # .lists frame doesn't collapse unless we force it 394 | $self.lists configure ;# -height 1 395 | } 396 | set list_class [lindex [split $list .] 3] 397 | set slot(${list_class}_is_on) 0 398 | } 399 | method add_cmdline {} { 400 | set cmdline \ 401 | [command_line $self.cmdline[incr slot(cmdline_counter)] -main $self] 402 | $cmdline set_target $slot(target) 403 | lappend slot(cmdlines) $cmdline 404 | } 405 | method delete_cmdline {cmdline} { 406 | set ndx [lsearch -exact $slot(cmdlines) $cmdline] 407 | set slot(cmdlines) [lreplace $slot(cmdlines) $ndx $ndx] 408 | } 409 | method add_menu {name} { 410 | set w $self.menu.[string tolower $name] 411 | menubutton $w -menu $w.m -text $name -underline 0 -bd 1 -relief flat 412 | bind $w {%W configure -relief raised -bd 1} 413 | bind $w {%W configure -relief flat -bd 1} 414 | pack $w -side left 415 | menu $w.m 416 | return $w.m 417 | } 418 | method delete_menu {name} { 419 | set w $self.menu.[string tolower $name] 420 | pack forget $w 421 | destroy $w 422 | } 423 | method help {topic} { 424 | global tkinspect tkinspect_library 425 | if [winfo exists $self.help] { 426 | wm deiconify $self.help 427 | raise $self.help 428 | } else { 429 | help_window $self.help -topics $tkinspect(help_topics) \ 430 | -helpdir $tkinspect_library 431 | center_window $self.help 432 | } 433 | $self.help show_topic $topic 434 | } 435 | method windows_info {args} { 436 | eval $slot(windows_info) $args 437 | } 438 | } 439 | 440 | proc tkinspect_create_main_window {args} { 441 | global tkinspect 442 | set w [eval tkinspect_main .main[incr tkinspect(counter)] $args] 443 | incr tkinspect(main_window_count) 444 | return $w 445 | } 446 | 447 | # 971005: phealy 448 | # 449 | # With tk8.0 the default tkerror proc is finally gone - bgerror 450 | # takes its place (see the changes tk8.0 changes file). This 451 | # simplified error handling should be ok. 452 | # 453 | proc tkinspect_failure {reason} { 454 | tk_dialog .failure "Tkinspect Failure" $reason warning 0 Ok 455 | } 456 | 457 | tkinspect_widgets_init 458 | tkinspect_default_options 459 | if [file exists ~/.tkinspect_opts] { 460 | source ~/.tkinspect_opts 461 | } 462 | tkinspect_create_main_window 463 | if [file exists .tkinspect_init] { 464 | source .tkinspect_init 465 | } 466 | 467 | dialog connect_interp { 468 | param value 469 | method create {} { 470 | ttk::frame $self.top 471 | pack $self.top -side top -fill x 472 | ttk::label $self.l -text "Connect to:" 473 | ttk::entry $self.e 474 | bind $self.e "$self connect" 475 | bind $self.e "destroy $self" 476 | pack $self.l -in $self.top -side left 477 | pack $self.e -in $self.top -fill x -expand 1 478 | ttk::button $self.close -text "OK" -width 8 -command "$self connect" 479 | ttk::button $self.cancel -text "Cancel" -width 8 -command "destroy $self" 480 | pack $self.close $self.cancel -side left 481 | wm title $self "Connect to Interp.." 482 | wm iconname $self "Connect to Interp.." 483 | focus $self.e 484 | } 485 | method reconfig {} { 486 | } 487 | method connect {} { 488 | set text [$self.e get] 489 | if ![string match {[0-9]*} $text] return 490 | comm::comm connect $text 491 | wm withdraw $self 492 | $slot(value) set_target $text comm 493 | } 494 | } 495 | 496 | -------------------------------------------------------------------------------- /stl-lite/tkhtml.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # $Id$ 3 | # 4 | # This software is copyright (C) 1995 by the Lawrence Berkeley Laboratory. 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that: (1) source code distributions 8 | # retain the above copyright notice and this paragraph in its entirety, (2) 9 | # distributions including binary code include the above copyright notice and 10 | # this paragraph in its entirety in the documentation or other materials 11 | # provided with the distribution, and (3) all advertising materials mentioning 12 | # features or use of this software display the following acknowledgement: 13 | # ``This product includes software developed by the University of California, 14 | # Lawrence Berkeley Laboratory and its contributors.'' Neither the name of 15 | # the University nor the names of its contributors may be used to endorse 16 | # or promote products derived from this software without specific prior 17 | # written permission. 18 | # 19 | # THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED 20 | # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 21 | # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 22 | # 23 | # This code is based on Angel Li's (angel@flipper.rsmas.miami.edu) HTML 24 | # rendering code. 25 | # 26 | 27 | proc tkhtml_set_render_hook {hook} { 28 | global tkhtml_priv 29 | set tkhtml_priv(render_hook) $hook 30 | } 31 | 32 | proc tkhtml_set_image_hook {hook} { 33 | global tkhtml_priv 34 | set tkhtml_priv(image_hook) $hook 35 | } 36 | 37 | proc tkhtml_render {w html} { 38 | global tkhtml_priv tkhtml_entity 39 | $w config -state normal 40 | $w delete 1.0 end 41 | tkhtml_setup $w 42 | set tkhtml_priv(continue_rendering) 1 43 | tkhtml_set_tag 44 | while {$tkhtml_priv(continue_rendering)} { 45 | # normal state 46 | while {[set len [string length $html]]} { 47 | # look for text up to the next <> element 48 | if [regexp -indices "^\[^<\]+" $html match] { 49 | set text [string range $html 0 [lindex $match 1]] 50 | tkhtml_append_text $text 51 | set html \ 52 | [string range $html [expr [lindex $match 1]+1] end] 53 | } 54 | # we're either at a <>, or at the eot 55 | if [regexp -indices "^<(\[^>\]+)>" $html match entity] { 56 | set entity [string range $html [lindex $entity 0] \ 57 | [lindex $entity 1]] 58 | set cmd [string tolower [lindex $entity 0]] 59 | if {[info exists tkhtml_entity($cmd)]} { 60 | tkhtml_do $cmd [lrange $entity 1 end] 61 | } 62 | set html \ 63 | [string range $html [expr [lindex $match 1]+1] end] 64 | } 65 | if [info exists tkhtml_priv(render_hook)] { 66 | eval $tkhtml_priv(render_hook) $len 67 | } 68 | if $tkhtml_priv(verbatim) break 69 | } 70 | # we reach here if html is empty, or verbatim is 1 71 | if !$len break 72 | # verbatim must be 1 73 | # append text until a is reached 74 | if {[regexp -indices -nocase $tkhtml_priv(verb_end_token) $html match]} { 75 | set text [string range $html 0 [expr [lindex $match 0]-1]] 76 | set html [string range $html [expr [lindex $match 1]+1] end] 77 | } else { 78 | set text $html 79 | set html "" 80 | } 81 | tkhtml_append_text $text 82 | if [info exists tkhtml_entity([string trim $tkhtml_priv(verb_end_token) <>])] { 83 | tkhtml_do [string trim $tkhtml_priv(verb_end_token) <>] 84 | } 85 | } 86 | $w config -state disabled 87 | } 88 | 89 | proc tkhtml_defaults {} { 90 | global tkhtml_priv 91 | set tkhtml_priv(defaults_set) 1 92 | set tkhtml_priv(default_font) times 93 | set tkhtml_priv(fixed_font) courier 94 | set tkhtml_priv(font_size) medium 95 | set tkhtml_priv(small_points) "60 80 100 120 140 180 240" 96 | set tkhtml_priv(medium_points) "80 100 120 140 180 240 360" 97 | set tkhtml_priv(large_points) "100 120 140 180 240 360 480" 98 | set tkhtml_priv(huge_points) "120 140 180 240 360 480 640" 99 | set tkhtml_priv(ruler_height) 6 100 | set tkhtml_priv(indent_incr) 4 101 | set tkhtml_priv(w) {} 102 | set tkhtml_priv(counter) -1 103 | } 104 | 105 | proc tkhtml_set_font {font size} { 106 | global tkhtml_priv 107 | set tkhtml_priv(default_font) $font 108 | set tkhtml_priv(font) $font 109 | set tkhtml_priv(font_size) $size 110 | } 111 | 112 | proc tkhtml_setup {w} { 113 | global tkhtml_priv 114 | if ![info exists tkhtml_priv(defaults_set)] tkhtml_defaults 115 | set tkhtml_priv(font) $tkhtml_priv(default_font) 116 | set tkhtml_priv(left) 0 117 | set tkhtml_priv(left2) 0 118 | set tkhtml_priv(right) 0 119 | set tkhtml_priv(justify) L 120 | set tkhtml_priv(weight) 0 121 | set tkhtml_priv(slant) 0 122 | set tkhtml_priv(underline) 0 123 | set tkhtml_priv(verbatim) 0 124 | set tkhtml_priv(pre) 0 125 | set tkhtml_priv(title) {} 126 | set tkhtml_priv(in_title) 0 127 | set tkhtml_priv(color) black 128 | set tkhtml_priv(li_style) bullet 129 | set tkhtml_priv(anchor_count) 0 130 | set tkhtml_priv(verb_end_token) {} 131 | set tkhtml_priv(stack.font) {} 132 | set tkhtml_priv(stack.color) {} 133 | set tkhtml_priv(stack.justify) {} 134 | set tkhtml_priv(stack.li_style) {} 135 | set tkhtml_priv(stack.href) {} 136 | set tkhtml_priv(points_ndx) 2 137 | if {$tkhtml_priv(w) != $w} { 138 | set tkhtml_priv(w) $w 139 | $tkhtml_priv(w) tag config hr -relief sunken -borderwidth 2 \ 140 | -font -*-*-*-*-*-*-$tkhtml_priv(ruler_height)-*-*-*-*-*-*-* 141 | foreach elt [array names tkhtml_priv] { 142 | if [regexp "^tag\\..*" $elt] { 143 | unset tkhtml_priv($elt) 144 | } 145 | } 146 | } 147 | } 148 | 149 | proc tkhtml_define_font {name foundry family weight slant registry} { 150 | global tkhtml_priv 151 | lappend tkhtml_priv(font_names) $name 152 | set tkhtml_priv(font_info.$name) \ 153 | [list $foundry $family $weight $slant $registry] 154 | } 155 | 156 | proc tkhtml_define_entity {name body} { 157 | global tkhtml_entity 158 | set tkhtml_entity($name) $body 159 | } 160 | 161 | proc tkhtml_do {cmd {argv {}}} { 162 | global tkhtml_priv tkhtml_entity 163 | eval $tkhtml_entity($cmd) 164 | } 165 | 166 | proc tkhtml_append_text {text} { 167 | global tkhtml_priv 168 | if !$tkhtml_priv(verbatim) { 169 | if !$tkhtml_priv(pre) { 170 | regsub -all "\[ \n\r\t\]+" [string trim $text] " " text 171 | } 172 | regsub -nocase -all "&" $text {\&} text 173 | regsub -nocase -all "<" $text "<" text 174 | regsub -nocase -all ">" $text ">" text 175 | if ![string length $text] return 176 | } 177 | if {!$tkhtml_priv(pre) && !$tkhtml_priv(in_title)} { 178 | set p [$tkhtml_priv(w) get "end - 2c"] 179 | set n [string index $text 0] 180 | if {![regexp "\[ \n(\]" $p] && ![regexp "\[\\.,')\]" $n]} { 181 | $tkhtml_priv(w) insert end " " 182 | } 183 | $tkhtml_priv(w) insert end $text $tkhtml_priv(tag) 184 | return 185 | } 186 | if {$tkhtml_priv(pre) && !$tkhtml_priv(in_title)} { 187 | $tkhtml_priv(w) insert end $text $tkhtml_priv(tag) 188 | return 189 | } 190 | append tkhtml_priv(title) $text 191 | } 192 | 193 | proc tkhtml_title {} { 194 | global tkhtml_priv 195 | return $tkhtml_priv(title) 196 | } 197 | 198 | # a tag is constructed as: font?B?I?U?Points-LeftLeft2RightColorJustify 199 | proc tkhtml_set_tag {} { 200 | global tkhtml_priv 201 | set i -1 202 | foreach var {foundry family weight slant registry} { 203 | set $var [lindex $tkhtml_priv(font_info.$tkhtml_priv(font)) [incr i]] 204 | } 205 | set x_font "-$foundry-$family-" 206 | set tag $tkhtml_priv(font) 207 | set args {} 208 | if {$tkhtml_priv(weight) > 0} { 209 | append tag "B" 210 | append x_font [lindex $weight 1]- 211 | } else { 212 | append x_font [lindex $weight 0]- 213 | } 214 | if {$tkhtml_priv(slant) > 0} { 215 | append tag "I" 216 | append x_font [lindex $slant 1]- 217 | } else { 218 | append x_font [lindex $slant 0]- 219 | } 220 | if {$tkhtml_priv(underline) > 0} { 221 | append tag "U" 222 | append args " -underline 1" 223 | } 224 | switch $tkhtml_priv(justify) { 225 | L { append args " -justify left" } 226 | R { append args " -justify right" } 227 | C { append args " -justify center" } 228 | } 229 | set pts [lindex $tkhtml_priv($tkhtml_priv(font_size)_points) \ 230 | $tkhtml_priv(points_ndx)] 231 | append tag $tkhtml_priv(points_ndx) - $tkhtml_priv(left) \ 232 | $tkhtml_priv(left2) $tkhtml_priv(right) \ 233 | $tkhtml_priv(color) $tkhtml_priv(justify) 234 | append x_font "normal-*-*-$pts-*-*-*-*-$registry-*" 235 | if $tkhtml_priv(anchor_count) { 236 | set href [tkhtml_peek href] 237 | set href_tag href[incr tkhtml_priv(counter)] 238 | set tags [list $tag $href_tag] 239 | if [info exists tkhtml_priv(command)] { 240 | $tkhtml_priv(w) tag bind $href_tag <1> \ 241 | [list tkhtml_href_click $tkhtml_priv(command) $href] 242 | } 243 | $tkhtml_priv(w) tag bind $href_tag \ 244 | [list $tkhtml_priv(w) tag configure $href_tag \ 245 | -foreground red] 246 | $tkhtml_priv(w) tag bind $href_tag \ 247 | [list $tkhtml_priv(w) tag configure $href_tag \ 248 | -foreground $tkhtml_priv(color)] 249 | } else { 250 | set tags $tag 251 | } 252 | if {![info exists tkhtml_priv(tag.$tag)]} { 253 | set tkhtml_priv(tag_font.$tag) 1 254 | eval $tkhtml_priv(w) tag configure $tag \ 255 | -font $x_font -foreground $tkhtml_priv(color) \ 256 | -lmargin1 $tkhtml_priv(left)m \ 257 | -lmargin2 $tkhtml_priv(left2)m $args 258 | } 259 | if [info exists href_tag] { 260 | $tkhtml_priv(w) tag raise $href_tag $tag 261 | } 262 | set tkhtml_priv(tag) $tags 263 | } 264 | 265 | proc tkhtml_reconfig_tags {w} { 266 | global tkhtml_priv 267 | foreach tag [$w tag names] { 268 | foreach font $tkhtml_priv(font_names) { 269 | if [regexp "${font}(B?)(I?)(U?)(\[1-9\]\[0-9\]*)-" $tag t b i u points] { 270 | set j -1 271 | if {$font != $tkhtml_priv(fixed_font)} { 272 | set font $tkhtml_priv(font) 273 | } 274 | foreach var {foundry family weight slant registry} { 275 | set $var [lindex $tkhtml_priv(font_info.$font) [incr j]] 276 | } 277 | set x_font "-$foundry-$family-" 278 | if {$b == "B"} { 279 | append x_font [lindex $weight 1]- 280 | } else { 281 | append x_font [lindex $weight 0]- 282 | } 283 | if {$i == "I"} { 284 | append x_font [lindex $slant 1]- 285 | } else { 286 | append x_font [lindex $slant 0]- 287 | } 288 | set pts [lindex $tkhtml_priv($tkhtml_priv(font_size)_points) \ 289 | $points] 290 | append x_font "normal-*-*-$pts-*-*-*-*-$registry-*" 291 | $w tag config $tag -font $x_font 292 | break 293 | } 294 | } 295 | } 296 | } 297 | 298 | proc tkhtml_push {stack value} { 299 | global tkhtml_priv 300 | lappend tkhtml_priv(stack.$stack) $value 301 | } 302 | 303 | proc tkhtml_pop {stack} { 304 | global tkhtml_priv 305 | set n [expr [llength $tkhtml_priv(stack.$stack)]-1] 306 | if {$n < 0} { 307 | puts "popping empty stack $stack" 308 | return "" 309 | } 310 | set val [lindex $tkhtml_priv(stack.$stack) $n] 311 | set tkhtml_priv(stack.$stack) [lreplace $tkhtml_priv(stack.$stack) $n $n] 312 | return $val 313 | } 314 | 315 | proc tkhtml_peek {stack} { 316 | global tkhtml_priv 317 | return [lindex $tkhtml_priv(stack.$stack) end] 318 | } 319 | 320 | proc tkhtml_parse_fields {array_var string} { 321 | upvar $array_var array 322 | foreach arg $string { 323 | if ![regexp "(\[^ \n\r=\]+)=\"?(\[^\"\n\r\t \]*)" $arg dummy field value] { 324 | puts "malformed command field" 325 | puts "field = \"$arg\"" 326 | continue 327 | } 328 | set array([string tolower $field]) $value 329 | } 330 | } 331 | 332 | proc tkhtml_set_command {cmd} { 333 | global tkhtml_priv 334 | set tkhtml_priv(command) $cmd 335 | } 336 | 337 | proc tkhtml_href_click {cmd href} { 338 | uplevel #0 $cmd $href 339 | } 340 | 341 | # define the fonts we're going to use 342 | set tkhtml_priv(font_names) "" 343 | tkhtml_define_font helvetica adobe helvetica "medium bold" "r o" iso8859 344 | tkhtml_define_font courier adobe courier "medium bold" "r o" iso8859 345 | tkhtml_define_font times adobe times "medium bold" "r i" iso8859 346 | tkhtml_define_font symbol adobe symbol "medium medium" "r r" adobe 347 | 348 | # define the entities we're going to handle 349 | tkhtml_define_entity b { incr tkhtml_priv(weight); tkhtml_set_tag } 350 | tkhtml_define_entity /b { incr tkhtml_priv(weight) -1; tkhtml_set_tag } 351 | tkhtml_define_entity strong { incr tkhtml_priv(weight); tkhtml_set_tag } 352 | tkhtml_define_entity /strong { incr tkhtml_priv(weight) -1; tkhtml_set_tag } 353 | tkhtml_define_entity tt { 354 | tkhtml_push font $tkhtml_priv(font) 355 | set tkhtml_priv(font) $tkhtml_priv(fixed_font) 356 | tkhtml_set_tag 357 | } 358 | tkhtml_define_entity /tt { 359 | set tkhtml_priv(font) [tkhtml_pop font] 360 | tkhtml_set_tag 361 | } 362 | tkhtml_define_entity code { tkhtml_do tt } 363 | tkhtml_define_entity /code { tkhtml_do /tt } 364 | tkhtml_define_entity kbd { tkhtml_do tt } 365 | tkhtml_define_entity /kbd { tkhtml_do /tt } 366 | tkhtml_define_entity em { incr tkhtml_priv(slant); tkhtml_set_tag } 367 | tkhtml_define_entity /em { incr tkhtml_priv(slant) -1; tkhtml_set_tag } 368 | tkhtml_define_entity var { incr tkhtml_priv(slant); tkhtml_set_tag } 369 | tkhtml_define_entity /var { incr tkhtml_priv(slant) -1; tkhtml_set_tag } 370 | tkhtml_define_entity cite { incr tkhtml_priv(slant); tkhtml_set_tag } 371 | tkhtml_define_entity /cite { incr tkhtml_priv(slant) -1; tkhtml_set_tag } 372 | tkhtml_define_entity address { 373 | tkhtml_do br 374 | incr tkhtml_priv(slant) 375 | tkhtml_set_tag 376 | } 377 | tkhtml_define_entity /address { 378 | incr tkhtml_priv(slant) -1 379 | tkhtml_do br 380 | tkhtml_set_tag 381 | } 382 | tkhtml_define_entity /cite { incr tkhtml_priv(slant) -1; tkhtml_set_tag } 383 | 384 | tkhtml_define_entity p { 385 | set x [$tkhtml_priv(w) get end-3c] 386 | set y [$tkhtml_priv(w) get end-2c] 387 | if {$x == "" && $y == ""} return 388 | if {$y == ""} { 389 | $tkhtml_priv(w) insert end "\n\n" 390 | return 391 | } 392 | if {$x == "\n" && $y == "\n"} return 393 | if {$y == "\n"} { 394 | $tkhtml_priv(w) insert end "\n" 395 | return 396 | } 397 | $tkhtml_priv(w) insert end "\n\n" 398 | } 399 | tkhtml_define_entity br { 400 | if {[$tkhtml_priv(w) get "end-2c"] != "\n"} { 401 | $tkhtml_priv(w) insert end "\n" 402 | } 403 | } 404 | tkhtml_define_entity title { set tkhtml_priv(in_title) 1 } 405 | tkhtml_define_entity /title { set tkhtml_priv(in_title) 0 } 406 | 407 | tkhtml_define_entity h1 { tkhtml_header 1 } 408 | tkhtml_define_entity /h1 { tkhtml_/header 1 } 409 | tkhtml_define_entity h2 { tkhtml_header 2 } 410 | tkhtml_define_entity /h2 { tkhtml_/header 2 } 411 | tkhtml_define_entity h3 { tkhtml_header 3 } 412 | tkhtml_define_entity /h3 { tkhtml_/header 3 } 413 | tkhtml_define_entity h4 { tkhtml_header 4 } 414 | tkhtml_define_entity /h4 { tkhtml_/header 4 } 415 | tkhtml_define_entity h5 { tkhtml_header 5 } 416 | tkhtml_define_entity /h5 { tkhtml_/header 5 } 417 | tkhtml_define_entity h6 { tkhtml_header 6 } 418 | tkhtml_define_entity /h6 { tkhtml_/header 6 } 419 | 420 | proc tkhtml_header {level} { 421 | global tkhtml_priv 422 | tkhtml_do p 423 | set tkhtml_priv(points_ndx) [expr 6-$level] 424 | incr tkhtml_priv(weight) 425 | tkhtml_set_tag 426 | } 427 | 428 | proc tkhtml_/header {level} { 429 | global tkhtml_priv 430 | set tkhtml_priv(points_ndx) 2 431 | incr tkhtml_priv(weight) -1 432 | tkhtml_set_tag 433 | tkhtml_do p 434 | } 435 | 436 | tkhtml_define_entity pre { 437 | tkhtml_do tt 438 | tkhtml_do br 439 | incr tkhtml_priv(pre) 440 | } 441 | tkhtml_define_entity /pre { 442 | tkhtml_do /tt 443 | set tkhtml_priv(pre) 0 444 | tkhtml_do p 445 | } 446 | 447 | tkhtml_define_entity hr { 448 | tkhtml_do p 449 | $tkhtml_priv(w) insert end "\n" hr 450 | } 451 | tkhtml_define_entity a { 452 | tkhtml_parse_fields ar $argv 453 | tkhtml_push color $tkhtml_priv(color) 454 | if [info exists ar(href)] { 455 | tkhtml_push href $ar(href) 456 | } else { 457 | tkhtml_push href {} 458 | } 459 | incr tkhtml_priv(anchor_count) 460 | set tkhtml_priv(color) blue 461 | incr tkhtml_priv(underline) 462 | tkhtml_set_tag 463 | } 464 | tkhtml_define_entity /a { 465 | tkhtml_pop href 466 | incr tkhtml_priv(anchor_count) -1 467 | set tkhtml_priv(color) [tkhtml_pop color] 468 | incr tkhtml_priv(underline) -1 469 | tkhtml_set_tag 470 | } 471 | tkhtml_define_entity center { 472 | tkhtml_push justify $tkhtml_priv(justify) 473 | set tkhtml_priv(justify) C 474 | tkhtml_set_tag 475 | } 476 | tkhtml_define_entity /center { 477 | set tkhtml_priv(justify) [tkhtml_pop justify] 478 | tkhtml_set_tag 479 | } 480 | tkhtml_define_entity ul { 481 | if $tkhtml_priv(left) { 482 | tkhtml_do br 483 | } else { 484 | tkhtml_do p 485 | } 486 | incr tkhtml_priv(left) $tkhtml_priv(indent_incr) 487 | incr tkhtml_priv(left2) [expr $tkhtml_priv(indent_incr)+3] 488 | tkhtml_push li_style $tkhtml_priv(li_style) 489 | set tkhtml_priv(li_style) bullet 490 | tkhtml_set_tag 491 | } 492 | tkhtml_define_entity /ul { 493 | incr tkhtml_priv(left) -$tkhtml_priv(indent_incr) 494 | incr tkhtml_priv(left2) -[expr $tkhtml_priv(indent_incr)+3] 495 | set tkhtml_priv(li_style) [tkhtml_pop li_style] 496 | tkhtml_set_tag 497 | tkhtml_do p 498 | } 499 | tkhtml_define_entity li { 500 | tkhtml_do br 501 | if {$tkhtml_priv(li_style) == "bullet"} { 502 | set old_font $tkhtml_priv(font) 503 | set tkhtml_priv(font) symbol 504 | tkhtml_set_tag 505 | $tkhtml_priv(w) insert end "\xb7" $tkhtml_priv(tag) 506 | set tkhtml_priv(font) $old_font 507 | tkhtml_set_tag 508 | } 509 | } 510 | tkhtml_define_entity listing { tkhtml_do pre } 511 | tkhtml_define_entity /listing { tkhtml_do /pre } 512 | tkhtml_define_entity code { tkhtml_do pre } 513 | tkhtml_define_entity /code { tkhtml_do /pre } 514 | 515 | tkhtml_define_entity img { 516 | tkhtml_parse_fields ar $argv 517 | if [info exists ar(src)] { 518 | set file $ar(src) 519 | if [info exists tkhtml_priv(image_hook)] { 520 | set img [eval $tkhmlt_priv(image_hook) $file] 521 | } else { 522 | if [catch {set img [image create photo -file $file]} err] { 523 | puts stderr "Couldn't create image $file: $err" 524 | return 525 | } 526 | } 527 | set align bottom 528 | if [info exists ar(align)] { 529 | set align [string tolower $ar(align)] 530 | } 531 | ttk::label $tkhtml_priv(w).$img -image $img 532 | $tkhtml_priv(w) window create end -window $tkhtml_priv(w).$img \ 533 | -align $align 534 | } 535 | } 536 | --------------------------------------------------------------------------------