Sign Up
Log In
Log In
or
Sign Up
Places
All Projects
Status Monitor
Collapse sidebar
openSUSE
tk.15844
tkcon.tcl
Overview
Repositories
Revisions
Requests
Users
Attributes
Meta
File tkcon.tcl of Package tk.15844
#!/bin/sh # -*- tcl -*- # \ exec wish "$0" ${1+"$@"} # ## tkcon.tcl ## Enhanced Tk Console, part of the VerTcl system ## ## Originally based off Brent Welch's Tcl Shell Widget ## (from "Practical Programming in Tcl and Tk") ## ## Thanks to the following (among many) for early bug reports & code ideas: ## Steven Wahl, Jan Nijtmans, Mark Crimmins, Wart ## ## Copyright (c) 1995-2011 Jeffrey Hobbs, jeff(a)hobbs(.)org ## Initiated: Thu Aug 17 15:36:47 PDT 1995 ## ## source standard_disclaimer.tcl ## source bourbon_ware.tcl ## # Proxy support for retrieving the current version of Tkcon. # # Mon Jun 25 12:19:56 2001 - Pat Thoyts # # In your tkcon.cfg or .tkconrc file put your proxy details into the # `proxy' member of the `PRIV' array. e.g.: # # set ::tkcon::PRIV(proxy) wwwproxy:8080 # # If you want to be prompted for proxy authentication details (eg for # an NT proxy server) make the second element of this variable non-nil - eg: # # set ::tkcon::PRIV(proxy) {wwwproxy:8080 1} # # Or you can set the above variable from within tkcon by calling # # tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080 # if {$tcl_version < 8.4} { return -code error "tkcon requires at least Tcl/Tk 8.4" } else { package require Tk 8.4 } # We need to load some package to get what's available, and we # choose ctext because we'll use it if its available in the editor catch {package require ctext} foreach pkg [info loaded {}] { set file [lindex $pkg 0] set name [lindex $pkg 1] if {![catch {set version [package require $name]}]} { if {[package ifneeded $name $version] eq ""} { package ifneeded $name $version [list load $file $name] } } } # Unset temporary global vars catch {unset pkg file name version} # Initialize the ::tkcon namespace # namespace eval ::tkcon { # when modifying this line, make sure that the auto-upgrade check # for version still works. variable VERSION "2.7" # The OPT variable is an array containing most of the optional # info to configure. COLOR has the color data. variable OPT variable COLOR # PRIV is used for internal data that only tkcon should fiddle with. variable PRIV set PRIV(WWW) [info exists embed_args] set PRIV(AQUA) [expr {$::tcl_version >= 8.4 && [tk windowingsystem] == "aqua"}] set PRIV(CTRL) [expr {$PRIV(AQUA) ? "Command-" : "Control-"}] set PRIV(ACC) [expr {$PRIV(AQUA) ? "Command-" : "Ctrl+"}] variable EXPECT 0 } ## ::tkcon::Init - inits tkcon # # Calls: ::tkcon::InitUI # Outputs: errors found in tkcon's resource file ## proc ::tkcon::Init {args} { variable VERSION variable OPT variable COLOR variable PRIV global tcl_platform env tcl_interactive errorInfo set tcl_interactive 1 set argc [llength $args] ## ## When setting up all the default values, we always check for ## prior existence. This allows users who embed tkcon to modify ## the initial state before tkcon initializes itself. ## # bg == {} will get bg color from the main toplevel (in InitUI) foreach {key default} { bg {} blink \#FFFF00 cursor \#000000 disabled \#4D4D4D proc \#008800 var \#FFC0D0 prompt \#8F4433 stdin \#000000 stdout \#0000FF stderr \#FF0000 } { if {![info exists COLOR($key)]} { set COLOR($key) $default } } # expandorder could also include 'Methodname' for XOTcl/NSF methods foreach {key default} { autoload {} blinktime 500 blinkrange 1 buffer 512 maxlinelen 0 calcmode 0 cols 80 debugPrompt {(level \#$level) debug [history nextid] > } dead {} edit edit expandorder {Pathname Variable Procname} font {} history 48 hoterrors 1 library {} lightbrace 1 lightcmd 1 maineval {} maxmenu 18 nontcl 0 prompt1 {ignore this, it's set below} rows 20 scrollypos right showmenu 1 showmultiple 1 showstatusbar 1 slaveeval {} slaveexit close subhistory 1 tabspace 8 gc-delay 60000 gets {congets} overrideexit 1 usehistory 1 resultfilter {} exec slave } { if {![info exists OPT($key)]} { set OPT($key) $default } } foreach {key default} { app {} appname {} apptype slave namesp :: cmd {} cmdbuf {} cmdsave {} event 1 deadapp 0 deadsock 0 debugging 0 displayWin . histid 0 find {} find,case 0 find,reg 0 errorInfo {} protocol exit showOnStartup 1 slaveprocs { alias clear dir dump echo idebug lremove tkcon_puts tkcon_gets observe observe_var unalias which what } RCS {RCS: @(#) $Id: tkcon.tcl,v 1.122 2014/09/09 10:46:15 hobbs Exp $} HEADURL {http://tkcon.cvs.sourceforge.net/viewvc/tkcon/tkcon/tkcon.tcl} docs "http://tkcon.sourceforge.net/" email {jeff(a)hobbs(.)org} root . uid 0 tabs {} } { if {![info exists PRIV($key)]} { set PRIV($key) $default } } foreach {key default} { slavealias { $OPT(edit) more less tkcon } } { if {![info exists PRIV($key)]} { set PRIV($key) [subst $default] } } set PRIV(version) $VERSION if {[info exists PRIV(name)]} { set title $PRIV(name) } else { MainInit # some main initialization occurs later in this proc, # to go after the UI init set MainInit 1 set title Main } ## NOTES FOR STAYING IN PRIMARY INTERPRETER: ## ## If you set ::tkcon::OPT(exec) to {}, then instead of a multiple ## interp model, you get tkcon operating in the main interp by default. ## This can be useful when attaching to programs that like to operate ## in the main interpter (for example, based on special wish'es). ## You can set this from the command line with -exec "" ## A side effect is that all tkcon command line args will be used ## by the first console only. #set OPT(exec) {} if {$PRIV(WWW)} { lappend PRIV(slavealias) history set OPT(prompt1) {[history nextid] % } } else { lappend PRIV(slaveprocs) tcl_unknown unknown set OPT(prompt1) {([file tail [pwd]]) [history nextid] % } } ## If we are using the default '.' toplevel, and there appear to be ## children of '.', then make sure we use a disassociated toplevel. if {$PRIV(root) == "." && [llength [winfo children .]]} { set PRIV(root) .tkcon } ## Do platform specific configuration here, other than defaults ### Use tkcon.cfg filename for resource filename on non-unix systems ### Determine what directory the resource file should be in switch $tcl_platform(platform) { macintosh { if {![interp issafe]} {cd [file dirname [info script]]} set envHome PREF_FOLDER set rcfile tkcon.cfg set histfile tkcon.hst catch {console hide} } windows { set envHome HOME set rcfile tkcon.cfg set histfile tkcon.hst } unix { set envHome HOME set rcfile .tkconrc set histfile .tkcon_history } } if {[info exists env($envHome)]} { set home $env($envHome) if {[file pathtype $home] == "volumerelative"} { # Convert 'C:' to 'C:/' if necessary, innocuous otherwise append home / } if {![info exists PRIV(rcfile)]} { set PRIV(rcfile) [file join $home $rcfile] } if {![info exists PRIV(histfile)]} { set PRIV(histfile) [file join $home $histfile] } } ## Handle command line arguments before sourcing resource file to ## find if resource file is being specified (let other args pass). if {[set i [lsearch -exact $args -rcfile]] != -1} { set PRIV(rcfile) [lindex $args [incr i]] } if {!$PRIV(WWW) && [file exists $PRIV(rcfile)]} { set code [catch {uplevel \#0 [list source $PRIV(rcfile)]} err] } if {[info exists env(TK_CON_LIBRARY)]} { lappend ::auto_path $env(TK_CON_LIBRARY) } elseif {$OPT(library) != ""} { lappend ::auto_path $OPT(library) } if {![info exists ::tcl_pkgPath]} { set dir [file join [file dirname [info nameofexec]] lib] if {[llength [info commands @scope]]} { set dir [file join $dir itcl] } catch {source [file join $dir pkgIndex.tcl]} } catch {tclPkgUnknown dummy-name dummy-version} ## Handle rest of command line arguments after sourcing resource file ## and slave is created, but before initializing UI or setting packages. set slaveargs {} set slavefiles {} set slaveargv0 {} set truth {^(1|yes|true|on)$} for {set i 0} {$i < $argc} {incr i} { set arg [lindex $args $i] if {[string match {-*} $arg]} { set val [lindex $args [incr i]] ## Handle arg based options switch -glob -- $arg { -- - -argv - -args { set slaveargs [concat $slaveargs [lrange $args $i end]] set ::argv $slaveargs set ::argc [llength $::argv] break } -color-* { set COLOR([string range $arg 7 end]) $val } -exec { set OPT(exec) $val } -main - -e - -eval { append OPT(maineval) \n$val\n } -package - -load { lappend OPT(autoload) $val if {$val eq "nsf" || $val eq "nx" || $val eq "XOTcl" } { # If xotcl is loaded, prepend expand order for it set OPT(expandorder) [concat Methodname $OPT(expandorder)] } } -slave { append OPT(slaveeval) \n$val\n } -nontcl { set OPT(nontcl) [regexp -nocase $truth $val]} -root { set PRIV(root) $val } -font { set OPT(font) $val } -rcfile {} default { lappend slaveargs $arg; incr i -1 } } } elseif {[file isfile $arg]} { if {$i == 0} { set slaveargv0 $arg } lappend slavefiles $arg } else { lappend slaveargs $arg } } ## Create slave executable if {"" != $OPT(exec)} { InitSlave $OPT(exec) $slaveargs $slaveargv0 } else { set argc [llength $slaveargs] set args $slaveargs uplevel \#0 $slaveargs } # Try not to make tkcon override too many standard defaults, and only # do it for the tkcon bits set optclass [tk appname]$PRIV(root) option add $optclass*Menu.tearOff 0 option add $optclass*Menu.borderWidth 1 option add $optclass*Menu.activeBorderWidth 1 if {!$PRIV(AQUA)} { option add $optclass*Scrollbar.borderWidth 1 } ## Attach to the slave, EvalAttached will then be effective Attach $PRIV(appname) $PRIV(apptype) InitUI $title if {"" != $OPT(exec)} { # override exit to DeleteTab now that tab has been created $OPT(exec) alias exit ::tkcon::DeleteTab $PRIV(curtab) $OPT(exec) } ## swap puts and gets with the tkcon versions to make sure all ## input and output is handled by tkcon if {![catch {rename ::puts ::tkcon_tcl_puts}]} { interp alias {} ::puts {} ::tkcon_puts if {[llength [info commands ::tcl::chan::puts]]} { interp alias {} ::tcl::chan::puts {} ::tkcon_puts } } if {($OPT(gets) != "") && ![catch {rename ::gets ::tkcon_tcl_gets}]} { interp alias {} ::gets {} ::tkcon_gets if {[llength [info commands ::tcl::chan::gets]]} { interp alias {} ::tcl::chan::gets {} ::tkcon_gets } } EvalSlave history keep $OPT(history) if {[info exists MainInit]} { # Source history file only for the main console, as all slave # consoles will adopt from the main's history, but still # keep separate histories if {!$PRIV(WWW) && $OPT(usehistory) && [file exists $PRIV(histfile)]} { puts -nonewline "loading history file ... " # The history file is built to be loaded in and # understood by tkcon if {[catch {uplevel \#0 [list source $PRIV(histfile)]} herr]} { puts stderr "error:\n$herr" append PRIV(errorInfo) $errorInfo\n } set PRIV(event) [EvalSlave history nextid] puts "[expr {$PRIV(event)-1}] events added" } } ## Autoload specified packages in slave set pkgs [EvalSlave package names] foreach pkg $OPT(autoload) { puts -nonewline "autoloading package \"$pkg\" ... " if {[lsearch -exact $pkgs $pkg]>-1} { if {[catch {EvalSlave package require [list $pkg]} pkgerr]} { puts stderr "error:\n$pkgerr" append PRIV(errorInfo) $errorInfo\n } else { puts "OK" } } else { puts stderr "error: package does not exist" } } ## Evaluate maineval in slave if {($OPT(maineval) ne "") && [catch {uplevel \#0 $OPT(maineval)} merr]} { puts stderr "error in eval:\n$merr" append PRIV(errorInfo) $errorInfo\n } ## Source extra command line argument files into slave executable foreach fn $slavefiles { puts -nonewline "slave sourcing \"$fn\" ... " if {[catch {EvalSlave uplevel \#0 [list source $fn]} fnerr]} { puts stderr "error:\n$fnerr" append PRIV(errorInfo) $errorInfo\n } else { puts "OK" } } ## Evaluate slaveeval in slave if {($OPT(slaveeval) ne "") && [catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} { puts stderr "error in slave eval:\n$serr" append PRIV(errorInfo) $errorInfo\n } ## Output any error/output that may have been returned from rcfile if {[info exists code] && $code && ($err ne "")} { puts stderr "error in $PRIV(rcfile):\n$err" append PRIV(errorInfo) $errorInfo } if {$OPT(exec) ne ""} { StateCheckpoint [concat $PRIV(name) $OPT(exec)] slave } StateCheckpoint $PRIV(name) slave puts "buffer line limit:\ [expr {$OPT(buffer)?$OPT(buffer):{unlimited}}] \ max line length:\ [expr {$OPT(maxlinelen)?$OPT(maxlinelen):{unlimited}}]" Prompt "$title console display active (Tcl$::tcl_patchLevel / Tk$::tk_patchLevel)\n" } ## ::tkcon::InitSlave - inits the slave by placing key procs and aliases in it ## It's arg[cv] are based on passed in options, while argv0 is the same as ## the master. tcl_interactive is the same as the master as well. # ARGS: slave - name of slave to init. If it does not exist, it is created. # args - args to pass to a slave as argv/argc ## proc ::tkcon::InitSlave {slave {slaveargs {}} {slaveargv0 {}}} { variable OPT variable COLOR variable PRIV global argv0 tcl_interactive tcl_library env auto_path tk_library if {$slave eq ""} { return -code error "Don't init the master interpreter, goofball" } if {![interp exists $slave]} { interp create $slave } if {[interp eval $slave info command source] == ""} { $slave alias source SafeSource $slave $slave alias load SafeLoad $slave $slave alias open SafeOpen $slave $slave alias file file interp eval $slave \ [list set auto_path [lremove $auto_path $tk_library]] interp eval $slave [dump var -nocomplain tcl_library env] interp eval $slave { catch {source [file join $tcl_library init.tcl]} } interp eval $slave { catch unknown } } # This will likely be overridden to call DeleteTab where possible $slave alias exit exit interp eval $slave { # Do package require before changing around puts/gets catch {set __tkcon_error ""; set __tkcon_error $errorInfo} catch {package require bogus-package-name} catch {rename ::puts ::tkcon_tcl_puts} set errorInfo ${__tkcon_error} unset __tkcon_error } foreach cmd $PRIV(slaveprocs) { $slave eval [dump proc $cmd] } foreach cmd $PRIV(slavealias) { $slave alias $cmd $cmd } interp alias $slave ::ls $slave ::dir -full interp alias $slave ::puts $slave ::tkcon_puts if {[llength [info commands ::tcl::chan::puts]]} { interp alias $slave ::tcl::chan::puts $slave ::tkcon_puts } if {$OPT(gets) != ""} { interp eval $slave { catch {rename ::gets ::tkcon_tcl_gets} } interp alias $slave ::gets $slave ::tkcon_gets if {[llength [info commands ::tcl::chan::gets]]} { interp alias $slave ::tcl::chan::gets $slave ::tkcon_gets } } if {$slaveargv0 != ""} { # If tkcon was invoked with 1 or more filenames, then make the # first filename argv0 in the slave, as tclsh/wish would do it. interp eval $slave [list set argv0 $slaveargv0] } else { if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]} } interp eval $slave set tcl_interactive $tcl_interactive \; \ set auto_path [list [lremove $auto_path $tk_library]] \; \ set argc [llength $slaveargs] \; \ set argv [list $slaveargs] \; { if {![llength [info command bgerror]]} { proc bgerror err { global errorInfo set body [info body bgerror] rename ::bgerror {} if {[auto_load bgerror]} { return [bgerror $err] } proc bgerror err $body tkcon bgerror $err $errorInfo } } } foreach pkg [lremove [package names] Tcl] { foreach v [package versions $pkg] { interp eval $slave [list package ifneeded $pkg $v \ [package ifneeded $pkg $v]] } } } ## ::tkcon::InitInterp - inits an interpreter by placing key ## procs and aliases in it. # ARGS: name - interp name # type - interp type (slave|interp) ## proc ::tkcon::InitInterp {name type} { variable OPT variable PRIV ## Don't allow messing up a local master interpreter if {($type eq "namespace") || (($type eq "slave") && [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} { return } set old [Attach] set oldname $PRIV(namesp) catch { Attach $name $type EvalAttached { catch {rename ::puts ::tkcon_tcl_puts} } foreach cmd $PRIV(slaveprocs) { EvalAttached [dump proc $cmd] } switch -exact $type { slave { foreach cmd $PRIV(slavealias) { Main [list interp alias $name ::$cmd $PRIV(name) ::$cmd] } } interp { set thistkcon [::send::appname] foreach cmd $PRIV(slavealias) { EvalAttached "proc $cmd args { ::send::send [list $thistkcon] $cmd \$args }" } } } ## Catch in case it's a 7.4 (no 'interp alias') interp EvalAttached { catch {interp alias {} ::ls {} ::dir -full} if {[catch {interp alias {} ::puts {} ::tkcon_puts}]} { catch {rename ::tkcon_puts ::puts} } elseif {[llength [info commands ::tcl::chan::puts]]} { catch {interp alias {} ::tcl::chan::puts {} ::tkcon_puts} } } if {$OPT(gets) != ""} { EvalAttached { catch {rename ::gets ::tkcon_tcl_gets} if {[catch {interp alias {} ::gets {} ::tkcon_gets}]} { catch {rename ::tkcon_gets ::gets} } elseif {[llength [info commands ::tcl::chan::gets]]} { catch {interp alias {} ::tcl::chan::gets {} ::tkcon_gets} } } } return } {err} eval Attach $old AttachNamespace $oldname if {$err ne ""} { return -code error $err } } ## ::tkcon::InitUI - inits UI portion (console) of tkcon ## Creates all elements of the console window and sets up the text tags # ARGS: root - widget pathname of the tkcon console root # title - title for the console root and main (.) windows # Calls: ::tkcon::InitMenus, ::tkcon::Prompt ## proc ::tkcon::InitUI {title} { variable OPT variable PRIV variable COLOR set root $PRIV(root) if {$root eq "."} { set w {} } else { set w [toplevel $root] } if {!$PRIV(WWW)} { wm withdraw $root wm protocol $root WM_DELETE_WINDOW $PRIV(protocol) } set PRIV(base) $w catch {font create tkconfixed -family Courier -size -12} catch {font create tkconfixedbold -family Courier -size -12 -weight bold} set PRIV(statusbar) [set sbar [frame $w.fstatus]] set PRIV(tabframe) [frame $sbar.tabs] set PRIV(X) [button $sbar.deltab -text "X" -command ::tkcon::DeleteTab \ -activeforeground red -fg red -font tkconfixedbold \ -highlightthickness 0 -padx 2 -pady 0 -borderwidth 1 \ -state disabled -relief flat -takefocus 0] catch {$PRIV(X) configure -overrelief raised} label $sbar.cursor -relief sunken -borderwidth 1 -anchor e -width 6 \ -textvariable ::tkcon::PRIV(StatusCursor) set padx [expr {![info exists ::tcl_platform(os)] || ($::tcl_platform(os) ne "Windows CE")}] grid $PRIV(X) $PRIV(tabframe) $sbar.cursor -sticky news -padx $padx grid configure $PRIV(tabframe) -sticky nsw grid configure $PRIV(X) -pady 0 -padx 0 grid columnconfigure $sbar 1 -weight 1 grid rowconfigure $sbar 0 -weight 1 grid rowconfigure $PRIV(tabframe) 0 -weight 1 if {$PRIV(AQUA)} { # resize control space and correct "X" button space grid columnconfigure $sbar [lindex [grid size $sbar] 0] -minsize 16 $PRIV(X) configure -pady 5 -padx 4 } ## Create console tab set con [InitTab $w] set PRIV(curtab) $con # Only apply this for the first console $con configure -setgrid 1 -width $OPT(cols) -height $OPT(rows) bind $PRIV(root) <Configure> { if {"%W" == $::tkcon::PRIV(root)} { scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \ ::tkcon::OPT(cols) ::tkcon::OPT(rows) if {[info exists ::tkcon::EXP(spawn_id)]} { catch {stty rows $::tkcon::OPT(rows) columns \ $::tkcon::OPT(cols) < $::tkcon::EXP(slave,name)} } } } # scrollbar set sy [scrollbar $w.sy -takefocus 0 -command [list $con yview]] if {!$PRIV(WWW) && ($::tcl_platform(os) eq "Windows CE")} { $w.sy configure -width 10 } $con configure -yscrollcommand [list $sy set] set PRIV(console) $con set PRIV(scrolly) $sy ## Menus ## catch against use in plugin if {[catch {menu $w.mbar} PRIV(menubar)]} { set PRIV(menubar) [frame $w.mbar -relief raised -borderwidth 1] } InitMenus $PRIV(menubar) $title Bindings if {$OPT(showmenu)} { $root configure -menu $PRIV(menubar) } grid $con -row 1 -column 1 -sticky news grid $sy -row 1 -column [expr {$OPT(scrollypos)=="left"?0:2}] -sticky ns grid $sbar -row 2 -column 0 -columnspan 3 -sticky ew grid columnconfigure $root 1 -weight 1 grid rowconfigure $root 1 -weight 1 if {!$OPT(showstatusbar)} { grid remove $sbar } # If we can locate the XDG icon file then make use of it. if {[package vsatisfies [package provide Tk] 8.6]} { if {[tk windowingsystem] eq "x11"} { if {[set icon [locate_xdg_icon tkcon-icon.png]] ne ""} { image create photo tkcon_icon -file $icon wm iconphoto $root tkcon_icon } } } if {!$PRIV(WWW)} { wm title $root "tkcon $PRIV(version) $title" if {$PRIV(showOnStartup)} { # this may throw an error if toplevel is embedded catch {wm deiconify $root} } } if {$PRIV(showOnStartup)} { focus -force $PRIV(console) } if {$OPT(gc-delay)} { after $OPT(gc-delay) ::tkcon::GarbageCollect } } # Hunt around the XDG defined directories for the icon. # Note: hicolor is the standard theme used by xdg-icon-resource. proc ::tkcon::locate_xdg_icon {name} { global env set dirs [list /usr/local/share /usr/share] if {[info exists env(XDG_DATA_DIRS)]} { set dirs [split $env(XDG_DATA_DIRS) :] } if {[file isdirectory ~/.local/share]} { set dirs [linsert $dirs 0 ~/.local/share] } foreach dir $dirs { foreach path [list icons icons/hicolor/48x48/apps] { set path [file join $dir $path $name] if {[file exists $path]} { return $path } } } return "" } proc ::tkcon::InitTab {w} { variable OPT variable PRIV variable COLOR variable ATTACH # text console set con $w.tab[incr PRIV(uid)] text $con -wrap char -foreground $COLOR(stdin) \ -insertbackground $COLOR(cursor) -borderwidth 1 -highlightthickness 0 $con mark set output 1.0 $con mark set limit 1.0 if {$COLOR(bg) ne ""} { $con configure -background $COLOR(bg) } set COLOR(bg) [$con cget -background] if {$OPT(font) ne ""} { ## Set user-requested font, if any $con configure -font $OPT(font) } elseif {$::tcl_platform(platform) ne "unix"} { ## otherwise make sure the font is monospace set font [$con cget -font] if {![font metrics $font -fixed]} { $con configure -font tkconfixed } } else { $con configure -font tkconfixed } set OPT(font) [$con cget -font] bindtags $con [list $con TkConsole TkConsolePost $PRIV(root) all] # scrollbar if {!$PRIV(WWW)} { if {$::tcl_platform(os) eq "Windows CE"} { font configure tkconfixed -family Tahoma -size 8 $con configure -font tkconfixed -borderwidth 0 -padx 0 -pady 0 set cw [font measure tkconfixed "0"] set ch [font metrics tkconfixed -linespace] set sw [winfo screenwidth $con] set sh [winfo screenheight $con] # We need the magic hard offsets until I find a way to # correctly assume size if {$cw*($OPT(cols)+2) > $sw} { set OPT(cols) [expr {($sw / $cw) - 2}] } if {$ch*($OPT(rows)+3) > $sh} { set OPT(rows) [expr {($sh / $ch) - 3}] } # Place it so that the titlebar underlaps the CE titlebar wm geometry $PRIV(root) +0+0 } } $con configure -height $OPT(rows) -width $OPT(cols) foreach col {prompt stdout stderr stdin proc} { $con tag configure $col -foreground $COLOR($col) } $con tag configure var -background $COLOR(var) $con tag raise sel $con tag configure blink -background $COLOR(blink) $con tag configure find -background $COLOR(blink) set ATTACH($con) [Attach] set rb [radiobutton $PRIV(tabframe).cb[winfo name $con] -takefocus 0 \ -textvariable ::tkcon::ATTACH($con) \ -selectcolor white -relief sunken \ -indicatoron 0 -padx 0 -pady 0 -borderwidth 1 \ -variable ::tkcon::PRIV(curtab) -value $con \ -command [list ::tkcon::GotoTab $con]] if {$::tcl_version >= 8.4} { $rb configure -offrelief flat -overrelief raised } if {$PRIV(AQUA)} { $rb configure -padx 4 -pady 4 -highlightthickness 0 } grid $rb -row 0 -column [lindex [grid size $PRIV(tabframe)] 0] -sticky ns grid $con -row 1 -column 1 -sticky news lappend PRIV(tabs) $con return $con } proc ::tkcon::GotoTab {con} { variable PRIV variable ATTACH set numtabs [llength $PRIV(tabs)] #if {$numtabs == 1} { return } if {[regexp {^[0-9]+$} $con]} { set curtab [lsearch -exact $PRIV(tabs) $PRIV(console)] set nexttab [expr {$curtab + $con}] if {$nexttab >= $numtabs} { set nexttab 0 } elseif {$nexttab < 0} { set nexttab "end" } set con [lindex $PRIV(tabs) $nexttab] } elseif {$con == $PRIV(console)} { return } # adjust console if {[winfo exists $PRIV(console)]} { lower $PRIV(console) $PRIV(console) configure -yscrollcommand {} set ATTACH($PRIV(console)) [Attach] } set PRIV(console) $con $con configure -yscrollcommand [list $PRIV(scrolly) set] $PRIV(scrolly) configure -command [list $con yview] # adjust attach eval [linsert $ATTACH($con) 0 Attach] set PRIV(curtab) $con raise $con if {[$con compare 1.0 == end-1c]} { Prompt } # set StatusCursor set PRIV(StatusCursor) [$con index insert] focus -force $con } proc ::tkcon::NewTab {{con {}}} { variable PRIV variable ATTACH set con [InitTab $PRIV(base)] set slave [GetSlave] InitSlave $slave $slave alias exit ::tkcon::DeleteTab $con $slave if {$PRIV(name) != ""} { set ATTACH($con) [list [list $PRIV(name) $slave] slave] } else { set ATTACH($con) [list $slave slave] } $PRIV(X) configure -state normal MenuConfigure Console "Delete Tab" -state normal GotoTab $con } # The extra code arg is for the alias of exit to this function proc ::tkcon::DeleteTab {{con {}} {slave {}} {code 0}} { variable PRIV set numtabs [llength $PRIV(tabs)] if {$numtabs <= 2} { $PRIV(X) configure -state disabled MenuConfigure Console "Delete Tab" -state disabled } if {$numtabs == 1} { # in the master, it should do the right thing # currently the first master still exists - need rearch to fix exit # we might end up here, depending on how exit is rerouted return } if {$con == ""} { set con $PRIV(console) } catch {unset ATTACH($con)} set curtab [lsearch -exact $PRIV(tabs) $con] set PRIV(tabs) [lreplace $PRIV(tabs) $curtab $curtab] set numtabs [llength $PRIV(tabs)] set nexttab $curtab if {$nexttab >= $numtabs} { set nexttab end } set nexttab [lindex $PRIV(tabs) $nexttab] GotoTab $nexttab if {$slave != "" && $slave != $::tkcon::OPT(exec)} { interp delete $slave } destroy $PRIV(tabframe).cb[winfo name $con] destroy $con } ## ::tkcon::GarbageCollect - do various cleanup ops periodically to our setup ## proc ::tkcon::GarbageCollect {} { variable OPT variable PRIV foreach w $PRIV(tabs) { if {[winfo exists $w]} { ## Remove error tags that no longer span anything ## Make sure the tag pattern matches the unique tag prefix foreach tag [$w tag names] { if {[string match _tag* $tag] && ![llength [$w tag ranges $tag]]} { $w tag delete $tag } } } } if {$OPT(gc-delay)} { after $OPT(gc-delay) ::tkcon::GarbageCollect } } ## ::tkcon::Eval - evaluates commands input into console window ## This is the first stage of the evaluating commands in the console. ## They need to be broken up into consituent commands (by ::tkcon::CmdSep) in ## case a multiple commands were pasted in, then each is eval'ed (by ## ::tkcon::EvalCmd) in turn. Any uncompleted command will not be eval'ed. # ARGS: w - console text widget # Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd ## proc ::tkcon::Eval {w} { set complete [CmdSep [CmdGet $w] cmds last] $w mark set insert end-1c $w insert end \n if {[llength $cmds]} { foreach c $cmds {EvalCmd $w $c} $w insert insert $last {} } elseif {$complete} { EvalCmd $w $last } if {[winfo exists $w]} { $w see insert } } ## ::tkcon::EvalCmd - evaluates a single command, adding it to history # ARGS: w - console text widget # cmd - the command to evaluate # Calls: ::tkcon::Prompt # Outputs: result of command to stdout (or stderr if error occured) # Returns: next event number ## proc ::tkcon::EvalCmd {w cmd} { variable OPT variable PRIV $w mark set output end if {$cmd ne ""} { set code 0 if {$OPT(subhistory)} { set ev [EvalSlave history nextid] incr ev -1 ## FIX: calcmode doesn't work with requesting history events if {$cmd eq "!!"} { set code [catch {EvalSlave history event $ev} cmd] if {!$code} {$w insert output $cmd\n stdin} } elseif {[regexp {^!(.+)$} $cmd dummy event]} { ## Check last event because history event is broken set code [catch {EvalSlave history event $ev} cmd] if {!$code && ![string match ${event}* $cmd]} { set code [catch {EvalSlave history event $event} cmd] } if {!$code} {$w insert output $cmd\n stdin} } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { set code [catch {EvalSlave history event $ev} cmd] if {!$code} { regsub -all -- $old $cmd $new cmd $w insert output $cmd\n stdin } } elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} { AddSlaveHistory $cmd set cmd $err set code -1 } } if {$code} { $w insert output $cmd\n stderr } else { ## We are about to evaluate the command, so move the limit ## mark to ensure that further <Return>s don't cause double ## evaluation of this command - for cases like the command ## has a vwait or something in it $w mark set limit end if {$OPT(nontcl) && ($PRIV(apptype) eq "interp")} { set code [catch {EvalSend $cmd} res] if {$code == 1} { set PRIV(errorInfo) "Non-Tcl errorInfo not available" } } elseif {$PRIV(apptype) eq "socket"} { set code [catch {EvalSocket $cmd} res] if {$code == 1} { set PRIV(errorInfo) "Socket-based errorInfo not available" } } else { set code [catch {EvalAttached $cmd} res] if {$code == 1} { if {[catch {EvalAttached [list set errorInfo]} err]} { set PRIV(errorInfo) "Error getting errorInfo:\n$err" } else { set PRIV(errorInfo) $err } } } if {![winfo exists $w]} { # early abort - must be a deleted tab return } AddSlaveHistory $cmd # Run any user defined result filter command. The command is # passed result code and data. if {[llength $OPT(resultfilter)]} { set cmd [linsert $OPT(resultfilter) end $code $res] if {[catch {EvalAttached $cmd} res2]} { $w insert output "Filter failed: $res2" stderr \n stdout } else { set res $res2 } } catch {EvalAttached [list set _ $res]} set maxlen $OPT(maxlinelen) set trailer "" if {($maxlen > 0) && ([string length $res] > $maxlen)} { # If we exceed maximum desired output line length, truncate # the result and add "...+${num}b" in error coloring set trailer ...+[expr {[string length $res]-$maxlen}]b set res [string range $res 0 $maxlen] } if {$code} { if {$OPT(hoterrors)} { set tag [UniqueTag $w] $w insert output $res [list stderr $tag] \n$trailer stderr $w tag bind $tag <Enter> \ [list $w tag configure $tag -under 1] $w tag bind $tag <Leave> \ [list $w tag configure $tag -under 0] $w tag bind $tag <ButtonRelease-1> \ "if {!\[info exists tk::Priv(mouseMoved)\] || !\$tk::Priv(mouseMoved)} \ {[list $OPT(edit) -attach [Attach] -type error -- $PRIV(errorInfo)]}" } else { $w insert output $res\n$trailer stderr } } elseif {$res ne ""} { $w insert output $res stdout $trailer stderr \n stdout } } } Prompt set PRIV(event) [EvalSlave history nextid] } ## ::tkcon::EvalSlave - evaluates the args in the associated slave ## args should be passed to this procedure like they would be at ## the command line (not like to 'eval'). # ARGS: args - the command and args to evaluate ## proc ::tkcon::EvalSlave args { interp eval $::tkcon::OPT(exec) $args } ## ::tkcon::EvalOther - evaluate a command in a foreign interp or slave ## without attaching to it. No check for existence is made. # ARGS: app - interp/slave name # type - (slave|interp) ## proc ::tkcon::EvalOther { app type args } { if {$type eq "slave"} { return [Slave $app $args] } else { return [uplevel 1 ::send::send [list $app] $args] } } ## ::tkcon::AddSlaveHistory - ## Command is added to history only if different from previous command. ## This also doesn't cause the history id to be incremented, although the ## command will be evaluated. # ARGS: cmd - command to add ## proc ::tkcon::AddSlaveHistory cmd { set ev [EvalSlave history nextid] incr ev -1 set code [catch {EvalSlave history event $ev} lastCmd] if {$code || $cmd ne $lastCmd} { EvalSlave history add $cmd # Save history every time so it's not lost in case of an abnormal termination. # Do not warn in case of an error: we don't want an error message # after each command if the history file is not writable. catch {SaveHistory} } } ## ::tkcon::EvalSend - sends the args to the attached interpreter ## Varies from 'send' by determining whether attachment is dead ## when an error is received # ARGS: cmd - the command string to send across # Returns: the result of the command ## proc ::tkcon::EvalSend cmd { variable OPT variable PRIV if {$PRIV(deadapp)} { if {[lsearch -exact [::send::interps] $PRIV(app)]<0} { return } else { set PRIV(appname) [string range $PRIV(appname) 5 end] set PRIV(deadapp) 0 Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)] } } set code [catch {::send::send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result] if {$code && [lsearch -exact [::send::interps] $PRIV(app)]<0} { ## Interpreter disappeared if {($OPT(dead) ne "leave") && (($OPT(dead) eq "ignore") || [tk_messageBox -title "Dead Attachment" -type yesno \ -icon info -message \ "\"$PRIV(app)\" appears to have died.\ \nReturn to primary slave interpreter?"] eq "no")} { set PRIV(appname) "DEAD:$PRIV(appname)" set PRIV(deadapp) 1 } else { set err "Attached Tk interpreter \"$PRIV(app)\" died." Attach {} set PRIV(deadapp) 0 EvalSlave set errorInfo $err } Prompt \n [CmdGet $PRIV(console)] } return -code $code $result } ## ::tkcon::EvalSocket - sends the string to an interpreter attached via ## a tcp/ip socket ## ## In the EvalSocket case, ::tkcon::PRIV(app) is the socket id ## ## Must determine whether socket is dead when an error is received # ARGS: cmd - the data string to send across # Returns: the result of the command ## proc ::tkcon::EvalSocket cmd { variable OPT variable PRIV global tcl_version if {$PRIV(deadapp)} { if {![info exists PRIV(app)] || \ [catch {eof $PRIV(app)} eof] || $eof} { return } else { set PRIV(appname) [string range $PRIV(appname) 5 end] set PRIV(deadapp) 0 Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)] } } # Sockets get \'s interpreted, so that users can # send things like \n\r or explicit hex values set cmd [subst -novariables -nocommands $cmd] #puts [list $PRIV(app) $cmd] set code [catch {puts $PRIV(app) $cmd ; flush $PRIV(app)} result] if {$code && [eof $PRIV(app)]} { ## Interpreter died or disappeared puts "$code eof [eof $PRIV(app)]" EvalSocketClosed $PRIV(app) } return -code $code $result } ## ::tkcon::EvalSocketEvent - fileevent command for an interpreter attached ## via a tcp/ip socket ## Must determine whether socket is dead when an error is received # ARGS: args - the args to send across # Returns: the result of the command ## proc ::tkcon::EvalSocketEvent {sock} { variable PRIV if {[gets $sock line] == -1} { if {[eof $sock]} { EvalSocketClosed $sock } return } puts $line } ## ::tkcon::EvalSocketClosed - takes care of handling a closed eval socket ## # ARGS: args - the args to send across # Returns: the result of the command ## proc ::tkcon::EvalSocketClosed {sock} { variable OPT variable PRIV catch {close $sock} if {$sock ne $PRIV(app)} { # If we are not still attached to that socket, just return. # Might be nice to tell the user the socket closed ... return } if {$OPT(dead) ne "leave" && ($OPT(dead) eq "ignore" || [tk_messageBox -title "Dead Attachment" -type yesno \ -icon question \ -message "\"$PRIV(app)\" appears to have died.\ \nReturn to primary slave interpreter?"] eq "no")} { set PRIV(appname) "DEAD:$PRIV(appname)" set PRIV(deadapp) 1 } else { set err "Attached Tk interpreter \"$PRIV(app)\" died." Attach {} set PRIV(deadapp) 0 EvalSlave set errorInfo $err } Prompt \n [CmdGet $PRIV(console)] } ## ::tkcon::EvalNamespace - evaluates the args in a particular namespace ## This is an override for ::tkcon::EvalAttached for when the user wants ## to attach to a particular namespace of the attached interp # ARGS: attached # namespace the namespace to evaluate in # args the args to evaluate # RETURNS: the result of the command ## proc ::tkcon::EvalNamespace { attached namespace args } { if {[llength $args]} { uplevel \#0 $attached \ [list [concat [list namespace eval $namespace] $args]] } } ## ::tkcon::Namespaces - return all the namespaces descendent from $ns ## # ## proc ::tkcon::Namespaces {{ns ::} {l {}}} { if {$ns ne ""} { lappend l $ns } foreach i [EvalAttached [list namespace children $ns]] { set l [Namespaces $i $l] } return $l } ## ::tkcon::CmdGet - gets the current command from the console widget # ARGS: w - console text widget # Returns: text which compromises current command line ## proc ::tkcon::CmdGet w { if {![llength [$w tag nextrange prompt limit end]]} { $w tag add stdin limit end-1c return [$w get limit end-1c] } } ## ::tkcon::CmdSep - separates multiple commands into a list and remainder # ARGS: cmd - (possible) multiple command to separate # list - varname for the list of commands that were separated. # last - varname of any remainder (like an incomplete final command). # If there is only one command, it's placed in this var. # Returns: constituent command info in varnames specified by list & rmd. ## proc ::tkcon::CmdSep {cmd list last} { upvar 1 $list cmds $last inc set inc {} set cmds {} foreach c [split [string trimleft $cmd] \n] { if {$inc ne ""} { append inc \n$c } else { append inc [string trimleft $c] } if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} { if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} set inc {} } } set i [string equal $inc {}] if {$i && $cmds ne "" && ![string match *\n $cmd]} { set inc [lindex $cmds end] set cmds [lreplace $cmds end end] } return $i } ## ::tkcon::CmdSplit - splits multiple commands into a list # ARGS: cmd - (possible) multiple command to separate # Returns: constituent commands in a list ## proc ::tkcon::CmdSplit {cmd} { set inc {} set cmds {} foreach cmd [split [string trimleft $cmd] \n] { if {$inc ne ""} { append inc \n$cmd } else { append inc [string trimleft $cmd] } if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} { #set inc [string trimright $inc] if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} set inc {} } } if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} return $cmds } ## ::tkcon::UniqueTag - creates a uniquely named tag, reusing names ## Called by ::tkcon::EvalCmd # ARGS: w - text widget # Outputs: tag name guaranteed unique in the widget ## proc ::tkcon::UniqueTag {w} { set tags [$w tag names] set idx 0 while {[lsearch -exact $tags _tag[incr idx]] != -1} {} return _tag$idx } ## ::tkcon::ConstrainBuffer - This limits the amount of data in the text widget ## Called by ::tkcon::Prompt and in tkcon proc buffer/console switch cases # ARGS: w - console text widget # size - # of lines to constrain to # Outputs: may delete data in console widget ## proc ::tkcon::ConstrainBuffer {w size} { if {$size && ([$w index end] > $size)} { $w delete 1.0 [expr {int([$w index end])-$size}].0 } } ## ::tkcon::Prompt - displays the prompt in the console widget # ARGS: w - console text widget # Outputs: prompt (specified in ::tkcon::OPT(prompt1)) to console ## proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} { variable OPT variable PRIV set w $PRIV(console) if {![winfo exists $w]} { return } if {$pre ne ""} { $w insert end $pre stdout } set i [$w index end-1c] if {!$OPT(showstatusbar)} { if {$PRIV(appname) ne ""} { $w insert end ">$PRIV(appname)< " prompt } if {$PRIV(namesp) ne "::"} { $w insert end "<$PRIV(namesp)> " prompt } } if {$prompt ne ""} { $w insert end $prompt prompt } else { $w insert end [EvalSlave subst $OPT(prompt1)] prompt } $w mark set output $i $w mark set insert end $w mark set limit insert $w mark gravity limit left if {$post ne ""} { $w insert end $post stdin } ConstrainBuffer $w $OPT(buffer) set ::tkcon::PRIV(StatusCursor) [$w index insert] $w see end } proc ::tkcon::RePrompt {{pre {}} {post {}} {prompt {}}} { # same as prompt, but does nothing for those actions where we # only wanted to refresh the prompt on attach change when the # statusbar is showing (which carries that info instead) variable OPT if {!$OPT(showstatusbar)} { Prompt $pre $post $prompt } } ## ::tkcon::About - gives about info for tkcon ## proc ::tkcon::About {} { variable OPT variable PRIV variable COLOR set w $PRIV(base).about if {![winfo exists $w]} { global tk_patchLevel tcl_patchLevel tcl_version toplevel $w wm withdraw $w wm transient $w $PRIV(root) wm group $w $PRIV(root) catch {wm attributes $w -type dialog} wm title $w "About tkcon v$PRIV(version)" wm resizable $w 0 0 button $w.b -text Dismiss -command [list wm withdraw $w] text $w.text -height 9 -width 60 \ -foreground $COLOR(stdin) \ -background $COLOR(bg) \ -font $OPT(font) -borderwidth 1 -highlightthickness 0 grid $w.text -sticky news grid $w.b -sticky se -padx 6 -pady 4 $w.text tag config center -justify center $w.text tag config title -justify center -font {Courier -18 bold} # strip down the RCS info displayed in the about box regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS $w.text insert 1.0 "About tkcon v$PRIV(version)" title \ "\n\nCopyright 1995-2002 Jeffrey Hobbs, $PRIV(email)\ \nRelease Info: v$PRIV(version), CVS v$RCS\ \nDocumentation available at:\n$PRIV(docs)\ \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center $w.text config -state disabled bind $w <Escape> [list destroy $w] } wm deiconify $w } ## ::tkcon::InitMenus - inits the menubar and popup for the console # ARGS: w - console text widget ## proc ::tkcon::InitMenus {w title} { variable OPT variable PRIV variable COLOR global tcl_platform if {[catch {menu $w.pop}]} { label $w.label -text "Menus not available in plugin mode" grid $w.label -sticky ew return } menu $w.context -disabledforeground $COLOR(disabled) set PRIV(context) $w.context set PRIV(popup) $w.pop proc MenuButton {w m l} { $w add cascade -label $m -underline 0 -menu $w.$l return $w.$l } proc MenuConfigure {m l args} { variable PRIV eval [list $PRIV(menubar).[string tolower $m] entryconfigure $l] $args eval [list $PRIV(popup).[string tolower $m] entryconfigure $l] $args } foreach m [list File Console Edit Interp Prefs History Help] { set l [string tolower $m] MenuButton $w $m $l $w.pop add cascade -label $m -underline 0 -menu $w.pop.$l } ## File Menu ## foreach m [list [menu $w.file -disabledforeground $COLOR(disabled)] \ [menu $w.pop.file -disabledforeground $COLOR(disabled)]] { $m add command -label "Load File" -underline 0 -command ::tkcon::Load $m add cascade -label "Save ..." -underline 0 -menu $m.save $m add separator $m add command -label "Quit" -underline 0 -accel $PRIV(ACC)q \ -command exit ## Save Menu ## set s $m.save menu $s -disabledforeground $COLOR(disabled) $s add command -label "All" -underline 0 \ -command {::tkcon::Save {} all} $s add command -label "History" -underline 0 \ -command {::tkcon::Save {} history} $s add command -label "Stdin" -underline 3 \ -command {::tkcon::Save {} stdin} $s add command -label "Stdout" -underline 3 \ -command {::tkcon::Save {} stdout} $s add command -label "Stderr" -underline 3 \ -command {::tkcon::Save {} stderr} } ## Console Menu ## foreach m [list [menu $w.console -disabledfore $COLOR(disabled)] \ [menu $w.pop.console -disabledfore $COLOR(disabled)]] { $m add command -label "$title Console" -state disabled $m add command -label "New Console" -underline 0 -accel $PRIV(ACC)N \ -command ::tkcon::New $m add command -label "New Tab" -underline 4 -accel $PRIV(ACC)T \ -command ::tkcon::NewTab $m add command -label "Delete Tab" -underline 0 \ -command ::tkcon::DeleteTab -state disabled $m add command -label "Close Console" -underline 0 -accel $PRIV(ACC)w \ -command ::tkcon::Destroy $m add command -label "Clear Console" -underline 1 -accel Ctrl-l \ -command { clear; ::tkcon::Prompt } if {[tk windowingsystem] eq "x11"} { $m add separator $m add command -label "Make Xauth Secure" -und 5 \ -command ::tkcon::XauthSecure } $m add separator $m add cascade -label "Attach To ..." -underline 0 -menu $m.attach ## Attach Console Menu ## set sub [menu $m.attach -disabledforeground $COLOR(disabled)] $sub add cascade -label "Interpreter" -underline 0 -menu $sub.apps $sub add cascade -label "Namespace" -underline 0 -menu $sub.name ## Attach Console Menu ## menu $sub.apps -disabledforeground $COLOR(disabled) \ -postcommand [list ::tkcon::AttachMenu $sub.apps] ## Attach Namespace Menu ## menu $sub.name -disabledforeground $COLOR(disabled) \ -postcommand [list ::tkcon::NamespaceMenu $sub.name] ## Attach Socket Menu ## $sub add cascade -label "Socket" -underline 0 -menu $sub.sock menu $sub.sock -disabledforeground $COLOR(disabled) \ -postcommand [list ::tkcon::SocketMenu $sub.sock] if {[tk windowingsystem] eq "x11"} { ## Attach Display Menu ## $sub add cascade -label "Display" -underline 0 -menu $sub.disp menu $sub.disp -disabledforeground $COLOR(disabled) \ -postcommand [list ::tkcon::DisplayMenu $sub.disp] } } ## Edit Menu ## set text $PRIV(console) foreach m [list [menu $w.edit] [menu $w.pop.edit]] { $m add command -label "Cut" -underline 2 -accel $PRIV(ACC)x \ -command [list ::tkcon::Cut $text] $m add command -label "Copy" -underline 0 -accel $PRIV(ACC)c \ -command [list ::tkcon::Copy $text] $m add command -label "Paste" -underline 0 -accel $PRIV(ACC)v \ -command [list ::tkcon::Paste $text] $m add separator $m add command -label "Find" -underline 0 -accel $PRIV(ACC)F \ -command [list ::tkcon::FindBox $text] } ## Interp Menu ## foreach m [list $w.interp $w.pop.interp] { menu $m -disabledforeground $COLOR(disabled) \ -postcommand [list ::tkcon::InterpMenu $m] } ## Prefs Menu ## foreach m [list [menu $w.prefs] [menu $w.pop.prefs]] { $m add check -label "Brace Highlighting" \ -underline 0 -variable ::tkcon::OPT(lightbrace) $m add check -label "Command Highlighting" \ -underline 0 -variable ::tkcon::OPT(lightcmd) $m add check -label "History Substitution" \ -underline 0 -variable ::tkcon::OPT(subhistory) $m add check -label "Hot Errors" \ -underline 4 -variable ::tkcon::OPT(hoterrors) $m add check -label "Non-Tcl Attachments" \ -underline 0 -variable ::tkcon::OPT(nontcl) $m add check -label "Calculator Mode" \ -underline 1 -variable ::tkcon::OPT(calcmode) $m add check -label "Show Multiple Matches" \ -underline 0 -variable ::tkcon::OPT(showmultiple) if {!$PRIV(AQUA)} { $m add check -label "Show Menubar" \ -underline 5 -variable ::tkcon::OPT(showmenu) \ -command { $::tkcon::PRIV(root) configure \ -menu [expr {$::tkcon::OPT(showmenu) ? $::tkcon::PRIV(menubar) : {}}] } } $m add check -label "Show Statusbar" \ -underline 5 -variable ::tkcon::OPT(showstatusbar) \ -command { if {$::tkcon::OPT(showstatusbar)} { grid $::tkcon::PRIV(statusbar) } else { grid remove $::tkcon::PRIV(statusbar) } } $m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll ## Scrollbar Menu ## set m [menu $m.scroll] $m add radio -label "Left" -value left \ -variable ::tkcon::OPT(scrollypos) \ -command { grid configure $::tkcon::PRIV(scrolly) -column 0 } $m add radio -label "Right" -value right \ -variable ::tkcon::OPT(scrollypos) \ -command { grid configure $::tkcon::PRIV(scrolly) -column 2 } } ## History Menu ## foreach m [list $w.history $w.pop.history] { menu $m -disabledforeground $COLOR(disabled) \ -postcommand [list ::tkcon::HistoryMenu $m] } ## Help Menu ## foreach m [list [menu $w.help] [menu $w.pop.help]] { $m add command -label "About " -underline 0 -accel $PRIV(ACC)A \ -command ::tkcon::About $m add command -label "Retrieve Latest Version" -underline 0 \ -command ::tkcon::Retrieve if {![catch {package require ActiveTcl} ver]} { set cmd "" if {$tcl_platform(platform) == "windows"} { package require registry set ver [join [lrange [split $ver .] 0 3] .] set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl} if {![catch {registry get "$key\\$ver\\Help" ""} help] && [file exists $help]} { set cmd [list exec $::env(COMSPEC) /c start {} $help] } } elseif {$tcl_platform(os) == "Darwin"} { set ver ActiveTcl-[join [lrange [split $ver .] 0 1] .] set rsc "/Library/Frameworks/Tcl.framework/Resources" set help "$rsc/English.lproj/$ver/index.html" if {[file exists $help]} { set cmd [list exec open $help] } } elseif {$tcl_platform(platform) == "unix"} { set help [file dirname [info nameofexe]] append help /../html/index.html if {[file exists $help]} { set cmd [list puts "Start $help"] } } if {$cmd != ""} { $m add separator $m add command -label "ActiveTcl Help" -underline 10 \ -command $cmd } } } } ## ::tkcon::HistoryMenu - dynamically build the menu for attached interpreters ## # ARGS: m - menu widget ## proc ::tkcon::HistoryMenu m { variable PRIV if {![winfo exists $m]} return set id [EvalSlave history nextid] if {$PRIV(histid)==$id} return set PRIV(histid) $id $m delete 0 end while {($id>1) && ($id>$PRIV(histid)-10) && \ ![catch {EvalSlave history event [incr id -1]} tmp]} { set lbl $tmp if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... } $m add command -label "$id: $lbl" -command " $::tkcon::PRIV(console) delete limit end $::tkcon::PRIV(console) insert limit [list $tmp] $::tkcon::PRIV(console) see end ::tkcon::Eval $::tkcon::PRIV(console)" } } ## ::tkcon::InterpMenu - dynamically build the menu for attached interpreters ## # ARGS: w - menu widget ## proc ::tkcon::InterpMenu w { variable OPT variable PRIV variable COLOR if {![winfo exists $w]} return $w delete 0 end foreach {app type} [Attach] break $w add command -label "[string toupper $type]: $app" -state disabled if {($OPT(nontcl) && $type eq "interp") || $PRIV(deadapp)} { $w add separator $w add command -state disabled -label "Communication disabled to" $w add command -state disabled -label "dead or non-Tcl interps" return } ## Show Last Error ## $w add separator $w add command -label "Show Last Error" \ -command [list tkcon error $app $type] ## Packages Cascaded Menu ## $w add separator $w add command -label "Manage Packages" -underline 0 \ -command [list ::tkcon::InterpPkgs $app $type] ## State Checkpoint/Revert ## $w add separator $w add command -label "Checkpoint State" \ -command [list ::tkcon::StateCheckpoint $app $type] $w add command -label "Revert State" \ -command [list ::tkcon::StateRevert $app $type] $w add command -label "View State Change" \ -command [list ::tkcon::StateCompare $app $type] ## Init Interp ## $w add separator $w add command -label "Send tkcon Commands" \ -command [list ::tkcon::InitInterp $app $type] } ## ::tkcon::PkgMenu - fill in in the applications sub-menu ## with a list of all the applications that currently exist. ## proc ::tkcon::InterpPkgs {app type} { variable PRIV set t $PRIV(base).interppkgs if {![winfo exists $t]} { toplevel $t wm withdraw $t wm title $t "$app Packages" wm transient $t $PRIV(root) wm group $t $PRIV(root) catch {wm attributes $t -type dialog} bind $t <Escape> [list destroy $t] label $t.ll -text "Loadable:" -anchor w label $t.lr -text "Loaded:" -anchor w listbox $t.loadable -font tkconfixed -background white -borderwidth 1 \ -yscrollcommand [list $t.llsy set] -selectmode extended listbox $t.loaded -font tkconfixed -background white -borderwidth 1 \ -yscrollcommand [list $t.lrsy set] scrollbar $t.llsy -command [list $t.loadable yview] scrollbar $t.lrsy -command [list $t.loaded yview] button $t.load -borderwidth 1 -text ">>" \ -command [list ::tkcon::InterpPkgLoad $app $type $t.loadable] if {$::tcl_version >= 8.4} { $t.load configure -relief flat -overrelief raised } set f [frame $t.btns] button $f.refresh -width 8 -text "Refresh" -command [info level 0] button $f.dismiss -width 8 -text "Dismiss" -command [list destroy $t] grid $f.refresh $f.dismiss -padx 4 -pady 3 -sticky ew if {$PRIV(AQUA)} { # corner resize control space grid columnconfigure $f [lindex [grid size $f] 0] -minsize 16 } grid $t.ll x x $t.lr x -sticky ew grid $t.loadable $t.llsy $t.load $t.loaded $t.lrsy -sticky news grid $t.btns -sticky e -columnspan 5 grid columnconfigure $t {0 3} -weight 1 grid rowconfigure $t 1 -weight 1 grid configure $t.load -sticky "" bind $t.loadable <Double-1> "[list $t.load invoke]; break" } $t.loaded delete 0 end $t.loadable delete 0 end # just in case stuff has been added to the auto_path # we have to make sure that the errorInfo doesn't get screwed up EvalAttached { set __tkcon_error $errorInfo catch {package require bogus-package-name} set errorInfo ${__tkcon_error} unset __tkcon_error } # get all packages loaded into current interp foreach pkg [EvalAttached [list info loaded {}]] { set pkg [lindex $pkg 1] set loaded($pkg) [package provide $pkg] } # get all package names currently visible foreach pkg [lremove [EvalAttached {package names}] Tcl] { set version [EvalAttached [list package provide $pkg]] if {$version ne ""} { set loaded($pkg) $version } elseif {![info exists loaded($pkg)]} { set loadable($pkg) package } } # get packages that are loaded in any interp foreach pkg [EvalAttached {info loaded}] { set pkg [lindex $pkg 1] if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} { set loadable($pkg) load } } foreach pkg [lsort -dictionary [array names loadable]] { foreach v [EvalAttached [list package version $pkg]] { $t.loadable insert end [list $pkg $v "($loadable($pkg))"] } } foreach pkg [lsort -dictionary [array names loaded]] { $t.loaded insert end [list $pkg $loaded($pkg)] } wm deiconify $t raise $t } proc ::tkcon::InterpPkgLoad {app type lb} { # load the lb entry items into the interp foreach sel [$lb curselection] { foreach {pkg ver method} [$lb get $sel] { break } if {$method == "(package)"} { set code [catch {::tkcon::EvalOther $app $type \ package require $pkg $ver} msg] } elseif {$method == "(load)"} { set code [catch {::tkcon::EvalOther $app $type load {} $pkg} msg] } else { set code 1 set msg "Incorrect entry in Loadable selection" } if {$code} { tk_messageBox -icon error -title "Error requiring $pkg" -type ok \ -message "Error requiring $pkg $ver:\n$msg\n$::errorInfo" } } # refresh package list InterpPkgs $app $type } ## ::tkcon::AttachMenu - fill in in the applications sub-menu ## with a list of all the applications that currently exist. ## proc ::tkcon::AttachMenu m { variable OPT variable PRIV array set interps [set tmp [Interps]] foreach {i j} $tmp { set tknames($j) {} } $m delete 0 end set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} $m add radio -label {None (use local slave) } -accel $PRIV(ACC)1 \ -variable ::tkcon::PRIV(app) \ -value [concat $::tkcon::PRIV(name) $::tkcon::OPT(exec)] \ -command "::tkcon::Attach {}; $cmd" $m add separator $m add command -label "Foreign Tk Interpreters" -state disabled foreach i [lsort [lremove [::send::interps] [array names tknames]]] { $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \ -command "::tkcon::Attach [list $i] interp; $cmd" } $m add separator $m add command -label "tkcon Interpreters" -state disabled foreach i [lsort [array names interps]] { if {$interps($i) eq ""} { set interps($i) "no Tk" } if {[regexp {^Slave[0-9]+} $i]} { set opts [list -label "$i ($interps($i))" \ -variable ::tkcon::PRIV(app) -value $i \ -command "::tkcon::Attach [list $i] slave; $cmd"] if {$PRIV(name) eq $i} { append opts " -accel $PRIV(ACC)2" } eval [list $m add radio] $opts } else { set name [concat Main $i] if {$name eq "Main"} { $m add radio -label "$name ($interps($i))" -accel $PRIV(ACC)3 \ -variable ::tkcon::PRIV(app) -value Main \ -command "::tkcon::Attach [list $name] slave; $cmd" } else { $m add radio -label "$name ($interps($i))" \ -variable ::tkcon::PRIV(app) -value $i \ -command "::tkcon::Attach [list $name] slave; $cmd" } } } } ## Displays Cascaded Menu ## proc ::tkcon::DisplayMenu m { $m delete 0 end set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} $m add command -label "New Display" -command ::tkcon::NewDisplay foreach disp [Display] { $m add separator $m add command -label $disp -state disabled set res [Display $disp] set win [lindex $res 0] foreach i [lsort [lindex $res 1]] { $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \ -command "::tkcon::Attach [list $i] [list dpy:$win]; $cmd" } } } ## Sockets Cascaded Menu ## proc ::tkcon::SocketMenu m { $m delete 0 end set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} $m add command -label "Create Connection" \ -command "::tkcon::NewSocket; $cmd" foreach sock [file channels sock*] { $m add radio -label $sock -variable ::tkcon::PRIV(app) -value $sock \ -command "::tkcon::Attach $sock socket; $cmd" } } ## Namepaces Cascaded Menu ## proc ::tkcon::NamespaceMenu m { variable PRIV variable OPT $m delete 0 end if {($PRIV(deadapp) || $PRIV(apptype) eq "socket" || \ ($OPT(nontcl) && $PRIV(apptype) eq "interp"))} { $m add command -label "No Namespaces" -state disabled return } ## Same command as for ::tkcon::AttachMenu items set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} set names [lsort [Namespaces ::]] if {[llength $names] > $OPT(maxmenu)} { $m add command -label "Attached to $PRIV(namesp)" -state disabled $m add command -label "List Namespaces" \ -command [list ::tkcon::NamespacesList $names] } else { foreach i $names { if {$i eq "::"} { $m add radio -label "Main" -value $i \ -variable ::tkcon::PRIV(namesp) \ -command "::tkcon::AttachNamespace [list $i]; $cmd" } else { $m add radio -label $i -value $i \ -variable ::tkcon::PRIV(namesp) \ -command "::tkcon::AttachNamespace [list $i]; $cmd" } } } } ## Namepaces List ## proc ::tkcon::NamespacesList {names} { variable PRIV set f $PRIV(base).namespaces catch {destroy $f} toplevel $f catch {wm attributes $f -type dialog} listbox $f.names -width 30 -height 15 -selectmode single \ -yscrollcommand [list $f.scrollv set] \ -xscrollcommand [list $f.scrollh set] \ -background white -borderwidth 1 scrollbar $f.scrollv -command [list $f.names yview] scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal frame $f.buttons button $f.cancel -text "Cancel" -command [list destroy $f] grid $f.names $f.scrollv -sticky nesw grid $f.scrollh -sticky ew grid $f.buttons -sticky nesw grid $f.cancel -in $f.buttons -pady 6 grid columnconfigure $f 0 -weight 1 grid rowconfigure $f 0 -weight 1 #fill the listbox foreach i $names { if {$i eq "::"} { $f.names insert 0 Main } else { $f.names insert end $i } } #Bindings bind $f.names <Double-1> { ## Catch in case the namespace disappeared on us catch { ::tkcon::AttachNamespace [%W get [%W nearest %y]] } ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] destroy [winfo toplevel %W] } } # ::tkcon::XauthSecure -- # # This removes all the names in the xhost list, and secures # the display for Tk send commands. Of course, this prevents # what might have been otherwise allowable X connections # # Arguments: # none # Results: # Returns nothing # proc ::tkcon::XauthSecure {} { global tcl_platform if {[tk windowingsystem] ne "x11"} { # This makes no sense outside of Unix return } set hosts [exec xhost] # the first line is info only foreach host [lrange [split $hosts \n] 1 end] { exec xhost -$host } exec xhost - tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info } ## ::tkcon::FindBox - creates minimal dialog interface to ::tkcon::Find # ARGS: w - text widget # str - optional seed string for ::tkcon::PRIV(find) ## proc ::tkcon::FindBox {w {str {}}} { variable PRIV set base $PRIV(base).find if {![winfo exists $base]} { toplevel $base wm withdraw $base catch {wm attributes $base -type dialog} wm title $base "tkcon Find" wm resizable $base 1 0 label $base.l -text "Find:" -anchor e entry $base.e -textvariable ::tkcon::PRIV(find) checkbutton $base.case -text "Case Sensitive" \ -variable ::tkcon::PRIV(find,case) checkbutton $base.re -text "Use Regexp" \ -variable ::tkcon::PRIV(find,reg) frame $base.sep -borderwidth 1 -relief sunken -height 2 frame $base.btn grid $base.l $base.e - - -sticky ew grid $base.case - $base.re -sticky ew grid $base.sep -columnspan 4 -sticky ew grid $base.btn -columnspan 4 -sticky ew grid columnconfigure $base 3 -weight 1 button $base.btn.fnd -text "Find" -width 6 button $base.btn.clr -text "Clear" -width 6 button $base.btn.dis -text "Dismiss" -width 6 eval grid [winfo children $base.btn] -padx 4 -pady 2 -sticky ew if {$PRIV(AQUA)} { # corner resize control space grid columnconfigure $base.btn \ [lindex [grid size $base.btn] 0] -minsize 16 } focus $base.e bind $base.e <Return> [list $base.btn.fnd invoke] bind $base.e <Escape> [list $base.btn.dis invoke] } $base.btn.fnd config -command "::tkcon::Find [list $w] \$::tkcon::PRIV(find) \ -case \$::tkcon::PRIV(find,case) -reg \$::tkcon::PRIV(find,reg)" $base.btn.clr config -command " [list $w] tag remove find 1.0 end set ::tkcon::PRIV(find) {} " $base.btn.dis config -command " [list $w] tag remove find 1.0 end wm withdraw [list $base] " if {$str ne ""} { set PRIV(find) $str $base.btn.fnd invoke } if {[wm state $base] ne "normal"} { wm deiconify $base } else { raise $base } $base.e select range 0 end } ## ::tkcon::Find - searches in text widget $w for $str and highlights it ## If $str is empty, it just deletes any highlighting # ARGS: w - text widget # str - string to search for # -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 # -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 ## proc ::tkcon::Find {w str args} { $w tag remove find 1.0 end set truth {^(1|yes|true|on)$} set opts {} foreach {key val} $args { switch -glob -- $key { -c* { if {[regexp -nocase $truth $val]} { set case 1 } } -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } } default { return -code error "Unknown option $key" } } } if {![info exists case]} { lappend opts -nocase } if {$str eq ""} { return } $w mark set findmark 1.0 while {[set ix [eval $w search $opts -count numc -- \ [list $str] findmark end]] ne ""} { $w tag add find $ix ${ix}+${numc}c $w mark set findmark ${ix}+1c } $w tag configure find -background $::tkcon::COLOR(blink) catch {$w see find.first} return [expr {[llength [$w tag ranges find]]/2}] } ## ::tkcon::Attach - called to attach tkcon to an interpreter # ARGS: name - application name to which tkcon sends commands # This is either a slave interperter name or tk appname. # type - (slave|interp) type of interpreter we're attaching to # slave means it's a tkcon interpreter # interp means we'll need to 'send' to it. # Results: ::tkcon::EvalAttached is recreated to evaluate in the # appropriate interpreter ## proc ::tkcon::Attach {{name <NONE>} {type slave} {ns {}}} { variable PRIV variable OPT variable ATTACH if {[llength [info level 0]] == 1} { # no args were specified, return the attach info instead return [AttachId] } set path [concat $PRIV(name) $OPT(exec)] set PRIV(displayWin) . if {$type eq "namespace"} { return [uplevel 1 ::tkcon::AttachNamespace $name] } elseif {[string match dpy:* $type]} { set PRIV(displayWin) [string range $type 4 end] } elseif {[string match sock* $type]} { global tcl_version if {[catch {eof $name} res]} { return -code error "No known channel \"$name\"" } elseif {$res} { catch {close $name} return -code error "Channel \"$name\" returned EOF" } set app $name set type socket } elseif {$name ne ""} { array set interps [Interps] if {[string match {[Mm]ain} [lindex $name 0]]} { set name [lrange $name 1 end] } if {$name eq $path} { set name {} set app $path set type slave } elseif {[info exists interps($name)]} { if {$name eq ""} { set name Main; set app Main } set type slave } elseif {[interp exists $name]} { set name [concat $PRIV(name) $name] set type slave } elseif {[interp exists [concat $OPT(exec) $name]]} { set name [concat $path $name] set type slave } elseif {[lsearch -exact [::send::interps] $name] > -1} { if {[EvalSlave info exists tk_library] && $name eq [EvalSlave tk appname]} { set name {} set app $path set type slave } elseif {[set i [lsearch -exact \ [Main set ::tkcon::PRIV(interps)] $name]] != -1} { set name [lindex [Main set ::tkcon::PRIV(slaves)] $i] if {[string match {[Mm]ain} $name]} { set app Main } set type slave } else { set type interp } } else { return -code error "No known interpreter \"$name\"" } } else { set app $path } if {![info exists app]} { set app $name } array set PRIV [list app $app appname $name apptype $type deadapp 0] ## ::tkcon::EvalAttached - evaluates the args in the attached interp ## args should be passed to this procedure as if they were being ## passed to the 'eval' procedure. This procedure is dynamic to ## ensure evaluation occurs in the right interp. # ARGS: args - the command and args to evaluate ## set PRIV(namesp) :: set namespOK 0 switch -glob -- $type { slave { if {$name eq ""} { interp alias {} ::tkcon::EvalAttached {} \ ::tkcon::EvalSlave uplevel \#0 } elseif {$PRIV(app) eq "Main"} { interp alias {} ::tkcon::EvalAttached {} ::tkcon::Main } elseif {$PRIV(name) eq $PRIV(app)} { interp alias {} ::tkcon::EvalAttached {} uplevel \#0 } else { interp alias {} ::tkcon::EvalAttached {} \ ::tkcon::Slave $::tkcon::PRIV(app) } set namespOK 1 } sock* { interp alias {} ::tkcon::EvalAttached {} \ ::tkcon::EvalSlave uplevel \#0 # The file event will just puts whatever data is found # into the interpreter fconfigure $name -buffering line -blocking 0 fileevent $name readable [list ::tkcon::EvalSocketEvent $name] } dpy:* - interp { if {$OPT(nontcl)} { interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave } else { interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend set namespOK 1 } } default { return -code error "[lindex [info level 0] 0] did not specify\ a valid type: must be slave or interp" } } if {$ns ne "" && $namespOK} { AttachNamespace $ns } return [AttachId] } proc ::tkcon::AttachId {} { # return Attach info in a form that Attach accepts again variable PRIV if {$PRIV(appname) eq ""} { variable OPT set appname [concat $PRIV(name) $OPT(exec)] } else { set appname $PRIV(appname) } set id [list $appname $PRIV(apptype)] # only display ns info if it isn't "::" as that is what is also # used to indicate no eval in namespace if {$PRIV(namesp) ne "::"} { lappend id $PRIV(namesp) } if {[info exists PRIV(console)]} { variable ATTACH set ATTACH($PRIV(console)) $id } return $id } ## ::tkcon::AttachNamespace - called to attach tkcon to a namespace # ARGS: name - namespace name in which tkcon should eval commands # Results: ::tkcon::EvalAttached will be modified ## proc ::tkcon::AttachNamespace { name } { variable PRIV variable OPT # We could enable 'socket' bound Tcl interps, but we'd have to create # a return listening socket if {($OPT(nontcl) && $PRIV(apptype) eq "interp") || $PRIV(apptype) eq "socket" || $PRIV(deadapp)} { return -code error "can't attach to namespace in attached environment" } if {$name eq "Main"} {set name ::} if {$name ne "" && [lsearch [Namespaces ::] $name] == -1} { return -code error "No known namespace \"$name\"" } if {[regexp {^(|::)$} $name]} { ## If name=={} || ::, we want the primary namespace set alias [interp alias {} ::tkcon::EvalAttached] if {[string match ::tkcon::EvalNamespace* $alias]} { eval [list interp alias {} ::tkcon::EvalAttached {}] \ [lindex $alias 1] } set name :: } else { interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalNamespace \ [interp alias {} ::tkcon::EvalAttached] [list $name] } set PRIV(namesp) $name return [AttachId] } ## ::tkcon::NewSocket - called to create a socket to connect to # ARGS: none # Results: It will create a socket, and attach if requested ## proc ::tkcon::NewSocket {} { variable PRIV set t $PRIV(base).newsock if {![winfo exists $t]} { toplevel $t wm withdraw $t catch {wm attributes $t -type dialog} wm title $t "tkcon Create Socket" wm resizable $t 1 0 label $t.lhost -text "Host: " entry $t.host -width 16 -takefocus 1 label $t.lport -text "Port: " entry $t.port -width 4 -takefocus 1 button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} -width 4 \ -takefocus 1 bind $t.host <Return> [list focus $t.port] bind $t.port <Return> [list focus $t.ok] bind $t.ok <Return> [list $t.ok invoke] grid $t.lhost $t.host $t.lport $t.port $t.ok -sticky ew grid configure $t.ok -padx 4 -pady 2 grid columnconfig $t 1 -weight 1 grid rowconfigure $t 1 -weight 1 if {$PRIV(AQUA)} { # corner resize control space grid columnconfigure $t [lindex [grid size $t] 0] -minsize 16 } wm transient $t $PRIV(root) wm group $t $PRIV(root) wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ reqwidth $t]) / 2}]+[expr {([winfo \ screenheight $t]-[winfo reqheight $t]) / 2}] bind $t <Escape> [list destroy $t] } #$t.host delete 0 end #$t.port delete 0 end wm deiconify $t raise $t grab $t focus $t.host vwait ::tkcon::PRIV(grab) grab release $t wm withdraw $t set host [$t.host get] set port [$t.port get] if {$host == ""} { return } if {[catch { set sock [socket $host $port] } err]} { tk_messageBox -title "Socket Connection Error" \ -message "Unable to connect to \"$host:$port\":\n$err" \ -icon error -type ok } else { Attach $sock socket } } ## ::tkcon::Load - sources a file into the console ## The file is actually sourced in the currently attached's interp # ARGS: fn - (optional) filename to source in # Returns: selected filename ({} if nothing was selected) ## proc ::tkcon::Load { {fn ""} } { set types { {{Tcl Files} {.tcl .tk}} {{Text Files} {.txt}} {{All Files} *} } # Allow for VFS directories, use Tk dialogs automatically when in # VFS-based areas set check [expr {$fn == "" ? [pwd] : $fn}] if {$::tcl_version >= 8.4 && [lindex [file system $check] 0] == "tclvfs"} { set opencmd [list ::tk::dialog::file:: open] } else { set opencmd [list tk_getOpenFile] } if {$fn eq "" && ([catch {tk_getOpenFile -filetypes $types \ -title "Source File"} fn] || $fn eq "") } { return } EvalAttached [list source $fn] } ## ::tkcon::Save - saves the console or other widget buffer to a file ## This does not eval in a slave because it's not necessary # ARGS: w - console text widget # fn - (optional) filename to save to ## proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } { variable PRIV if {![regexp -nocase {^(all|history|stdin|stdout|stderr|widget)$} $type]} { array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel } ## Allow user to specify what kind of stuff to save set type [tk_dialog $PRIV(base).savetype "Save Type" \ "What part of the text do you want to save?" \ questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)] if {$type == 5 || $type == -1} return set type $s($type) } # Allow for VFS directories, use Tk dialogs automatically when in # VFS-based areas set check [expr {$opt == "" ? [pwd] : $opt}] if {$::tcl_version >= 8.4 && [lindex [file system $check] 0] == "tclvfs"} { set savecmd [list ::tk::dialog::file:: save] } else { set savecmd [list tk_getSaveFile] } if {$fn eq ""} { set types { {{Tcl Files} {.tcl .tk}} {{Text Files} {.txt}} {{All Files} *} } if {[catch {eval $savecmd [list -defaultextension .tcl \ -filetypes $types \ -title "Save $type"]} fn] || $fn eq ""} return } set type [string tolower $type] switch $type { stdin - stdout - stderr { set data {} foreach {first last} [$PRIV(console) tag ranges $type] { lappend data [$PRIV(console) get $first $last] } set data [join $data \n] } history { set data [tkcon history] } all - default { set data [$PRIV(console) get 1.0 end-1c] } widget { set data [$opt get 1.0 end-1c] } } if {[catch {open $fn $mode} fid]} { return -code error "Save Error: Unable to open '$fn' for writing\n$fid" } puts -nonewline $fid $data close $fid } ## ::tkcon::MainInit ## This is only called for the main interpreter to include certain procs ## that we don't want to include (or rather, just alias) in slave interps. ## proc ::tkcon::MainInit {} { variable PRIV variable OPT if {![info exists PRIV(slaves)]} { array set PRIV [list slave 0 slaves Main name {} \ interps [list [tk appname]]] } interp alias {} ::tkcon::Main {} ::tkcon::InterpEval Main interp alias {} ::tkcon::Slave {} ::tkcon::InterpEval proc ::tkcon::GetSlave {{slave {}}} { set i 0 while {[Slave $slave [list interp exists Slave[incr i]]]} { # oh my god, an empty loop! } set interp [Slave $slave [list interp create Slave$i]] return $interp } ## ::tkcon::New - create new console window ## Creates a slave interpreter and sources in this script. ## All other interpreters also get a command to eval function in the ## new interpreter. ## proc ::tkcon::New {} { variable PRIV global argv0 argc argv set tmp [GetSlave] lappend PRIV(slaves) $tmp load {} Tk $tmp # If we have tbcload, then that should be autoloaded into slaves. set idx [lsearch [info loaded] "* Tbcload"] if {$idx != -1} { catch {load {} Tbcload $tmp} } lappend PRIV(interps) [$tmp eval [list tk appname \ "[tk appname] $tmp"]] if {[info exists argv0]} {$tmp eval [list set argv0 $argv0]} if {[info exists argc]} {$tmp eval [list set argc $argc]} if {[info exists argv]} {$tmp eval [list set argv $argv]} $tmp eval [list namespace eval ::tkcon {}] $tmp eval [list set ::tkcon::PRIV(name) $tmp] $tmp eval [list set ::tkcon::PRIV(SCRIPT) $::tkcon::PRIV(SCRIPT)] $tmp alias exit ::tkcon::Exit $tmp $tmp alias ::tkcon::Destroy ::tkcon::Destroy $tmp $tmp alias ::tkcon::New ::tkcon::New $tmp alias ::tkcon::GetSlave ::tkcon::GetSlave $tmp $tmp alias ::tkcon::Main ::tkcon::InterpEval Main $tmp alias ::tkcon::Slave ::tkcon::InterpEval $tmp alias ::tkcon::Interps ::tkcon::Interps $tmp alias ::tkcon::NewDisplay ::tkcon::NewDisplay $tmp alias ::tkcon::Display ::tkcon::Display $tmp alias ::tkcon::StateCheckpoint ::tkcon::StateCheckpoint $tmp alias ::tkcon::StateCleanup ::tkcon::StateCleanup $tmp alias ::tkcon::StateCompare ::tkcon::StateCompare $tmp alias ::tkcon::StateRevert ::tkcon::StateRevert $tmp eval { if [catch {source -rsrc tkcon}] { source $::tkcon::PRIV(SCRIPT) } } return $tmp } ## ::tkcon::Exit - full exit OR destroy slave console ## This proc should only be called in the main interpreter from a slave. ## The master determines whether we do a full exit or just kill the slave. ## proc ::tkcon::Exit {slave args} { variable PRIV variable OPT ## Slave interpreter exit request if {$OPT(slaveexit) eq "exit" || [llength $PRIV(interps)] == 1} { ## Only exit if it specifically is stated to do so, or this ## is the last interp uplevel 1 exit $args } else { ## Otherwise we will delete the slave interp and associated data Destroy $slave } } ## ::tkcon::Destroy - destroy console window ## This proc should only be called by the main interpreter. If it is ## called from there, it will ask before exiting tkcon. All others ## (slaves) will just have their slave interpreter deleted, closing them. ## proc ::tkcon::Destroy {{slave {}}} { variable PRIV # Just close on the last one if {[llength $PRIV(interps)] == 1} { exit } if {"" == $slave} { ## Main interpreter close request if {[tk_messageBox -parent $PRIV(root) -title "Quit tkcon?" \ -message "Close all windows and exit tkcon?" \ -icon question -type yesno] == "yes"} { exit } return } elseif {$slave == $::tkcon::OPT(exec)} { set name [tk appname] set slave "Main" } else { ## Slave interpreter close request set name [InterpEval $slave] interp delete $slave } set PRIV(interps) [lremove $PRIV(interps) [list $name]] set PRIV(slaves) [lremove $PRIV(slaves) [list $slave]] StateCleanup $slave } if {$OPT(overrideexit)} { ## We want to do a couple things before exiting... if {[catch {rename ::exit ::tkcon::FinalExit} err]} { puts stderr "tkcon might panic:\n$err" } proc ::exit args { if {$::tkcon::OPT(usehistory)} { if {[catch {::tkcon::SaveHistory} msg]} { puts stderr "unable to save history file:\n$msg" # pause a moment, because we are about to die finally... after 1000 } } uplevel 1 ::tkcon::FinalExit $args } } ## ::tkcon::SaveHistory - saves history to history file ## If the history file is not writable it raises an error proc ::tkcon::SaveHistory {} { if {$::tkcon::OPT(usehistory)} { if {[catch {open $::tkcon::PRIV(histfile) w} fid]} { error $fid } else { set max [::tkcon::EvalSlave history nextid] set id [expr {$max - $::tkcon::OPT(history)}] if {$id < 1} { set id 1 } ## FIX: This puts history in backwards!! while {($id < $max) && ![catch \ {::tkcon::EvalSlave history event $id} cmd]} { if {$cmd ne ""} { puts $fid "::tkcon::EvalSlave\ history add [list $cmd]" } incr id } close $fid } } } ## ::tkcon::InterpEval - passes evaluation to another named interpreter ## If the interpreter is named, but no args are given, it returns the ## [tk appname] of that interps master (not the associated eval slave). ## proc ::tkcon::InterpEval {{slave {}} args} { variable PRIV if {[llength [info level 0]] == 1} { # no args given return $PRIV(slaves) } elseif {[string match {[Mm]ain} $slave]} { set slave {} } if {[llength $args]} { return [interp eval $slave uplevel \#0 $args] } else { # beware safe interps with Tk if {[interp eval $slave {llength [info commands tk]}]} { if {[catch {interp eval $slave tk appname} name]} { return "safetk" } return $name } } } proc ::tkcon::Interps {{ls {}} {interp {}}} { if {$interp eq ""} { lappend ls {} [tk appname] } foreach i [interp slaves $interp] { if {$interp ne ""} { set i "$interp $i" } if {[interp eval $i package provide Tk] ne ""} { # beware safe interps with Tk if {[catch {interp eval $i tk appname} name]} { set name {} } lappend ls $i $name } else { lappend ls $i {} } set ls [Interps $ls $i] } return $ls } proc ::tkcon::Display {{disp {}}} { variable DISP set res {} if {$disp != ""} { if {![info exists DISP($disp)]} { return } return [list $DISP($disp) [winfo interps -displayof $DISP($disp)]] } return [lsort -dictionary [array names DISP]] } proc ::tkcon::NewDisplay {} { variable PRIV variable DISP set t $PRIV(base).newdisp if {![winfo exists $t]} { toplevel $t wm withdraw $t catch {wm attributes $t -type dialog} wm title $t "tkcon Attach to Display" label $t.gets -text "New Display: " entry $t.data -width 32 button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} bind $t.data <Return> [list $t.ok invoke] bind $t.ok <Return> [list $t.ok invoke] grid $t.gets $t.data -sticky ew grid $t.ok - -sticky ew grid columnconfig $t 1 -weight 1 grid rowconfigure $t 1 -weight 1 wm transient $t $PRIV(root) wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ reqwidth $t]) / 2}]+[expr {([winfo \ screenheight $t]-[winfo reqheight $t]) / 2}] } $t.data delete 0 end wm deiconify $t raise $t grab $t focus $t.data vwait ::tkcon::PRIV(grab) grab release $t wm withdraw $t set disp [$t.data get] if {$disp == ""} { return } regsub -all {\.} [string tolower $disp] ! dt set dt $PRIV(base).$dt destroy $dt if {[catch { toplevel $dt -screen $disp set interps [winfo interps -displayof $dt] if {![llength $interps]} { error "No other Tk interpreters on $disp" } ::send::send -displayof $dt [lindex $interps 0] [list info tclversion] } err]} { global env if {[info exists env(DISPLAY)]} { set myd $env(DISPLAY) } else { set myd "myDisplay:0" } tk_messageBox -title "Display Connection Error" \ -message "Unable to connect to \"$disp\":\n$err\ \nMake sure you have xauth-based permissions\ (xauth add $myd . `mcookie`), and xhost is disabled\ (xhost -) on \"$disp\"" \ -icon error -type ok destroy $dt return } set DISP($disp) $dt wm withdraw $dt bind $dt <Destroy> [subst {catch {unset ::tkcon::DISP($disp)}}] tk_messageBox -title "$disp Connection" \ -message "Connected to \"$disp\", found:\n[join $interps \n]" \ -type ok } ## ## The following state checkpoint/revert procedures are very sketchy ## and prone to problems. They do not track modifications to currently ## existing procedures/variables, and they can really screw things up ## if you load in libraries (especially Tk) between checkpoint and ## revert. Only with this knowledge in mind should you use these. ## ## ::tkcon::StateCheckpoint - checkpoints the current state of the system ## This allows you to return to this state with ::tkcon::StateRevert # ARGS: ## proc ::tkcon::StateCheckpoint {app type} { variable CPS variable PRIV if {[info exists CPS($type,$app,cmd)] && \ [tk_dialog $PRIV(base).warning "Overwrite Previous State?" \ "Are you sure you want to lose previously checkpointed\ state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return set CPS($type,$app,cmd) [EvalOther $app $type info commands *] set CPS($type,$app,var) [EvalOther $app $type info vars *] return } ## ::tkcon::StateCompare - compare two states and output difference # ARGS: ## proc ::tkcon::StateCompare {app type {verbose 0}} { variable CPS variable PRIV variable OPT variable COLOR if {![info exists CPS($type,$app,cmd)]} { return -code error \ "No previously checkpointed state for $type \"$app\"" } set w $PRIV(base).compare if {[winfo exists $w]} { $w.text config -state normal $w.text delete 1.0 end } else { toplevel $w catch {wm attributes $w -type dialog} frame $w.btn scrollbar $w.sy -command [list $w.text yview] text $w.text -yscrollcommand [list $w.sy set] -height 12 \ -foreground $COLOR(stdin) \ -background $COLOR(bg) \ -insertbackground $COLOR(cursor) \ -font $OPT(font) -borderwidth 1 -highlightthickness 0 $w.text tag config red -foreground red button $w.close -text "Dismiss" -width 8 \ -command [list destroy $w] button $w.check -text "Recheckpoint" -width 11 button $w.revert -text "Revert" -width 8 button $w.expand -text "Verbose" -width 8 button $w.update -text "Update" -width 8 grid $w.text - - - - - $w.sy -sticky news grid x $w.check $w.revert $w.expand $w.update $w.close grid configure $w.close -padx {4 0} grid rowconfigure $w 0 -weight 1 grid columnconfigure $w 0 -weight 1 } wm title $w "Compare State: $type [list $app]" $w.check config \ -command "::tkcon::StateCheckpoint [list $app] $type; \ ::tkcon::StateCompare [list $app] $type $verbose" $w.revert config \ -command "::tkcon::StateRevert [list $app] $type; \ ::tkcon::StateCompare [list $app] $type $verbose" $w.update config -command [info level 0] if {$verbose} { $w.expand config -text Brief \ -command [list ::tkcon::StateCompare $app $type 0] } else { $w.expand config -text Verbose \ -command [list ::tkcon::StateCompare $app $type 1] } ## Don't allow verbose mode unless 'dump' exists in $app ## We're assuming this is tkcon's dump command set hasdump [llength [EvalOther $app $type info commands dump]] if {$hasdump} { $w.expand config -state normal } else { $w.expand config -state disabled } set cmds [lremove [EvalOther $app $type info commands *] \ $CPS($type,$app,cmd)] set vars [lremove [EvalOther $app $type info vars *] \ $CPS($type,$app,var)] if {$hasdump && $verbose} { set cmds [EvalOther $app $type eval dump c -nocomplain $cmds] set vars [EvalOther $app $type eval dump v -nocomplain $vars] } $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \ $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {} raise $w $w.text config -state disabled } ## ::tkcon::StateRevert - reverts interpreter to previous state # ARGS: ## proc ::tkcon::StateRevert {app type} { variable CPS variable PRIV if {![info exists CPS($type,$app,cmd)]} { return -code error \ "No previously checkpointed state for $type \"$app\"" } if {![tk_dialog $PRIV(base).warning "Revert State?" \ "Are you sure you want to revert the state in $type \"$app\"?"\ questhead 1 "Do It" "Cancel"]} { foreach i [lremove [EvalOther $app $type info commands *] \ $CPS($type,$app,cmd)] { catch {EvalOther $app $type rename $i {}} } foreach i [lremove [EvalOther $app $type info vars *] \ $CPS($type,$app,var)] { catch {EvalOther $app $type unset $i} } } } ## ::tkcon::StateCleanup - cleans up state information in master array # ## proc ::tkcon::StateCleanup {args} { variable CPS if {![llength $args]} { foreach state [array names CPS slave,*] { if {![interp exists [string range $state 6 end]]} { unset CPS($state) } } } else { set app [lindex $args 0] set type [lindex $args 1] if {[regexp {^(|slave)$} $type]} { foreach state [array names CPS "slave,$app\[, \]*"] { if {![interp exists [string range $state 6 end]]} { unset CPS($state) } } } else { catch {unset CPS($type,$app)} } } } } ## ::tkcon::Event - get history event, search if string != {} ## look forward (next) if $int>0, otherwise look back (prev) # ARGS: W - console widget ## proc ::tkcon::Event {int {str {}}} { if {!$int} return variable PRIV set w $PRIV(console) set nextid [EvalSlave history nextid] if {$str ne ""} { ## String is not empty, do an event search set event $PRIV(event) if {$int < 0 && $event == $nextid} { set PRIV(cmdbuf) $str } set len [string len $PRIV(cmdbuf)] incr len -1 if {$int > 0} { ## Search history forward while {$event < $nextid} { if {[incr event] == $nextid} { $w delete limit end $w insert limit $PRIV(cmdbuf) break } elseif { ![catch {EvalSlave history event $event} res] && [set p [string first $PRIV(cmdbuf) $res]] > -1 } { set p2 [expr {$p + [string length $PRIV(cmdbuf)]}] $w delete limit end $w insert limit $res Blink $w "limit + $p c" "limit + $p2 c" break } } set PRIV(event) $event } else { ## Search history reverse while {![catch {EvalSlave history event [incr event -1]} res]} { if {[set p [string first $PRIV(cmdbuf) $res]] > -1} { set p2 [expr {$p + [string length $PRIV(cmdbuf)]}] $w delete limit end $w insert limit $res set PRIV(event) $event Blink $w "limit + $p c" "limit + $p2 c" break } } } } else { ## String is empty, just get next/prev event if {$int > 0} { ## Goto next command in history if {$PRIV(event) < $nextid} { $w delete limit end if {[incr PRIV(event)] == $nextid} { $w insert limit $PRIV(cmdbuf) } else { $w insert limit [EvalSlave history event $PRIV(event)] } } } else { ## Goto previous command in history if {$PRIV(event) == $nextid} { set PRIV(cmdbuf) [CmdGet $w] } if {[catch {EvalSlave history event [incr PRIV(event) -1]} res]} { incr PRIV(event) } else { $w delete limit end $w insert limit $res } } } $w mark set insert end $w see end } ## ::tkcon::Highlight - magic highlighting ## beware: voodoo included # ARGS: ## proc ::tkcon::Highlight {w type} { variable COLOR variable OPT switch -exact $type { "error" { HighlightError $w } "tcl" - "test" { if {[winfo class $w] != "Ctext"} { return } foreach {app type} [tkcon attach] {break} set cmds [::tkcon::EvalOther $app $type info commands] set classes [list \ [list comment ClassForRegexp "^\\s*#\[^\n\]*" $COLOR(stderr)] \ [list var ClassWithOnlyCharStart "\$" $COLOR(stdout)] \ [list syntax ClassForSpecialChars "\[\]{}\"" $COLOR(prompt)] \ [list command Class $cmds $COLOR(proc)] \ ] # Remove all highlight classes from a widget ctext::clearHighlightClasses $w foreach class $classes { foreach {cname ctype cptn ccol} $class break ctext::addHighlight$ctype $w $cname $ccol $cptn } $w highlight 1.0 end } } } ## ::tkcon::HighlightError - magic error highlighting ## beware: voodoo included # ARGS: ## proc ::tkcon::HighlightError w { variable COLOR variable OPT ## do voodoo here set app [Attach] # we have to pull the text out, because text regexps are screwed on \n's. set info [$w get 1.0 end-1c] # Check for specific line error in a proc set exp(proc) "\"(\[^\"\]+)\"\n\[\t \]+\\\(procedure \"(\[^\"\]+)\"" # Check for too few args to a proc set exp(param) "parameter \"(\[^\"\]+)\" to \"(\[^\"\]+)\"" set start 1.0 while { [regexp -indices -- $exp(proc) $info junk what cmd] || [regexp -indices -- $exp(param) $info junk what cmd] } { foreach {w0 w1} $what {c0 c1} $cmd {break} set what [string range $info $w0 $w1] set cmd [string range $info $c0 $c1] if {[string match *::* $cmd]} { set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \ [list [namespace qualifiers $cmd] \ [list info procs [namespace tail $cmd]]]] } else { set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]] } if {[llength $res]==1} { set tag [UniqueTag $w] $w tag add $tag $start+${c0}c $start+1c+${c1}c $w tag configure $tag -foreground $COLOR(stdout) $w tag bind $tag <Enter> [list $w tag configure $tag -under 1] $w tag bind $tag <Leave> [list $w tag configure $tag -under 0] $w tag bind $tag <ButtonRelease-1> "if {!\$tk::Priv(mouseMoved)} \ {[list $OPT(edit) -attach $app -type proc -find $what -- $cmd]}" } set info [string range $info $c1 end] set start [$w index $start+${c1}c] } ## Next stage, check for procs that start a line set start 1.0 set exp(cmd) "^\"\[^\" \t\n\]+" while { [string compare {} [set ix \ [$w search -regexp -count numc -- $exp(cmd) $start end]]] } { set start [$w index $ix+${numc}c] # +1c to avoid the first quote set cmd [$w get $ix+1c $start] if {[string match *::* $cmd]} { set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \ [list [namespace qualifiers $cmd] \ [list info procs [namespace tail $cmd]]]] } else { set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]] } if {[llength $res]==1} { set tag [UniqueTag $w] $w tag add $tag $ix+1c $start $w tag configure $tag -foreground $COLOR(proc) $w tag bind $tag <Enter> [list $w tag configure $tag -under 1] $w tag bind $tag <Leave> [list $w tag configure $tag -under 0] $w tag bind $tag <ButtonRelease-1> "if {!\$tk::Priv(mouseMoved)} \ {[list $OPT(edit) -attach $app -type proc -- $cmd]}" } } } proc ::tkcon::ExpectInit {{termcap 1} {terminfo 1}} { global env if {$termcap} { set env(TERM) "tt" set env(TERMCAP) {tt: :ks=\E[KS: :ke=\E[KE: :cm=\E[%d;%dH: :up=\E[A: :nd=\E[C: :cl=\E[H\E[J: :do=^J: :so=\E[7m: :se=\E[m: :k1=\EOP: :k2=\EOQ: :k3=\EOR: :k4=\EOS: :k5=\EOT: :k6=\EOU: :k7=\EOV: :k8=\EOW: :k9=\EOX: } } if {$terminfo} { set env(TERM) "tkterm" if {![info exists env(TEMP)]} { set env(TEMP) /tmp } set env(TERMINFO) $env(TEMP) set ttsrc [file join $env(TEMP) tt.src] set file [open $ttsrc w] puts $file {tkterm|Don Libes' tk text widget terminal emulator, smkx=\E[KS, rmkx=\E[KE, cup=\E[%p1%d;%p2%dH, cuu1=\E[A, cuf1=\E[C, clear=\E[H\E[J, ind=\n, cr=\r, smso=\E[7m, rmso=\E[m, kf1=\EOP, kf2=\EOQ, kf3=\EOR, kf4=\EOS, kf5=\EOT, kf6=\EOU, kf7=\EOV, kf8=\EOW, kf9=\EOX, } close $file if {[catch {exec tic $ttsrc} msg]} { return -code error \ "tic failed, you may not have terminfo support:\n$msg" } file delete $ttsrc } } # term_exit is called if the spawned process exits proc ::tkcon::term_exit {w} { variable EXP catch {exp_close -i $EXP(spawn_id)} set EXP(forever) 1 unset EXP } # term_chars_changed is called after every change to the displayed chars # You can use if you want matches to occur in the background (a la bind) # If you want to test synchronously, then just do so - you don't need to # redefine this procedure. proc ::tkcon::term_chars_changed {w args} { } # term_cursor_changed is called after the cursor is moved proc ::tkcon::term_cursor_changed {w args} { } proc ::tkcon::term_update_cursor {w args} { variable OPT variable EXP $w mark set insert $EXP(row).$EXP(col) $w see insert term_cursor_changed $w } proc ::tkcon::term_clear {w args} { $w delete 1.0 end term_init $w } proc ::tkcon::term_init {w args} { variable OPT variable EXP # initialize it with blanks to make insertions later more easily set blankline [string repeat " " $OPT(cols)]\n for {set i 1} {$i <= $OPT(rows)} {incr i} { $w insert $i.0 $blankline } set EXP(row) 1 set EXP(col) 0 $w mark set insert $EXP(row).$EXP(col) } proc ::tkcon::term_down {w args} { variable OPT variable EXP if {$EXP(row) < $OPT(rows)} { incr EXP(row) } else { # already at last line of term, so scroll screen up $w delete 1.0 2.0 # recreate line at end $w insert end [string repeat " " $OPT(cols)]\n } } proc ::tkcon::term_insert {w s} { variable OPT variable EXP set chars_rem_to_write [string length $s] set space_rem_on_line [expr {$OPT(cols) - $EXP(col)}] set tag_action [expr {$EXP(standout) ? "add" : "remove"}] ################## # write first line ################## if {$chars_rem_to_write > $space_rem_on_line} { set chars_to_write $space_rem_on_line set newline 1 } else { set chars_to_write $chars_rem_to_write set newline 0 } $w delete $EXP(row).$EXP(col) \ $EXP(row).[expr {$EXP(col) + $chars_to_write}] $w insert $EXP(row).$EXP(col) \ [string range $s 0 [expr {$space_rem_on_line-1}]] $w tag $tag_action standout $EXP(row).$EXP(col) \ $EXP(row).[expr {$EXP(col) + $chars_to_write}] # discard first line already written incr chars_rem_to_write -$chars_to_write set s [string range $s $chars_to_write end] # update EXP(col) incr EXP(col) $chars_to_write # update EXP(row) if {$newline} { term_down $w } ################## # write full lines ################## while {$chars_rem_to_write >= $OPT(cols)} { $w delete $EXP(row).0 $EXP(row).end $w insert $EXP(row).0 [string range $s 0 [expr {$OPT(cols)-1}]] $w tag $tag_action standout $EXP(row).0 $EXP(row).end # discard line from buffer set s [string range $s $OPT(cols) end] incr chars_rem_to_write -$OPT(cols) set EXP(col) 0 term_down $w } ################# # write last line ################# if {$chars_rem_to_write} { $w delete $EXP(row).0 $EXP(row).$chars_rem_to_write $w insert $EXP(row).0 $s $w tag $tag_action standout $EXP(row).0 $EXP(row).$chars_rem_to_write set EXP(col) $chars_rem_to_write } term_chars_changed $w } proc ::tkcon::Expect {cmd} { variable OPT variable PRIV variable EXP set EXP(standout) 0 set EXP(row) 0 set EXP(col) 0 set env(LINES) $OPT(rows) set env(COLUMNS) $OPT(cols) ExpectInit log_user 0 set ::stty_init "-tabs" uplevel \#0 [linsert $cmd 0 spawn] set EXP(spawn_id) $::spawn_id if {[info exists ::spawn_out(slave,name)]} { set EXP(slave,name) $::spawn_out(slave,name) catch {stty rows $OPT(rows) columns $OPT(cols) < $::spawn_out(slave,name)} } if {[string index $cmd end] == "&"} { set cmd expect_background } else { set cmd expect } bind $PRIV(console) <Meta-KeyPress> { if {"%A" != ""} { exp_send -i $::tkcon::EXP(spawn_id) "\033%A" break } } bind $PRIV(console) <KeyPress> { exp_send -i $::tkcon::EXP(spawn_id) -- %A break } bind $PRIV(console) <Control-space> {exp_send -null} set code [catch { term_init $PRIV(console) while {[info exists EXP(spawn_id)]} { $cmd { -i $::tkcon::EXP(spawn_id) -re "^\[^\x01-\x1f\]+" { # Text ::tkcon::term_insert $::tkcon::PRIV(console) \ $expect_out(0,string) ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\r" { # (cr,) Go to beginning of line update idle set ::tkcon::EXP(col) 0 ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\n" { # (ind,do) Move cursor down one line if {$::tcl_platform(platform) eq "windows"} { # Windows seems to get the LF without the CR update idle set ::tkcon::EXP(col) 0 } ::tkcon::term_down $::tkcon::PRIV(console) ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\b" { # Backspace nondestructively incr ::tkcon::EXP(col) -1 ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\a" { bell } "^\t" { # Tab, shouldn't happen send_error "got a tab!?" } eof { ::tkcon::term_exit $::tkcon::PRIV(console) } "^\x1b\\\[A" { # Cursor Up (cuu1,up) incr ::tkcon::EXP(row) -1 ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\x1b\\\[B" { # Cursor Down incr ::tkcon::EXP(row) ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\x1b\\\[C" { # Cursor Right (cuf1,nd) incr ::tkcon::EXP(col) ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\x1b\\\[D" { # Cursor Left incr ::tkcon::EXP(col) ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\x1b\\\[H" { # Cursor Home } -re "^\x1b\\\[(\[0-9\]*);(\[0-9\]*)H" { # (cup,cm) Move to row y col x set ::tkcon::EXP(row) [expr {$expect_out(1,string)+1}] set ::tkcon::EXP(col) $expect_out(2,string) ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\x1b\\\[H\x1b\\\[J" { # (clear,cl) Clear screen ::tkcon::term_clear $::tkcon::PRIV(console) ::tkcon::term_update_cursor $::tkcon::PRIV(console) } "^\x1b\\\[7m" { # (smso,so) Begin standout mode set ::tkcon::EXP(standout) 1 } "^\x1b\\\[m" { # (rmso,se) End standout mode set ::tkcon::EXP(standout) 0 } "^\x1b\\\[KS" { # (smkx,ks) start keyboard-transmit mode # terminfo invokes these when going in/out of graphics mode # In graphics mode, we should have no scrollbars #graphicsSet 1 } "^\x1b\\\[KE" { # (rmkx,ke) end keyboard-transmit mode # Out of graphics mode, we should have scrollbars #graphicsSet 0 } } } #vwait ::tkcon::EXP(forever) } err] bind $PRIV(console) <Meta-KeyPress> {} bind $PRIV(console) <KeyPress> {} bind $PRIV(console) <Control-space> {} catch {unset EXP} if {$code} { return -code $code -errorinfo $::errorInfo $err } } ## tkcon - command that allows control over the console ## This always exists in the main interpreter, and is aliased into ## other connected interpreters # ARGS: totally variable, see internal comments ## proc tkcon {cmd args} { variable ::tkcon::PRIV variable ::tkcon::OPT global errorInfo switch -glob -- $cmd { buf* { ## 'buffer' Sets/Query the buffer size if {[llength $args]} { if {[regexp {^[1-9][0-9]*$} $args]} { set OPT(buffer) $args # catch in case the console doesn't exist yet catch {::tkcon::ConstrainBuffer $PRIV(console) \ $OPT(buffer)} } else { return -code error "buffer must be a valid integer" } } return $OPT(buffer) } linelen* { ## 'linelength' Sets/Query the maximum line length if {[llength $args]} { if {[regexp {^-?[0-9]+$} $args]} { set OPT(maxlinelen) $args } else { return -code error "buffer must be a valid integer" } } return $OPT(maxlinelen) } bg* { ## 'bgerror' Brings up an error dialog set errorInfo [lindex $args 1] bgerror [lindex $args 0] } cl* { ## 'close' Closes the console ::tkcon::Destroy } cons* { ## 'console' - passes the args to the text widget of the console. set result [uplevel 1 $PRIV(console) $args] ::tkcon::ConstrainBuffer $PRIV(console) $OPT(buffer) return $result } congets { ## 'congets' a replacement for [gets stdin] # Use the 'gets' alias of 'tkcon_gets' command instead of # calling the *get* methods directly for best compatability if {[llength $args]} { return -code error "wrong # args: must be \"tkcon congets\"" } tkcon show set old [bind TkConsole <<TkCon_Eval>>] bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 } set w $PRIV(console) # Make sure to move the limit to get the right data $w mark set limit end-1c $w mark gravity limit left $w mark set insert end $w see end vwait ::tkcon::PRIV(wait) set line [::tkcon::CmdGet $w] $w insert end \n bind TkConsole <<TkCon_Eval>> $old return $line } exp* { ::tkcon::Expect [lindex $args 0] } getc* { ## 'getcommand' a replacement for [gets stdin] ## This forces a complete command to be input though if {[llength $args]} { return -code error "wrong # args: must be \"tkcon getcommand\"" } tkcon show set old [bind TkConsole <<TkCon_Eval>>] bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 } set w $PRIV(console) # Make sure to move the limit to get the right data $w mark set insert end $w mark set limit insert $w see end vwait ::tkcon::PRIV(wait) set line [::tkcon::CmdGet $w] $w insert end \n while {![info complete $line] || [regexp {[^\\]\\$} $line]} { vwait ::tkcon::PRIV(wait) set line [::tkcon::CmdGet $w] $w insert end \n $w see end } bind TkConsole <<TkCon_Eval>> $old return $line } get - gets { ## 'gets' - a replacement for [gets stdin] ## This pops up a text widget to be used for stdin (local grabbed) if {[llength $args]} { return -code error "wrong # args: should be \"tkcon gets\"" } set t $PRIV(base).gets if {![winfo exists $t]} { toplevel $t wm withdraw $t catch {wm attributes $t -type dialog} wm title $t "tkcon gets stdin request" label $t.gets -text "\"gets stdin\" request:" text $t.data -width 32 -height 5 -wrap none \ -xscrollcommand [list $t.sx set] \ -yscrollcommand [list $t.sy set] -borderwidth 1 scrollbar $t.sx -orient h -takefocus 0 -highlightthickness 0 \ -command [list $t.data xview] scrollbar $t.sy -orient v -takefocus 0 -highlightthickness 0 \ -command [list $t.data yview] button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} bind $t.ok <Return> { %W invoke } grid $t.gets - -sticky ew grid $t.data $t.sy -sticky news grid $t.sx -sticky ew grid $t.ok - -sticky ew grid columnconfig $t 0 -weight 1 grid rowconfig $t 1 -weight 1 wm transient $t $PRIV(root) wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ reqwidth $t]) / 2}]+[expr {([winfo \ screenheight $t]-[winfo reqheight $t]) / 2}] } $t.data delete 1.0 end wm deiconify $t raise $t grab $t focus $t.data vwait ::tkcon::PRIV(grab) grab release $t wm withdraw $t return [$t.data get 1.0 end-1c] } err* { ## Outputs stack caused by last error. ## error handling with pizazz (but with pizza would be nice too) if {[llength $args]==2} { set app [lindex $args 0] set type [lindex $args 1] if {[catch {::tkcon::EvalOther $app $type set errorInfo} info]} { set info "error getting info from $type $app:\n$info" } } else { set info $PRIV(errorInfo) } if {[string match {} $info]} { set info "errorInfo empty" } ## If args is empty, the -attach switch just ignores it $OPT(edit) -attach $args -type error -- $info } fi* { ## 'find' string ::tkcon::Find $PRIV(console) $args } fo* { ## 'font' ?fontname? - gets/sets the font of the console if {[llength $args]} { if {[info exists PRIV(console)] && \ [winfo exists $PRIV(console)]} { $PRIV(console) config -font $args set OPT(font) [$PRIV(console) cget -font] } else { set OPT(font) $args } } return $OPT(font) } hid* - with* { ## 'hide' 'withdraw' - hides the console. if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} { wm withdraw $PRIV(root) } } his* { ## 'history' set sub {\2} if {[string match -new* $args]} { append sub "\n"} set h [::tkcon::EvalSlave history] regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h return $h } ico* { ## 'iconify' - iconifies the console with 'iconify'. if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} { wm iconify $PRIV(root) } } mas* - eval { ## 'master' - evals contents in master interpreter uplevel \#0 $args } result* { ## 'resultfilter' Sets/queries the result filter command if {[llength $args]} { set OPT(resultfilter) $args } return $OPT(resultfilter) } set { ## 'set' - set (or get, or unset) simple vars (not whole arrays) ## from the master console interpreter ## possible formats: ## tkcon set <var> ## tkcon set <var> <value> ## tkcon set <var> <interp> <var1> <var2> w ## tkcon set <var> <interp> <var1> <var2> u ## tkcon set <var> <interp> <var1> <var2> r if {[llength $args]==5} { ## This is for use w/ 'tkcon upvar' and only works with slaves foreach {var i var1 var2 op} $args break if {[string compare {} $var2]} { append var1 "($var2)" } switch $op { u { uplevel \#0 [list unset $var] } w { return [uplevel \#0 [list set $var \ [interp eval $i [list set $var1]]]] } r { return [interp eval $i [list set $var1 \ [uplevel \#0 [list set $var]]]] } } } elseif {[llength $args] == 1} { upvar \#0 [lindex $args 0] var if {[array exists var]} { return [array get var] } else { return $var } } return [uplevel \#0 set $args] } append { ## Modify a var in the master environment using append return [uplevel \#0 append $args] } lappend { ## Modify a var in the master environment using lappend return [uplevel \#0 lappend $args] } sh* - dei* { ## 'show|deiconify' - deiconifies the console. if {![info exists PRIV(root)]} { # We are likely in some embedded console configuration. # Make default setup reflect that. set PRIV(showOnStartup) 0 set PRIV(protocol) {tkcon hide} set PRIV(root) .tkcon set OPT(exec) "" } if {![winfo exists $PRIV(root)]} { eval [linsert $args 0 ::tkcon::Init] } # this may throw an error if toplevel is embedded catch {wm deiconify $PRIV(root); raise $PRIV(root)} focus -force $PRIV(console) } ti* { ## 'title' ?title? - gets/sets the console's title if {[llength $args]} { return [wm title $PRIV(root) [join $args]] } else { return [wm title $PRIV(root)] } } upv* { ## 'upvar' masterVar slaveVar ## link slave variable slaveVar to the master variable masterVar ## only works masters<->slave set masterVar [lindex $args 0] set slaveVar [lindex $args 1] if {[info exists $masterVar]} { interp eval $OPT(exec) \ [list set $slaveVar [set $masterVar]] } else { catch {interp eval $OPT(exec) [list unset $slaveVar]} } interp eval $OPT(exec) \ [list trace variable $slaveVar rwu \ [list tkcon set $masterVar $OPT(exec)]] return } v* { return $PRIV(version) } default { ## tries to determine if the command exists, otherwise throws error set new ::tkcon::[string toupper \ [string index $cmd 0]][string range $cmd 1 end] if {[llength [info command $new]]} { uplevel \#0 $new $args } else { return -code error "bad option \"$cmd\": must be\ [join [lsort [list attach close console destroy \ font hide iconify load main master new save show \ slave deiconify version title bgerror]] {, }]" } } } } ## ## Some procedures to make up for lack of built-in shell commands ## ## tkcon_puts - ## This allows me to capture all stdout/stderr to the console window ## This will be renamed to 'puts' at the appropriate time during init ## # ARGS: same as usual # Outputs: the string with a color-coded text tag ## proc tkcon_puts args { set len [llength $args] foreach {arg1 arg2 arg3} $args { break } if {$len == 1} { tkcon console insert output "$arg1\n" stdout } elseif {$len == 2} { if {![string compare $arg1 -nonewline]} { tkcon console insert output $arg2 stdout } elseif {![string compare $arg1 stdout] \ || ![string compare $arg1 stderr]} { tkcon console insert output "$arg2\n" $arg1 } else { set len 0 } } elseif {$len == 3} { if {![string compare $arg1 -nonewline] \ && (![string compare $arg2 stdout] \ || ![string compare $arg2 stderr])} { tkcon console insert output $arg3 $arg2 } elseif {(![string compare $arg1 stdout] \ || ![string compare $arg1 stderr]) \ && ![string compare $arg3 nonewline]} { tkcon console insert output $arg2 $arg1 } else { set len 0 } } else { set len 0 } ## $len == 0 means it wasn't handled by tkcon above. ## if {$len == 0} { global errorCode errorInfo if {[catch "tkcon_tcl_puts $args" msg]} { regsub tkcon_tcl_puts $msg puts msg regsub -all tkcon_tcl_puts $errorInfo puts errorInfo return -code error $msg } return $msg } ## WARNING: This update should behave well because it uses idletasks, ## however, if there are weird looping problems with events, or ## hanging in waits, try commenting this out. if {$len} { tkcon console see output update idletasks } } ## tkcon_gets - ## This allows me to capture all stdin input without needing to stdin ## This will be renamed to 'gets' at the appropriate time during init ## # ARGS: same as gets # Outputs: same as gets ## proc tkcon_gets args { set len [llength $args] if {$len != 1 && $len != 2} { return -code error \ "wrong # args: should be \"gets channelId ?varName?\"" } if {[string compare stdin [lindex $args 0]]} { return [uplevel 1 tkcon_tcl_gets $args] } set gtype [tkcon set ::tkcon::OPT(gets)] if {$gtype == ""} { set gtype congets } set data [tkcon $gtype] if {$len == 2} { upvar 1 [lindex $args 1] var set var $data return [string length $data] } return $data } ## edit - opens a file/proc/var for reading/editing ## # Arguments: # type proc/file/var # what the actual name of the item # Returns: nothing ## proc edit {args} { variable ::tkcon::PRIV variable ::tkcon::COLOR variable ::tkcon::OPT array set opts {-find {} -type {} -attach {} -wrap {none}} while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { -f* { set opts(-find) [lindex $args 1] } -a* { set opts(-attach) [lindex $args 1] } -t* { set opts(-type) [lindex $args 1] } -w* { set opts(-wrap) [lindex $args 1] } -- { set args [lreplace $args 0 0]; break } default {return -code error "unknown option \"[lindex $args 0]\""} } set args [lreplace $args 0 1] } # determine who we are dealing with if {[llength $opts(-attach)]} { foreach {app type} $opts(-attach) {break} } else { foreach {app type} [tkcon attach] {break} } set word [lindex $args 0] if {$opts(-type) == {}} { if {[llength [::tkcon::EvalOther $app $type info commands [list $word]]]} { set opts(-type) "proc" } elseif {[llength [::tkcon::EvalOther $app $type info vars [list $word]]]} { set opts(-type) "var" } elseif {[::tkcon::EvalOther $app $type file isfile [list $word]]} { set opts(-type) "file" } } if {$opts(-type) == {}} { return -code error "unrecognized type '$word'" } # Create unique edit window toplevel set w $PRIV(base).__edit set i 0 while {[winfo exists $w[incr i]]} {} append w $i toplevel $w wm withdraw $w if {[string length $word] > 20} { wm title $w "[string range $word 0 16]... - tkcon Edit" } else { wm title $w "$word - tkcon Edit" } if {[package provide ctext] != ""} { set txt [ctext $w.text] } else { set txt [text $w.text] } $w.text configure -wrap $opts(-wrap) \ -xscrollcommand [list $w.sx set] \ -yscrollcommand [list $w.sy set] \ -foreground $COLOR(stdin) \ -background $COLOR(bg) \ -insertbackground $COLOR(cursor) \ -font $::tkcon::OPT(font) -borderwidth 1 -highlightthickness 0 \ -undo 1 catch { # 8.5+ stuff set tabsp [expr {$OPT(tabspace) * [font measure $OPT(font) 0]}] $w.text configure -tabs [list $tabsp left] -tabstyle wordprocessor } scrollbar $w.sx -orient h -command [list $w.text xview] scrollbar $w.sy -orient v -command [list $w.text yview] set menu [menu $w.mbar] $w configure -menu $menu ## File Menu ## set m [menu [::tkcon::MenuButton $menu File file]] $m add command -label "Save As..." -underline 0 \ -command [list ::tkcon::Save {} widget $w.text] $m add command -label "Append To..." -underline 0 \ -command [list ::tkcon::Save {} widget $w.text a+] $m add separator $m add command -label "Dismiss" -underline 0 -accel $PRIV(ACC)w \ -command [list destroy $w] bind $w <$PRIV(CTRL)w> [list destroy $w] bind $w <Alt-w> [list destroy $w] ## Edit Menu ## set text $w.text set m [menu [::tkcon::MenuButton $menu Edit edit]] $m add command -label "Cut" -under 2 \ -command [list tk_textCut $text] $m add command -label "Copy" -under 0 \ -command [list tk_textCopy $text] $m add command -label "Paste" -under 0 \ -command [list tk_textPaste $text] $m add separator $m add command -label "Find" -under 0 \ -command [list ::tkcon::FindBox $text] ## Send To Menu ## set m [menu [::tkcon::MenuButton $menu "Send To..." send]] $m add command -label "Send To $app" -underline 0 \ -command "::tkcon::EvalOther [list $app] $type \ eval \[$w.text get 1.0 end-1c\]" set other [tkcon attach] if {[string compare $other [list $app $type]]} { $m add command -label "Send To [lindex $other 0]" \ -command "::tkcon::EvalOther $other \ eval \[$w.text get 1.0 end-1c\]" } grid $w.text - $w.sy -sticky news grid $w.sx - -sticky ew grid columnconfigure $w 0 -weight 1 grid columnconfigure $w 1 -weight 1 grid rowconfigure $w 0 -weight 1 switch -glob -- $opts(-type) { proc* { $w.text insert 1.0 \ [::tkcon::EvalOther $app $type dump proc [list $word]] after idle [::tkcon::Highlight $w.text tcl] } var* { $w.text insert 1.0 \ [::tkcon::EvalOther $app $type dump var [list $word]] after idle [::tkcon::Highlight $w.text tcl] } file { $w.text insert 1.0 [::tkcon::EvalOther $app $type eval \ [subst -nocommands { set __tkcon(fid) [open {$word} r] set __tkcon(data) [read \$__tkcon(fid)] close \$__tkcon(fid) after 1000 unset __tkcon return \$__tkcon(data) } ]] after idle [::tkcon::Highlight $w.text \ [string trimleft [file extension $word] .]] } error* { $w.text insert 1.0 [join $args \n] after idle [::tkcon::Highlight $w.text error] } default { $w.text insert 1.0 [join $args \n] } } wm deiconify $w focus $w.text if {[string compare $opts(-find) {}]} { ::tkcon::Find $w.text $opts(-find) -case 1 } } interp alias {} ::more {} ::edit interp alias {} ::less {} ::edit ## echo ## Relaxes the one string restriction of 'puts' # ARGS: any number of strings to output to stdout ## proc echo args { puts stdout [concat $args] } ## clear - clears the buffer of the console (not the history though) ## This is executed in the parent interpreter ## proc clear {{pcnt 100}} { if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { return -code error \ "invalid percentage to clear: must be 1-100 (100 default)" } elseif {$pcnt == 100} { tkcon console delete 1.0 end } else { set tmp [expr {$pcnt/100.0*[tkcon console index end]}] tkcon console delete 1.0 "$tmp linestart" } } ## alias - akin to the csh alias command ## If called with no args, then it dumps out all current aliases ## If called with one arg, returns the alias of that arg (or {} if none) # ARGS: newcmd - (optional) command to bind alias to # args - command and args being aliased ## proc alias {{newcmd {}} args} { if {[string match {} $newcmd]} { set res {} foreach a [interp aliases] { lappend res [list $a -> [interp alias {} $a]] } return [join $res \n] } elseif {![llength $args]} { interp alias {} $newcmd } else { eval interp alias [list {} $newcmd {}] $args } } ## unalias - unaliases an alias'ed command # ARGS: cmd - command to unbind as an alias ## proc unalias {cmd} { interp alias {} $cmd {} } ## dump - outputs variables/procedure/widget info in source'able form. ## Accepts glob style pattern matching for the names # # ARGS: type - type of thing to dump: must be variable, procedure, widget # # OPTS: -nocomplain # don't complain if no items of the specified type are found # -filter pattern # specifies a glob filter pattern to be used by the variable # method as an array filter pattern (it filters down for # nested elements) and in the widget method as a config # option filter pattern # -- forcibly ends options recognition # # Returns: the values of the requested items in a 'source'able form ## proc dump {type args} { set whine 1 set code ok if {![llength $args]} { ## If no args, assume they gave us something to dump and ## we'll try anything set args $type set type any } while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { -n* { set whine 0; set args [lreplace $args 0 0] } -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } -- { set args [lreplace $args 0 0]; break } default {return -code error "unknown option \"[lindex $args 0]\""} } } if {$whine && ![llength $args]} { return -code error "wrong \# args: [lindex [info level 0] 0] type\ ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?" } set res {} switch -glob -- $type { c* { # command # outputs commands by figuring out, as well as possible, what it is # this does not attempt to auto-load anything foreach arg $args { if {[llength [set cmds [info commands $arg]]]} { foreach cmd [lsort $cmds] { if {[lsearch -exact [interp aliases] $cmd] > -1} { append res "\#\# ALIAS: $cmd =>\ [interp alias {} $cmd]\n" } elseif { [llength [info procs $cmd]] || ([string match *::* $cmd] && [llength [namespace eval [namespace qual $cmd] \ info procs [namespace tail $cmd]]]) } { if {[catch {dump p -- $cmd} msg] && $whine} { set code error } append res $msg\n } else { append res "\#\# COMMAND: $cmd\n" } } } elseif {$whine} { append res "\#\# No known command $arg\n" set code error } } } v* { # variable # outputs variables value(s), whether array or simple. if {![info exists fltr]} { set fltr * } foreach arg $args { if {![llength [set vars [uplevel 1 info vars [list $arg]]]]} { if {[uplevel 1 info exists $arg]} { set vars $arg } elseif {$whine} { append res "\#\# No known variable $arg\n" set code error continue } else { continue } } foreach var [lsort $vars] { if {[uplevel 1 [list info locals $var]] == ""} { # use the proper scope of the var, but namespace which # won't id locals or some upvar'ed vars correctly set new [uplevel 1 \ [list namespace which -variable $var]] if {$new != ""} { set var $new } } upvar 1 $var v if {[array exists v] || [catch {string length $v}]} { set nst {} append res "array set [list $var] \{\n" if {[array size v]} { foreach i \ [lsort -dictionary [array names v $fltr]] { upvar 0 v\($i\) __a if {[array exists __a]} { append nst "\#\# NESTED ARRAY ELEM: $i\n" append nst "upvar 0 [list $var\($i\)] __a;\ [dump v -filter $fltr __a]\n" } else { append res " [list $i]\t[list $v($i)]\n" } } } else { ## empty array append res " empty array\n" if {$var == ""} { append nst "unset (empty)\n" } else { append nst "unset [list $var](empty)\n" } } append res "\}\n$nst" } else { append res [list set $var $v]\n } } } } p* { # procedure foreach arg $args { if { ![llength [set procs [info proc $arg]]] && ([string match *::* $arg] && [llength [set ps [namespace eval \ [namespace qualifier $arg] \ info procs [namespace tail $arg]]]]) } { set procs {} set namesp [namespace qualifier $arg] foreach p $ps { lappend procs ${namesp}::$p } } if {[llength $procs]} { foreach p [lsort $procs] { set as {} foreach a [info args $p] { if {[info default $p $a tmp]} { lappend as [list $a $tmp] } else { lappend as $a } } append res [list proc $p $as [info body $p]]\n } } elseif {$whine} { append res "\#\# No known proc $arg\n" set code error } } } w* { # widget ## The user should have Tk loaded if {![llength [info command winfo]]} { return -code error "winfo not present, cannot dump widgets" } if {![info exists fltr]} { set fltr .* } foreach arg $args { if {[llength [set ws [info command $arg]]]} { foreach w [lsort $ws] { if {[winfo exists $w]} { if {[catch {$w configure} cfg]} { append res "\#\# Widget $w\ does not support configure method" set code error } else { append res "\#\# [winfo class $w]\ $w\n$w configure" foreach c $cfg { if {[llength $c] != 5} continue ## Check to see that the option does ## not match the default, then check ## the item against the user filter if {[string compare [lindex $c 3] \ [lindex $c 4]] && \ [regexp -nocase -- $fltr $c]} { append res " \\\n\t[list [lindex $c 0]\ [lindex $c 4]]" } } append res \n } } } } elseif {$whine} { append res "\#\# No known widget $arg\n" set code error } } } a* { ## see if we recognize it, other complain if {[regexp {(var|com|proc|widget)} \ [set types [uplevel 1 what $args]]]} { foreach type $types { if {[regexp {(var|com|proc|widget)} $type]} { append res "[uplevel 1 dump $type $args]\n" } } } else { set res "dump was unable to resolve type for \"$args\"" set code error } } default { return -code error "bad [lindex [info level 0] 0] option\ \"$type\": must be variable, command, procedure,\ or widget" } } return -code $code [string trimright $res \n] } ## idebug - interactive debugger # # idebug body ?level? # # Prints out the body of the command (if it is a procedure) at the # specified level. <i>level</i> defaults to the current level. # # idebug break # # Creates a breakpoint within a procedure. This will only trigger # if idebug is on and the id matches the pattern. If so, TkCon will # pop to the front with the prompt changed to an idebug prompt. You # are given the basic ability to observe the call stack an query/set # variables or execute Tcl commands at any level. A separate history # is maintained in debugging mode. # # idebug echo|{echo ?id?} ?args? # # Behaves just like "echo", but only triggers when idebug is on. # You can specify an optional id to further restrict triggering. # If no id is specified, it defaults to the name of the command # in which the call was made. # # idebug id ?id? # # Query or set the idebug id. This id is used by other idebug # methods to determine if they should trigger or not. The idebug # id can be a glob pattern and defaults to *. # # idebug off # # Turns idebug off. # # idebug on ?id? # # Turns idebug on. If 'id' is specified, it sets the id to it. # # idebug puts|{puts ?id?} args # # Behaves just like "puts", but only triggers when idebug is on. # You can specify an optional id to further restrict triggering. # If no id is specified, it defaults to the name of the command # in which the call was made. # # idebug show type ?level? ?VERBOSE? # # 'type' must be one of vars, locals or globals. This method # will output the variables/locals/globals present in a particular # level. If VERBOSE is added, then it actually 'dump's out the # values as well. 'level' defaults to the level in which this # method was called. # # idebug trace ?level? # # Prints out the stack trace from the specified level up to the top # level. 'level' defaults to the current level. # ## proc idebug {opt args} { global IDEBUG if {![info exists IDEBUG(on)]} { array set IDEBUG { on 0 id * debugging 0 } } set level [expr {[info level]-1}] switch -glob -- $opt { on { # id is just arg0 [bug #50] if {[llength $args]} { set IDEBUG(id) [lindex $args 0] } return [set IDEBUG(on) 1] } off { return [set IDEBUG(on) 0] } id { if {![llength $args]} { return $IDEBUG(id) } else { return [set IDEBUG(id) [lindex $args 0]] } } break { if {!$IDEBUG(on) || $IDEBUG(debugging) || \ ([llength $args] && \ ![string match $IDEBUG(id) $args]) || [info level]<1} { return } set IDEBUG(debugging) 1 puts stderr "idebug at level \#$level: [lindex [info level -1] 0]" set tkcon [llength [info command tkcon]] if {$tkcon} { tkcon master eval set ::tkcon::OPT(prompt2) \$::tkcon::OPT(prompt1) tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(debugPrompt) set slave [tkcon set ::tkcon::OPT(exec)] set event [tkcon set ::tkcon::PRIV(event)] tkcon set ::tkcon::OPT(exec) [tkcon master interp create debugger] tkcon set ::tkcon::PRIV(event) 1 } set max $level while 1 { set err {} if {$tkcon} { # tkcon's overload of gets is advanced enough to not need # this, but we get a little better control this way. tkcon evalSlave set level $level tkcon prompt set line [tkcon getcommand] tkcon console mark set output end } else { puts -nonewline stderr "(level \#$level) debug > " gets stdin line while {![info complete $line]} { puts -nonewline "> " append line "\n[gets stdin]" } } if {[string match {} $line]} continue set key [regexp -inline {\S+} $line] if {![regexp {^\s*\S+\s+([#-]?[0-9]+)} $line -> lvl]} { set lvl \#$level } set res {}; set c 0 switch -- $key { + { ## Allow for jumping multiple levels if {$level < $max} { idebug trace [incr level] $level 0 VERBOSE } } - { ## Allow for jumping multiple levels if {$level > 1} { idebug trace [incr level -1] $level 0 VERBOSE } } . { set c [catch {idebug trace $level $level 0 VERBOSE} res] } v { set c [catch {idebug show vars $lvl } res] } V { set c [catch {idebug show vars $lvl VERBOSE} res] } l { set c [catch {idebug show locals $lvl } res] } L { set c [catch {idebug show locals $lvl VERBOSE} res] } g { set c [catch {idebug show globals $lvl } res] } G { set c [catch {idebug show globals $lvl VERBOSE} res] } t { set c [catch {idebug trace 1 $max $level } res] } T { set c [catch {idebug trace 1 $max $level VERBOSE} res]} b { set c [catch {idebug body $lvl} res] } o { set res [set IDEBUG(on) [expr {!$IDEBUG(on)}]] } h - ? { puts stderr " + Move down in call stack - Move up in call stack . Show current proc name and params v Show names of variables currently in scope V Show names of variables currently in scope with values l Show names of local (transient) variables L Show names of local (transient) variables with values g Show names of declared global variables G Show names of declared global variables with values t Show a stack trace T Show a verbose stack trace b Show body of current proc o Toggle on/off any further debugging c,q Continue regular execution (Quit debugger) h,? Print this help default Evaluate line at current level (\#$level)" } c - q break default { set c [catch {uplevel \#$level $line} res] } } if {$tkcon} { tkcon set ::tkcon::PRIV(event) \ [tkcon evalSlave eval history add [list $line]\ \; history nextid] } if {$c} { puts stderr $res } elseif {[string compare {} $res]} { puts $res } } set IDEBUG(debugging) 0 if {$tkcon} { tkcon master interp delete debugger tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(prompt2) tkcon set ::tkcon::OPT(exec) $slave tkcon set ::tkcon::PRIV(event) $event tkcon prompt } } bo* { if {[regexp {^([#-]?[0-9]+)} $args level]} { return [uplevel $level {dump c -no [lindex [info level 0] 0]}] } } t* { if {[llength $args]<2} return set min [set max [set lvl $level]] set exp {^#?([0-9]+)? ?#?([0-9]+) ?#?([0-9]+)? ?(VERBOSE)?} if {![regexp $exp $args junk min max lvl verbose]} return for {set i $max} { $i>=$min && ![catch {uplevel \#$i info level 0} info] } {incr i -1} { if {$i==$lvl} { puts -nonewline stderr "* \#$i:\t" } else { puts -nonewline stderr " \#$i:\t" } set name [lindex $info 0] if {[string compare VERBOSE $verbose] || \ ![llength [info procs $name]]} { puts $info } else { puts "proc $name {[info args $name]} { ... }" set idx 0 foreach arg [info args $name] { if {[string match args $arg]} { puts "\t$arg = [lrange $info [incr idx] end]" break } else { puts "\t$arg = [lindex $info [incr idx]]" } } } } } s* { #var, local, global set level \#$level if {![regexp {^([vgl][^ ]*) ?([#-]?[0-9]+)? ?(VERBOSE)?} \ $args junk type level verbose]} return switch -glob -- $type { v* { set vars [uplevel $level {lsort [info vars]}] } l* { set vars [uplevel $level {lsort [info locals]}] } g* { set vars [lremove [uplevel $level {info vars}] \ [uplevel $level {info locals}]] } } if {[string match VERBOSE $verbose]} { return [uplevel $level dump var -nocomplain $vars] } else { return $vars } } e* - pu* { if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} { set id [lindex [info level 0] 0] } else { set id [lindex $opt 1] } if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} { if {[string match e* $opt]} { puts [concat $args] } else { eval puts $args } } } default { return -code error "bad [lindex [info level 0] 0] option \"$opt\",\ must be: [join [lsort [list on off id break print body\ trace show puts echo]] {, }]" } } } ## observe - like trace, but not # ARGS: opt - option # name - name of variable or command ## proc observe {opt name args} { global tcl_observe switch -glob -- $opt { co* { if {[regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} \ $name]} { return -code error "cannot observe \"$name\":\ infinite eval loop will occur" } set old ${name}@ while {[llength [info command $old]]} { append old @ } rename $name $old set max 4 regexp {^[0-9]+} $args max # handle the observe'ing of 'proc' set proccmd "proc" if {[string match "proc" $name]} { set proccmd $old } ## idebug trace could be used here $proccmd $name args " for {set i \[info level\]; set max \[expr \[info level\]-$max\]} { \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\] } {incr i -1} { puts -nonewline stderr \" \#\$i:\t\" puts \$info } uplevel \[lreplace \[info level 0\] 0 0 $old\] " set tcl_observe($name) $old } cd* { if {[info exists tcl_observe($name)] && [catch { rename $name {} rename $tcl_observe($name) $name unset tcl_observe($name) } err]} { return -code error $err } } ci* { ## What a useless method... if {[info exists tcl_observe($name)]} { set i $tcl_observe($name) set res "\"$name\" observes true command \"$i\"" while {[info exists tcl_observe($i)]} { append res "\n\"$name\" observes true command \"$i\"" set i $tcl_observe($name) } return $res } } va* - vd* { set type [lindex $args 0] set args [lrange $args 1 end] if {![regexp {^[rwu]} $type type]} { return -code error "bad [lindex [info level 0] 0] $opt type\ \"$type\", must be: read, write or unset" } if {![llength $args]} { set args observe_var } foreach c [uplevel 1 [list trace vinfo $name]] { # don't double up on the traces if {[list $type $args] == $c} { return } } uplevel 1 [list trace $opt $name $type $args] } vi* { uplevel 1 [list trace vinfo $name] } default { return -code error "bad [lindex [info level 0] 0] option\ \"[lindex $args 0]\", must be: [join [lsort \ [list command cdelete cinfo variable vdelete vinfo]] {, }]" } } } ## observe_var - auxilary function for observing vars, called by trace ## via observe # ARGS: name - variable name # el - array element name, if any # op - operation type (rwu) ## proc observe_var {name el op} { if {[string match u $op]} { if {[string compare {} $el]} { puts "unset \"${name}($el)\"" } else { puts "unset \"$name\"" } } else { upvar 1 $name $name if {[info exists ${name}($el)]} { puts [dump v ${name}($el)] } else { puts [dump v $name] } } } ## which - tells you where a command is found # ARGS: cmd - command name # Returns: where command is found (internal / external / unknown) ## proc which cmd { ## This tries to auto-load a command if not recognized set types [uplevel 1 [list what $cmd 1]] if {[llength $types]} { set out {} foreach type $types { switch -- $type { alias { set res "$cmd: aliased to [alias $cmd]" } procedure { set res "$cmd: procedure" } command { set res "$cmd: internal command" } executable { lappend out [auto_execok $cmd] } variable { lappend out "$cmd: $type" } } if {[info exists res]} { global auto_index if {[info exists auto_index($cmd)]} { ## This tells you where the command MIGHT have come from - ## not true if the command was redefined interactively or ## existed before it had to be auto_loaded. This is just ## provided as a hint at where it MAY have come from append res " ($auto_index($cmd))" } lappend out $res unset res } } return [join $out \n] } else { return -code error "$cmd: command not found" } } ## what - tells you what a string is recognized as # ARGS: str - string to id # Returns: id types of command as list ## proc what {str {autoload 0}} { set types {} if {[llength [info commands $str]] || ($autoload && \ [auto_load $str] && [llength [info commands $str]])} { if {[lsearch -exact [interp aliases] $str] > -1} { lappend types "alias" } elseif { [llength [info procs $str]] || ([string match *::* $str] && [llength [namespace eval [namespace qualifier $str] \ info procs [namespace tail $str]]]) } { lappend types "procedure" } else { lappend types "command" } } if {[llength [uplevel 1 info vars $str]]} { upvar 1 $str var if {[array exists var]} { lappend types array variable } else { lappend types scalar variable } } if {[file isdirectory $str]} { lappend types "directory" } if {[file isfile $str]} { lappend types "file" } if {[llength [info commands winfo]] && [winfo exists $str]} { lappend types "widget" } if {[string compare {} [auto_execok $str]]} { lappend types "executable" } return $types } ## dir - directory list # ARGS: args - names/glob patterns of directories to list # OPTS: -all - list hidden files as well (Unix dot files) # -long - list in full format "permissions size date filename" # -full - displays / after directories and link paths for links # Returns: a directory listing ## proc dir {args} { array set s { all 0 full 0 long 0 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx } while {[string match \-* [lindex $args 0]]} { set str [lindex $args 0] set args [lreplace $args 0 0] switch -glob -- $str { -a* {set s(all) 1} -f* {set s(full) 1} -l* {set s(long) 1} -- break default { return -code error "unknown option \"$str\",\ should be one of: -all, -full, -long" } } } set sep [string trim [file join . .] .] if {![llength $args]} { set args [list [pwd]] } if {$::tcl_version >= 8.3} { # Newer glob args allow safer dir processing. The user may still # want glob chars, but really only for file matching. foreach arg $args { if {[file isdirectory $arg]} { if {$s(all)} { lappend out [list $arg [lsort \ [glob -nocomplain -directory $arg .* *]]] } else { lappend out [list $arg [lsort \ [glob -nocomplain -directory $arg *]]] } } else { set dir [file dirname $arg] lappend out [list $dir$sep [lsort \ [glob -nocomplain -directory $dir [file tail $arg]]]] } } } else { foreach arg $args { if {[file isdirectory $arg]} { set arg [string trimright $arg $sep]$sep if {$s(all)} { lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] } else { lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] } } else { lappend out [list [file dirname $arg]$sep \ [lsort [glob -nocomplain -- $arg]]] } } } if {$s(long)} { set old [clock scan {1 year ago}] set fmt "%s%9ld %s %s\n" foreach o $out { set d [lindex $o 0] append res $d:\n foreach f [lindex $o 1] { file lstat $f st set f [file tail $f] if {$s(full)} { switch -glob $st(type) { d* { append f $sep } l* { append f "@ -> [file readlink $d$sep$f]" } default { if {[file exec $d$sep$f]} { append f * } } } } if {[string match file $st(type)]} { set mode - } else { set mode [string index $st(type) 0] } foreach j [split [format %03o [expr {$st(mode)&0777}]] {}] { append mode $s($j) } if {$st(mtime)>$old} { set cfmt {%b %d %H:%M} } else { set cfmt {%b %d %Y} } append res [format $fmt $mode $st(size) \ [clock format $st(mtime) -format $cfmt] $f] } append res \n } } else { foreach o $out { set d [lindex $o 0] append res "$d:\n" set i 0 foreach f [lindex $o 1] { if {[string len [file tail $f]] > $i} { set i [string len [file tail $f]] } } set i [expr {$i+2+$s(full)}] set j 80 ## This gets the number of cols in the tkcon console widget if {[llength [info commands tkcon]]} { set j [expr {[tkcon master set ::tkcon::OPT(cols)]/$i}] } set k 0 foreach f [lindex $o 1] { set f [file tail $f] if {$s(full)} { switch -glob [file type $d$sep$f] { d* { append f $sep } l* { append f @ } default { if {[file exec $d$sep$f]} { append f * } } } } append res [format "%-${i}s" $f] if {$j == 0 || [incr k]%$j == 0} { set res [string trimright $res]\n } } append res \n\n } } return [string trimright $res] } interp alias {} ::ls {} ::dir -full ## lremove - remove items from a list # OPTS: # -all remove all instances of each item # -glob remove all instances matching glob pattern # -regexp remove all instances matching regexp pattern # ARGS: l a list to remove items from # args items to remove (these are 'join'ed together) ## proc lremove {args} { array set opts {-all 0 pattern -exact} while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { -a* { set opts(-all) 1 } -g* { set opts(pattern) -glob } -r* { set opts(pattern) -regexp } -- { set args [lreplace $args 0 0]; break } default {return -code error "unknown option \"[lindex $args 0]\""} } set args [lreplace $args 0 0] } set l [lindex $args 0] foreach i [join [lreplace $args 0 0]] { if {[set ix [lsearch $opts(pattern) $l $i]] == -1} continue set l [lreplace $l $ix $ix] if {$opts(-all)} { while {[set ix [lsearch $opts(pattern) $l $i]] != -1} { set l [lreplace $l $ix $ix] } } } return $l } if {!$::tkcon::PRIV(WWW)} {; ## Unknown changed to get output into tkcon window # unknown: # Invoked automatically whenever an unknown command is encountered. # Works through a list of "unknown handlers" that have been registered # to deal with unknown commands. Extensions can integrate their own # handlers into the 'unknown' facility via 'unknown_handler'. # # If a handler exists that recognizes the command, then it will # take care of the command action and return a valid result or a # Tcl error. Otherwise, it should return "-code continue" (=2) # and responsibility for the command is passed to the next handler. # # Arguments: # args - A list whose elements are the words of the original # command, including the command name. proc unknown args { global unknown_handler_order unknown_handlers errorInfo errorCode # # Be careful to save error info now, and restore it later # for each handler. Some handlers generate their own errors # and disrupt handling. # set savedErrorCode $errorCode set savedErrorInfo $errorInfo if {![info exists unknown_handler_order] || \ ![info exists unknown_handlers]} { set unknown_handlers(tcl) tcl_unknown set unknown_handler_order tcl } foreach handler $unknown_handler_order { set status [catch {uplevel 1 $unknown_handlers($handler) $args} result] if {$status == 1} { # # Strip the last five lines off the error stack (they're # from the "uplevel" command). # set new [split $errorInfo \n] set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n] return -code $status -errorcode $errorCode \ -errorinfo $new $result } elseif {$status != 4} { return -code $status $result } set errorCode $savedErrorCode set errorInfo $savedErrorInfo } set name [lindex $args 0] return -code error "invalid command name \"$name\"" } # tcl_unknown: # Invoked when a Tcl command is invoked that doesn't exist in the # interpreter: # # 1. See if the autoload facility can locate the command in a # Tcl script file. If so, load it and execute it. # 2. If the command was invoked interactively at top-level: # (a) see if the command exists as an executable UNIX program. # If so, "exec" the command. # (b) see if the command requests csh-like history substitution # in one of the common forms !!, !<number>, or ^old^new. If # so, emulate csh's history substitution. # (c) see if the command is a unique abbreviation for another # command. If so, invoke the command. # # Arguments: # args - A list whose elements are the words of the original # command, including the command name. proc tcl_unknown args { global auto_noexec auto_noload env unknown_pending tcl_interactive global errorCode errorInfo # If the command word has the form "namespace inscope ns cmd" # then concatenate its arguments onto the end and evaluate it. set cmd [lindex $args 0] if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] \ && [llength $cmd] == 4} { set arglist [lrange $args 1 end] set ret [catch {uplevel 1 $cmd $arglist} result] if {$ret == 0} { return $result } else { return -code $ret -errorcode $errorCode $result } } # Save the values of errorCode and errorInfo variables, since they # may get modified if caught errors occur below. The variables will # be restored just before re-executing the missing command. set savedErrorCode $errorCode set savedErrorInfo $errorInfo set name [lindex $args 0] if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # if {[info exists unknown_pending($name)]} { return -code error "self-referential recursion in \"unknown\" for command \"$name\"" } set unknown_pending($name) pending if {[llength [info args auto_load]]==1} { set ret [catch {auto_load $name} msg] } else { set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg] } unset unknown_pending($name) if {$ret} { return -code $ret -errorcode $errorCode \ "error while autoloading \"$name\": $msg" } if {![array size unknown_pending]} { unset unknown_pending } if {$msg} { set errorCode $savedErrorCode set errorInfo $savedErrorInfo set code [catch {uplevel 1 $args} msg] if {$code == 1} { # # Strip the last five lines off the error stack (they're # from the "uplevel" command). # set new [split $errorInfo \n] set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n] return -code error -errorcode $errorCode \ -errorinfo $new $msg } else { return -code $code $msg } } } if {[info level] == 1 && [string match {} [info script]] \ && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] if {[string compare {} $new]} { set errorCode $savedErrorCode set errorInfo $savedErrorInfo if {[info exists ::tkcon::EXPECT] && $::tkcon::EXPECT && [package provide Expect] != ""} { return [tkcon expect [concat $new [lrange $args 1 end]]] } else { return [uplevel 1 exec $new [lrange $args 1 end]] } #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] } } set errorCode $savedErrorCode set errorInfo $savedErrorInfo ## ## History substitution moved into ::tkcon::EvalCmd ## if {[string compare $name "::"] == 0} { set name "" } if {$ret != 0} { return -code $ret -errorcode $errorCode \ "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" } set cmds [info commands $name*] if {[llength $cmds] == 1} { return [uplevel 1 [lreplace $args 0 0 $cmds]] } if {[llength $cmds]} { if {$name == ""} { return -code error "empty command name \"\"" } else { return -code error \ "ambiguous command name \"$name\": [lsort $cmds]" } } ## We've got nothing so far ## Check and see if Tk wasn't loaded, but it appears to be a Tk cmd if {![uplevel \#0 info exists tk_version]} { lappend tkcmds bell bind bindtags button \ canvas checkbutton clipboard destroy \ entry event focus font frame grab grid image \ label labelframe listbox lower menu menubutton message \ option pack panedwindow place radiobutton raise \ scale scrollbar selection send spinbox \ text tk tkwait toplevel winfo wm if {[lsearch -exact $tkcmds $name] >= 0 && \ [tkcon master tk_messageBox -icon question -parent . \ -title "Load Tk?" -type retrycancel -default retry \ -message "This appears to be a Tk command, but Tk\ has not yet been loaded. Shall I retry the command\ with loading Tk first?"] == "retry"} { return [uplevel 1 "load {} Tk; $args"] } } } return -code continue } } ; # end exclusionary code for WWW proc ::tkcon::Bindings {} { variable PRIV global tcl_platform tk_version #----------------------------------------------------------------------- # Elements of tk::Priv that are used in this file: # # mouseMoved - Non-zero means the mouse has moved a significant # amount since the button went down (so, for example, # start dragging out a selection). #----------------------------------------------------------------------- ## Get all Text bindings into TkConsole foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] } ## We really didn't want the newline insertion bind TkConsole <Control-Key-o> {} ## in 8.6b3, the virtual events <<NextLine>> and <<PrevLine>> # mess up our history feature bind TkConsole <<NextLine>> {} bind TkConsole <<PrevLine>> {} ## Now make all our virtual event bindings set bindings { <<TkCon_Exit>> <$PRIV(CTRL)-q> <<TkCon_New>> <$PRIV(CTRL)-N> <<TkCon_NewTab>> <$PRIV(CTRL)-T> <<TkCon_NextTab>> <Control-Key-Tab> <<TkCon_PrevTab>> <Control-Shift-Key-Tab> <<TkCon_Close>> <$PRIV(CTRL)-w> <<TkCon_About>> <$PRIV(CTRL)-A> <<TkCon_Find>> <$PRIV(CTRL)F> <<TkCon_Slave>> <$PRIV(CTRL)Key-1> <<TkCon_Master>> <$PRIV(CTRL)Key-2> <<TkCon_Main>> <$PRIV(CTRL)Key-3> <<TkCon_Expand>> <Key-Tab> <<TkCon_ExpandFile>> <Key-Escape> <<TkCon_ExpandProc>> <Control-P> <<TkCon_ExpandVar>> <Control-V> <<TkCon_Tab>> <Control-i> <<TkCon_Tab>> <Alt-i> <<TkCon_Newline>> <Control-o> <<TkCon_Newline>> <Alt-o> <<TkCon_Newline>> <Control-Key-Return> <<TkCon_Newline>> <Control-Key-KP_Enter> <<TkCon_Eval>> <Return> <<TkCon_Eval>> <KP_Enter> <<TkCon_Clear>> <Control-l> <<TkCon_Previous>> <Up> <<TkCon_PreviousImmediate>> <Control-p> <<TkCon_PreviousSearch>> <Control-r> <<TkCon_Next>> <Down> <<TkCon_NextImmediate>> <Control-n> <<TkCon_NextSearch>> <Control-s> <<TkCon_Transpose>> <Control-t> <<TkCon_ClearLine>> <Control-u> <<TkCon_SaveCommand>> <Control-z> } if {$PRIV(AQUA)} { lappend bindings <<TkCon_Popup>> <Control-Button-1> \ <<TkCon_Popup>> <Button-2> } else { lappend bindings <<TkCon_Popup>> <Button-3> } foreach {ev key} [subst -nocommand -noback $bindings] { event add $ev $key ## Make sure the specific key won't be defined bind TkConsole $key {} } ## Make the ROOT bindings bind $PRIV(root) <<TkCon_Exit>> exit bind $PRIV(root) <<TkCon_New>> { ::tkcon::New } bind $PRIV(root) <<TkCon_NewTab>> { ::tkcon::NewTab } bind $PRIV(root) <<TkCon_NextTab>> { ::tkcon::GotoTab 1 ; break } bind $PRIV(root) <<TkCon_PrevTab>> { ::tkcon::GotoTab -1 ; break } bind $PRIV(root) <<TkCon_Close>> { ::tkcon::Destroy } bind $PRIV(root) <<TkCon_About>> { ::tkcon::About } bind $PRIV(root) <<TkCon_Find>> { ::tkcon::FindBox $::tkcon::PRIV(console) } bind $PRIV(root) <<TkCon_Slave>> { ::tkcon::Attach {} ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] } bind $PRIV(root) <<TkCon_Master>> { if {[string compare {} $::tkcon::PRIV(name)]} { ::tkcon::Attach $::tkcon::PRIV(name) } else { ::tkcon::Attach Main } ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] } bind $PRIV(root) <<TkCon_Main>> { ::tkcon::Attach Main ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] } bind $PRIV(root) <<TkCon_Popup>> { ::tkcon::PopupMenu %X %Y } ## Menu items need null TkConsolePost bindings to avoid the TagProc ## foreach ev [bind $PRIV(root)] { bind TkConsolePost $ev { # empty } } # ::tkcon::ClipboardKeysyms -- # This procedure is invoked to identify the keys that correspond to # the copy, cut, and paste functions for the clipboard. # # Arguments: # copy - Name of the key (keysym name plus modifiers, if any, # such as "Meta-y") used for the copy operation. # cut - Name of the key used for the cut operation. # paste - Name of the key used for the paste operation. proc ::tkcon::ClipboardKeysyms {copy cut paste} { bind TkConsole <$copy> {::tkcon::Copy %W} bind TkConsole <$cut> {::tkcon::Cut %W} bind TkConsole <$paste> {::tkcon::Paste %W} } proc ::tkcon::GetSelection {w} { if { ![catch {selection get -displayof $w -type UTF8_STRING} txt] || ![catch {selection get -displayof $w} txt] || ![catch {selection get -displayof $w -selection CLIPBOARD} txt] } { return $txt } return -code error "could not find default selection" } proc ::tkcon::Cut w { if {[string match $w [selection own -displayof $w]]} { clipboard clear -displayof $w catch { set txt [selection get -displayof $w] clipboard append -displayof $w $txt if {[$w compare sel.first >= limit]} { $w delete sel.first sel.last } } } } proc ::tkcon::Copy w { if {[string match $w [selection own -displayof $w]]} { clipboard clear -displayof $w catch { set txt [selection get -displayof $w] clipboard append -displayof $w $txt } } } proc ::tkcon::Paste w { if {![catch {GetSelection $w} txt]} { catch { if {[$w compare sel.first >= limit]} { $w delete sel.first sel.last } } if {[$w compare insert < limit]} { $w mark set insert end } $w insert insert $txt $w see insert if {[string match *\n* $txt]} { ::tkcon::Eval $w } } } ## Redefine for TkConsole what we need ## event delete <<Paste>> <$PRIV(CTRL)V> ::tkcon::ClipboardKeysyms <Copy> <Cut> <Paste> bind TkConsole <Insert> { catch { ::tkcon::Insert %W [::tkcon::GetSelection %W] } } bind TkConsole <Triple-1> {+ catch { eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] eval %W tag remove sel sel.last-1c %W mark set insert sel.first } } ## binding editor needed ## binding <events> for .tkconrc bind TkConsole <<TkCon_ExpandFile>> { if {[%W compare insert > limit]} {::tkcon::Expand %W path} break ; # could check "%K" == "Tab" } bind TkConsole <<TkCon_ExpandProc>> { if {[%W compare insert > limit]} {::tkcon::Expand %W proc} break ; # could check "%K" == "Tab" } bind TkConsole <<TkCon_ExpandVar>> { if {[%W compare insert > limit]} {::tkcon::Expand %W var} break ; # could check "%K" == "Tab" } bind TkConsole <<TkCon_Expand>> { if {[%W compare insert > limit]} {::tkcon::Expand %W} break ; # could check "%K" == "Tab" } bind TkConsole <<TkCon_Tab>> { if {[%W compare insert >= limit]} { ::tkcon::Insert %W \t } } bind TkConsole <<TkCon_Newline>> { if {[%W compare insert >= limit]} { ::tkcon::Insert %W \n } } bind TkConsole <<TkCon_Eval>> { ::tkcon::Eval %W } bind TkConsole <Delete> { if {[llength [%W tag nextrange sel 1.0 end]] \ && [%W compare sel.first >= limit]} { %W delete sel.first sel.last } elseif {[%W compare insert >= limit]} { %W delete insert %W see insert } } bind TkConsole <BackSpace> { if {[llength [%W tag nextrange sel 1.0 end]] \ && [%W compare sel.first >= limit]} { %W delete sel.first sel.last } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} { %W delete insert-1c %W see insert } } bind TkConsole <Control-h> [bind TkConsole <BackSpace>] bind TkConsole <KeyPress> { ::tkcon::Insert %W %A } bind TkConsole <Control-a> { if {[%W compare {limit linestart} == {insert linestart}]} { tk::TextSetCursor %W limit } else { tk::TextSetCursor %W {insert linestart} } } bind TkConsole <Key-Home> [bind TkConsole <Control-a>] bind TkConsole <Control-d> { if {[%W compare insert < limit]} break %W delete insert } bind TkConsole <Control-k> { if {[%W compare insert < limit]} break if {[%W compare insert == {insert lineend}]} { %W delete insert } else { %W delete insert {insert lineend} } } bind TkConsole <<TkCon_Clear>> { ## Clear console buffer, without losing current command line input set ::tkcon::PRIV(tmp) [::tkcon::CmdGet %W] clear ::tkcon::Prompt {} $::tkcon::PRIV(tmp) } bind TkConsole <<TkCon_Previous>> { if {[%W compare {insert linestart} != {limit linestart}]} { tk::TextSetCursor %W [tk::TextUpDownLine %W -1] } else { ::tkcon::Event -1 } } bind TkConsole <<TkCon_Next>> { if {[%W compare {insert linestart} != {end-1c linestart}]} { tk::TextSetCursor %W [tk::TextUpDownLine %W 1] } else { ::tkcon::Event 1 } } bind TkConsole <<TkCon_NextImmediate>> { ::tkcon::Event 1 } bind TkConsole <<TkCon_PreviousImmediate>> { ::tkcon::Event -1 } bind TkConsole <<TkCon_PreviousSearch>> { ::tkcon::Event -1 [::tkcon::CmdGet %W] } bind TkConsole <<TkCon_NextSearch>> { ::tkcon::Event 1 [::tkcon::CmdGet %W] } bind TkConsole <<TkCon_Transpose>> { ## Transpose current and previous chars if {[%W compare insert > "limit+1c"]} { tk::TextTranspose %W } } bind TkConsole <<TkCon_ClearLine>> { ## Clear command line (Unix shell staple) %W delete limit end } bind TkConsole <<TkCon_SaveCommand>> { ## Save command buffer (swaps with current command) set ::tkcon::PRIV(tmp) $::tkcon::PRIV(cmdsave) set ::tkcon::PRIV(cmdsave) [::tkcon::CmdGet %W] if {[string match {} $::tkcon::PRIV(cmdsave)]} { set ::tkcon::PRIV(cmdsave) $::tkcon::PRIV(tmp) } else { %W delete limit end-1c } ::tkcon::Insert %W $::tkcon::PRIV(tmp) %W see end } catch {bind TkConsole <Key-Page_Up> { tk::TextScrollPages %W -1 }} catch {bind TkConsole <Key-Prior> { tk::TextScrollPages %W -1 }} catch {bind TkConsole <Key-Page_Down> { tk::TextScrollPages %W 1 }} catch {bind TkConsole <Key-Next> { tk::TextScrollPages %W 1 }} bind TkConsole <Alt-d> { if {[%W compare insert >= limit]} { %W delete insert {insert wordend} } } bind TkConsole <Alt-BackSpace> { if {[%W compare {insert -1c wordstart} >= limit]} { %W delete {insert -1c wordstart} insert } } bind TkConsole <Alt-Delete> { if {[%W compare insert >= limit]} { %W delete insert {insert wordend} } } bind TkConsole <ButtonRelease-2> { if { (!$tk::Priv(mouseMoved) || $tk_strictMotif) && ![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)] } { if {[%W compare @%x,%y < limit]} { %W insert end $::tkcon::PRIV(tmp) } else { %W insert @%x,%y $::tkcon::PRIV(tmp) } if {[string match *\n* $::tkcon::PRIV(tmp)]} {::tkcon::Eval %W} } } ## ## End TkConsole bindings ## ## ## Bindings for doing special things based on certain keys ## bind TkConsolePost <Key-parenright> { if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ [string compare \\ [%W get insert-2c]]} { ::tkcon::MatchPair %W \( \) limit } set ::tkcon::PRIV(StatusCursor) [%W index insert] } bind TkConsolePost <Key-bracketright> { if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ [string compare \\ [%W get insert-2c]]} { ::tkcon::MatchPair %W \[ \] limit } set ::tkcon::PRIV(StatusCursor) [%W index insert] } bind TkConsolePost <Key-braceright> { if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ [string compare \\ [%W get insert-2c]]} { ::tkcon::MatchPair %W \{ \} limit } set ::tkcon::PRIV(StatusCursor) [%W index insert] } bind TkConsolePost <Key-quotedbl> { if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ [string compare \\ [%W get insert-2c]]} { ::tkcon::MatchQuote %W limit } set ::tkcon::PRIV(StatusCursor) [%W index insert] } bind TkConsolePost <KeyPress> { if {[winfo exists "%W"]} { if {$::tkcon::OPT(lightcmd) && [string compare {} %A]} { ::tkcon::TagProc %W } set ::tkcon::PRIV(StatusCursor) [%W index insert] } } bind TkConsolePost <Button-1> { set ::tkcon::PRIV(StatusCursor) [%W index insert] } bind TkConsolePost <B1-Motion> { set ::tkcon::PRIV(StatusCursor) [%W index insert] } } ## # ::tkcon::PopupMenu - what to do when the popup menu is requested ## proc ::tkcon::PopupMenu {X Y} { variable PRIV variable OPT set w $PRIV(console) if {[string compare $w [winfo containing $X $Y]]} { tk_popup $PRIV(popup) $X $Y return } set x [expr {$X-[winfo rootx $w]}] set y [expr {$Y-[winfo rooty $w]}] if {[llength [set tags [$w tag names @$x,$y]]]} { if {[lsearch -exact $tags "proc"] >= 0} { lappend type "proc" foreach {first last} [$w tag prevrange proc @$x,$y] { set word [$w get $first $last]; break } } if {[lsearch -exact $tags "var"] >= 0} { lappend type "var" foreach {first last} [$w tag prevrange var @$x,$y] { set word [$w get $first $last]; break } } } if {![info exists type]} { set exp "(^|\[^\\\\\]\[ \t\n\r\])" set exp2 "\[\[\\\\\\?\\*\]" set i [$w search -backwards -regexp $exp @$x,$y "@$x,$y linestart"] if {[string compare {} $i]} { if {![string match *.0 $i]} {append i +2c} if {[string compare {} \ [set j [$w search -regexp $exp $i "$i lineend"]]]} { append j +1c } else { set j "$i lineend" } regsub -all $exp2 [$w get $i $j] {\\\0} word set word [string trim $word {\"$[]{}',?#*}] if {[llength [EvalAttached [list info commands $word]]]} { lappend type "proc" } if {[llength [EvalAttached [list info vars $word]]]} { lappend type "var" } if {[EvalAttached [list file isfile $word]]} { lappend type "file" } } } if {![info exists type] || ![info exists word]} { tk_popup $PRIV(popup) $X $Y return } $PRIV(context) delete 0 end $PRIV(context) add command -label "$word" -state disabled $PRIV(context) add separator set app [Attach] if {[lsearch $type proc] != -1} { $PRIV(context) add command -label "View Procedure" \ -command [list $OPT(edit) -attach $app -type proc -- $word] } if {[lsearch $type var] != -1} { $PRIV(context) add command -label "View Variable" \ -command [list $OPT(edit) -attach $app -type var -- $word] } if {[lsearch $type file] != -1} { $PRIV(context) add command -label "View File" \ -command [list $OPT(edit) -attach $app -type file -- $word] } tk_popup $PRIV(context) $X $Y } ## ::tkcon::TagProc - tags a procedure in the console if it's recognized ## This procedure is not perfect. However, making it perfect wastes ## too much CPU time... ## proc ::tkcon::TagProc w { set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" set i [$w search -backwards -regexp $exp insert-1c limit-1c] if {[string compare {} $i]} {append i +2c} else {set i limit} regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c if {[llength [EvalAttached [list info commands $c]]]} { $w tag add proc $i "insert-1c wordend" } else { $w tag remove proc $i "insert-1c wordend" } if {[llength [EvalAttached [list info vars $c]]]} { $w tag add var $i "insert-1c wordend" } else { $w tag remove var $i "insert-1c wordend" } } ## ::tkcon::MatchPair - blinks a matching pair of characters ## c2 is assumed to be at the text index 'insert'. ## This proc is really loopy and took me an hour to figure out given ## all possible combinations with escaping except for escaped \'s. ## It doesn't take into account possible commenting... Oh well. If ## anyone has something better, I'd like to see/use it. This is really ## only efficient for small contexts. # ARGS: w - console text widget # c1 - first char of pair # c2 - second char of pair # Calls: ::tkcon::Blink ## proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} { if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { while { [string match {\\} [$w get $ix-1c]] && [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] } {} set i1 insert-1c while {[string compare {} $ix]} { set i0 $ix set j 0 while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} { append i0 +1c if {[string match {\\} [$w get $i0-2c]]} continue incr j } if {!$j} break set i1 $ix while {$j && [string compare {} \ [set ix [$w search -back $c1 $ix $lim]]]} { if {[string match {\\} [$w get $ix-1c]]} continue incr j -1 } } if {[string match {} $ix]} { set ix [$w index $lim] } } else { set ix [$w index $lim] } if {$::tkcon::OPT(blinkrange)} { Blink $w $ix [$w index insert] } else { Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] } } ## ::tkcon::MatchQuote - blinks between matching quotes. ## Blinks just the quote if it's unmatched, otherwise blinks quoted string ## The quote to match is assumed to be at the text index 'insert'. # ARGS: w - console text widget # Calls: ::tkcon::Blink ## proc ::tkcon::MatchQuote {w {lim 1.0}} { set i insert-1c set j 0 while {[string compare [set i [$w search -back \" $i $lim]] {}]} { if {[string match {\\} [$w get $i-1c]]} continue if {!$j} {set i0 $i} incr j } if {$j&1} { if {$::tkcon::OPT(blinkrange)} { Blink $w $i0 [$w index insert] } else { Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] } } else { Blink $w [$w index insert-1c] [$w index insert] } } ## ::tkcon::Blink - blinks between n index pairs for a specified duration. # ARGS: w - console text widget # i1 - start index to blink region # i2 - end index of blink region # dur - duration in usecs to blink for # Outputs: blinks selected characters in $w ## proc ::tkcon::Blink {w args} { eval [list $w tag add blink] $args after $::tkcon::OPT(blinktime) [list $w] tag remove blink $args return } ## ::tkcon::Insert ## Insert a string into a text console at the point of the insertion cursor. ## If there is a selection in the text, and it covers the point of the ## insertion cursor, then delete the selection before inserting. # ARGS: w - text window in which to insert the string # s - string to insert (usually just a single char) # Outputs: $s to text widget ## proc ::tkcon::Insert {w s} { if {[string match {} $s] || [string match disabled [$w cget -state]]} { return } variable EXP if {[info exists EXP(spawn_id)]} { exp_send -i $EXP(spawn_id) -- $s return } if {[$w comp insert < limit]} { $w mark set insert end } if {[llength [$w tag ranges sel]] && \ [$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { $w delete sel.first sel.last } $w insert insert $s $w see insert } ## ::tkcon::Expand - # ARGS: w - text widget in which to expand str # type - type of expansion (path / proc / variable) # Calls: ::tkcon::Expand(Pathname|Procname|Variable) # Outputs: The string to match is expanded to the longest possible match. # If ::tkcon::OPT(showmultiple) is non-zero and the user longest # match equaled the string to expand, then all possible matches # are output to stdout. Triggers bell if no matches are found. # Returns: number of matches found ## proc ::tkcon::Expand {w {type ""}} { set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"$\]" set tmp [$w search -backwards -regexp $exp insert-1c limit-1c] if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit} set str [$w get $tmp insert] # Expand procs can return "break" to indicate not to try further # matches, otherwise "continue" says "I got nothing, continue on" # We can ignore return codes from the specific expand type checks switch -glob $type { pa* { set code [catch {ExpandPathname $str} res] } pr* { set code [catch {ExpandProcname $str} res] } v* { set code [catch {ExpandVariable $str} res] } default { # XXX could be extended to allow the results of all matches # XXX to be amalgamted ... may be confusing to user set res {} foreach t $::tkcon::OPT(expandorder) { set code [catch {Expand$t $str} res] if {$code == 0 || $code == 3} { break } set res {} } } } set len [llength $res] if {$len} { $w delete $tmp insert $w insert $tmp [lindex $res 0] if {$len > 1} { if {$::tkcon::OPT(showmultiple) && \ ![string compare [lindex $res 0] $str]} { puts stdout [lsort [lreplace $res 0 0]] } } } else { bell } return [incr len -1] } ## ::tkcon::ExpandPathname - expand a file pathname based on $str ## This is based on UNIX file name conventions # ARGS: str - partial file pathname to expand # Calls: ::tkcon::ExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches ## proc ::tkcon::ExpandPathname str { # require at least a single character, otherwise continue if {$str eq ""} {return -code continue} set pwd [EvalAttached pwd] # Cause a string like {C:/Program\ Files/} to become "C:/Program Files/" regsub -all {\\([][ ])} $str {\1} str if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { return -code error $err } set dir [file tail $str] ## Check to see if it was known to be a directory and keep the trailing ## slash if so (file tail cuts it off) if {[string match */ $str]} { append dir / } # Create a safely glob-able name regsub -all {([][])} $dir {\\\1} safedir if {[catch {lsort [EvalAttached [list glob $safedir*]]} m]} { set match {} } else { if {[llength $m] > 1} { global tcl_platform if {[string match windows $tcl_platform(platform)]} { ## Windows is screwy because it's case insensitive set tmp [ExpandBestMatch [string tolower $m] \ [string tolower $dir]] ## Don't change case if we haven't changed the word if {[string length $dir]==[string length $tmp]} { set tmp $dir } } else { set tmp [ExpandBestMatch $m $dir] } if {[string match */* $str]} { set tmp [string trimright [file dirname $str] /]/$tmp } regsub -all {([^\\])([][ ])} $tmp {\1\\\2} tmp set match [linsert $m 0 $tmp] } else { ## This may look goofy, but it handles spaces in path names eval append match $m if {[file isdirectory $match]} {append match /} if {[string match */* $str]} { set match [string trimright [file dirname $str] /]/$match } regsub -all {([^\\])([][ ])} $match {\1\\\2} match ## Why is this one needed and the ones below aren't!! set match [list $match] } } EvalAttached [list cd $pwd] return -code [expr {$match eq "" ? "continue" : "break"}] $match } ## ::tkcon::ExpandProcname - expand a tcl proc name based on $str # ARGS: str - partial proc name to expand # Calls: ::tkcon::ExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches ## proc ::tkcon::ExpandProcname str { # require at least a single character, otherwise continue if {$str eq ""} {return -code continue} set match [EvalAttached [list info commands $str*]] if {[llength $match] == 0} { set ns [EvalAttached \ "namespace children \[namespace current\] [list $str*]"] if {[llength $ns]==1} { set match [EvalAttached [list info commands ${ns}::*]] } else { set match $ns } } if {[llength $match] > 1} { regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str set match [linsert $match 0 $str] } else { regsub -all {([^\\]) } $match {\1\\ } match } return -code [expr {$match eq "" ? "continue" : "break"}] $match } ## ::tkcon::ExpandMethodname - expand an NSF/XOTcl method name based on $str # ARGS: str - partial proc name to expand # Calls: ::tkcon::ExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches ## proc ::tkcon::ExpandMethodname str { # In a first step, obtain the typed-in cmd from the console set typedCmd [::tkcon::CmdGet $::tkcon::PRIV(console)] set obj [lindex $typedCmd 0] if {$obj eq $typedCmd} { # just a single word, can't be a method expansion return -code continue } # Get the full string after the object set sub [string trimleft [string range $typedCmd [string length [list $obj]] end]] if {[EvalAttached [list info exists ::nsf::version]]} { # Next Scripting Framework is loaded if {![EvalAttached [list ::nsf::object::exists $obj]]} {return -code continue} if {[string match ::* $sub]} { # NSF allows dispatch of unregistered methods via absolute # paths set cmd "concat \[info commands $sub*\] \[namespace children \[namespace qualifiers $sub\] $sub*\]" } else { set cmd [list $obj ::nsf::methods::object::info::lookupmethods -callprotection public -path -- $sub*] } } elseif {[EvalAttached [list info exists ::xotcl::version]]} { # XOTcl < 2.* is loaded if {![EvalAttached [list ::xotcl::Object isobject $obj]]} {return -code continue} set cmd [list $obj info methods $sub*] } else { # No NSF/XOTcl loaded return -code continue } set match [EvalAttached $cmd] if {[llength $match] > 1} { regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } bestMatch if {$str eq "" && [string match "* " $bestMatch]} { set match [linsert $match 0 ""] } else { regsub -all {\\ } $bestMatch { } bestMatch set match [linsert $match 0 [lindex $bestMatch end]] } } else { set match [lindex [lindex $match 0] end] } return -code break $match } ## ::tkcon::ExpandVariable - expand a tcl variable name based on $str # ARGS: str - partial tcl var name to expand # Calls: ::tkcon::ExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches ## proc ::tkcon::ExpandVariable str { # require at least a single character, otherwise continue if {$str eq ""} {return -code continue} if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { ## Looks like they're trying to expand an array. set match [EvalAttached [list array names $ary $str*]] if {[llength $match] > 1} { set vars $ary\([ExpandBestMatch $match $str] foreach var $match {lappend vars $ary\($var\)} return $vars } elseif {[llength $match] == 1} { set match $ary\($match\) } ## Space transformation avoided for array names. } else { set match [EvalAttached [list info vars $str*]] if {[llength $match] > 1} { regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str set match [linsert $match 0 $str] } else { regsub -all {([^\\]) } $match {\1\\ } match } } return -code [expr {$match eq "" ? "continue" : "break"}] $match } ## ::tkcon::ExpandBestMatch2 - finds the best unique match in a list of names ## Improves upon the speed of the below proc only when $l is small ## or $e is {}. $e is extra for compatibility with proc below. # ARGS: l - list to find best unique match in # Returns: longest unique match in the list ## proc ::tkcon::ExpandBestMatch2 {l {e {}}} { set s [lindex $l 0] if {[llength $l]>1} { set i [expr {[string length $s]-1}] foreach l $l { while {$i>=0 && [string first $s $l]} { set s [string range $s 0 [incr i -1]] } } } return $s } ## ::tkcon::ExpandBestMatch - finds the best unique match in a list of names ## The extra $e in this argument allows us to limit the innermost loop a ## little further. This improves speed as $l becomes large or $e becomes long. # ARGS: l - list to find best unique match in # e - currently best known unique match # Returns: longest unique match in the list ## proc ::tkcon::ExpandBestMatch {l {e {}}} { set ec [lindex $l 0] if {[llength $l]>1} { set e [string length $e]; incr e -1 set ei [string length $ec]; incr ei -1 foreach l $l { while {$ei>=$e && [string first $ec $l]} { set ec [string range $ec 0 [incr ei -1]] } } } return $ec } # Here is a group of functions that is only used when Tkcon is # executed in a safe interpreter. It provides safe versions of # missing functions. For example: # # - "tk appname" returns "tkcon.tcl" but cannot be set # - "toplevel" is equivalent to 'frame', only it is automatically # packed. # - The 'source', 'load', 'open', 'file' and 'exit' functions are # mapped to corresponding functions in the parent interpreter. # # Further on, Tk cannot be really loaded. Still the safe 'load' # provedes a speciall case. The Tk can be divided into 4 groups, # that each has a safe handling procedure. # # - "::tkcon::SafeItem" handles commands like 'button', 'canvas' ...... # Each of these functions has the window name as first argument. # - "::tkcon::SafeManage" handles commands like 'pack', 'place', 'grid', # 'winfo', which can have multiple window names as arguments. # - "::tkcon::SafeWindow" handles all windows, such as '.'. For every # window created, a new alias is formed which also is handled by # this function. # - Other (e.g. bind, bindtag, image), which need their own function. # ## These functions courtesy Jan Nijtmans ## if {![llength [info commands tk]]} { proc tk {option args} { if {![string match app* $option]} { error "wrong option \"$option\": should be appname" } return "tkcon.tcl" } } if {![llength [info command toplevel]]} { proc toplevel {name args} { eval [linsert $args 0 frame $name] grid $name -sticky news } } proc ::tkcon::SafeSource {i f} { set fd [open $f r] set r [read $fd] close $fd if {[catch {interp eval $i $r} msg]} { error $msg } } proc ::tkcon::SafeOpen {i f {m r}} { set fd [open $f $m] interp transfer {} $fd $i return $fd } proc ::tkcon::SafeLoad {i f p} { global tk_version tk_patchLevel tk_library auto_path if {[string compare $p Tk]} { load $f $p $i } else { foreach command {button canvas checkbutton entry frame label listbox message radiobutton scale scrollbar spinbox text toplevel} { $i alias $command ::tkcon::SafeItem $i $command } $i alias image ::tkcon::SafeImage $i foreach command {pack place grid destroy winfo} { $i alias $command ::tkcon::SafeManage $i $command } if {[llength [info command event]]} { $i alias event ::tkcon::SafeManage $i $command } frame .${i}_dot -width 300 -height 300 -relief raised pack .${i}_dot -side left $i alias tk tk $i alias bind ::tkcon::SafeBind $i $i alias bindtags ::tkcon::SafeBindtags $i $i alias . ::tkcon::SafeWindow $i {} foreach var {tk_version tk_patchLevel tk_library auto_path} { $i eval [list set $var [set $var]] } $i eval { package provide Tk $tk_version if {[lsearch -exact $auto_path $tk_library] < 0} { lappend auto_path $tk_library } } return "" } } proc ::tkcon::SafeSubst {i a} { set arg1 "" foreach {arg value} $a { if {![string compare $arg -textvariable] || ![string compare $arg -variable]} { set newvalue "[list $i] $value" global $newvalue if {[interp eval $i info exists $value]} { set $newvalue [interp eval $i set $value] } else { catch {unset $newvalue} } $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\} set value $newvalue } elseif {![string compare $arg -command]} { set value [list $i eval $value] } lappend arg1 $arg $value } return $arg1 } proc ::tkcon::SafeItem {i command w args} { set args [::tkcon::SafeSubst $i $args] set code [catch "$command [list .${i}_dot$w] $args" msg] $i alias $w ::tkcon::SafeWindow $i $w regsub -all .${i}_dot $msg {} msg return -code $code $msg } proc ::tkcon::SafeManage {i command args} { set args1 "" foreach arg $args { if {[string match . $arg]} { set arg .${i}_dot } elseif {[string match .* $arg]} { set arg ".${i}_dot$arg" } lappend args1 $arg } set code [catch "$command $args1" msg] regsub -all .${i}_dot $msg {} msg return -code $code $msg } # # FIX: this function doesn't work yet if the binding starts with '+'. # proc ::tkcon::SafeBind {i w args} { if {[string match . $w]} { set w .${i}_dot } elseif {[string match .* $w]} { set w ".${i}_dot$w" } if {[llength $args] > 1} { set args [list [lindex $args 0] \ "[list $i] eval [list [lindex $args 1]]"] } set code [catch "bind $w $args" msg] if {[llength $args] <2 && $code == 0} { set msg [lindex $msg 3] } return -code $code $msg } proc ::tkcon::SafeImage {i option args} { set code [catch "image $option $args" msg] if {[string match cr* $option]} { $i alias $msg $msg } return -code $code $msg } proc ::tkcon::SafeBindtags {i w {tags {}}} { if {[string match . $w]} { set w .${i}_dot } elseif {[string match .* $w]} { set w ".${i}_dot$w" } set newtags {} foreach tag $tags { if {[string match . $tag]} { lappend newtags .${i}_dot } elseif {[string match .* $tag]} { lappend newtags ".${i}_dot$tag" } else { lappend newtags $tag } } if {[string match $tags {}]} { set code [catch {bindtags $w} msg] regsub -all \\.${i}_dot $msg {} msg } else { set code [catch {bindtags $w $newtags} msg] } return -code $code $msg } proc ::tkcon::SafeWindow {i w option args} { if {[string match conf* $option] && [llength $args] > 1} { set args [::tkcon::SafeSubst $i $args] } elseif {[string match itemco* $option] && [llength $args] > 2} { set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]" } elseif {[string match cr* $option]} { if {[llength $args]%2} { set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]" } else { set args [::tkcon::SafeSubst $i $args] } } elseif {[string match bi* $option] && [llength $args] > 2} { set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"] } set code [catch ".${i}_dot$w $option $args" msg] if {$code} { regsub -all .${i}_dot $msg {} msg } elseif {[string match conf* $option] || [string match itemco* $option]} { if {[llength $args] == 1} { switch -- $args { -textvariable - -variable { set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]" } -command - updatecommand { set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]" } } } elseif {[llength $args] == 0} { set args1 "" foreach el $msg { switch -- [lindex $el 0] { -textvariable - -variable { set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]" } -command - updatecommand { set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]" } } lappend args1 $el } set msg $args1 } } elseif {[string match cg* $option] || [string match itemcg* $option]} { switch -- $args { -textvariable - -variable { set msg [lrange $msg 1 end] } -command - updatecommand { set msg [lindex $msg 2] } } } elseif {[string match bi* $option]} { if {[llength $args] == 2 && $code == 0} { set msg [lindex $msg 2] } } return -code $code $msg } proc ::tkcon::RetrieveFilter {host} { variable PRIV set result {} if {[info exists PRIV(proxy)]} { if {![regexp "^(localhost|127\.0\.0\.1)" $host]} { set result [lrange [split [lindex $PRIV(proxy) 0] :] 0 1] } } return $result } proc ::tkcon::RetrieveAuthentication {} { package require Tk if {[catch {package require base64}]} { if {[catch {package require Trf}]} { error "base64 support not available" } else { set local64 "base64 -mode enc" } } else { set local64 "base64::encode" } set dlg [toplevel .auth] catch {wm attributes $dlg -type dialog} wm title $dlg "Authenticating Proxy Configuration" set f1 [frame ${dlg}.f1] set f2 [frame ${dlg}.f2] button $f2.b -text "OK" -command "destroy $dlg" pack $f2.b -side right label $f1.l2 -text "Username" label $f1.l3 -text "Password" entry $f1.e2 -textvariable "[namespace current]::conf_userid" entry $f1.e3 -textvariable "[namespace current]::conf_passwd" -show * grid $f1.l2 -column 0 -row 0 -sticky e grid $f1.l3 -column 0 -row 1 -sticky e grid $f1.e2 -column 1 -row 0 -sticky news grid $f1.e3 -column 1 -row 1 -sticky news grid columnconfigure $f1 1 -weight 1 pack $f2 -side bottom -fill x pack $f1 -side top -anchor n -fill both -expand 1 tkwait window $dlg set result {} if {[info exists [namespace current]::conf_userid]} { set data [subst $[namespace current]::conf_userid] append data : [subst $[namespace current]::conf_passwd] set data [$local64 $data] set result [list "Proxy-Authorization" "Basic $data"] } unset [namespace current]::conf_passwd return $result } proc ::tkcon::Retrieve {} { # A little bit'o'magic to grab the latest tkcon from CVS and # save it locally. It doesn't support proxies though... variable PRIV set defExt "" if {[string match "windows" $::tcl_platform(platform)]} { set defExt ".tcl" } set file [tk_getSaveFile -title "Save Latest tkcon to ..." \ -defaultextension $defExt \ -initialdir [file dirname $PRIV(SCRIPT)] \ -initialfile [file tail $PRIV(SCRIPT)] \ -parent $PRIV(root) \ -filetypes {{"Tcl Files" {.tcl .tk}} {"All Files" {*.*}}}] if {[string compare $file ""]} { package require http 2 set headers {} if {[info exists PRIV(proxy)]} { ::http::config -proxyfilter [namespace origin RetrieveFilter] if {[lindex $PRIV(proxy) 1] != {}} { set headers [RetrieveAuthentication] } } set token [::http::geturl $PRIV(HEADURL) \ -headers $headers -timeout 30000] ::http::wait $token set code [catch { set ncode [::http::ncode $token] set i 0 while {(($ncode >= 301) && ($ncode <= 307)) && [incr i] < 5} { # redirect to meta Location array set meta [::http::meta $token] ::http::cleanup $token if {![info exists meta(Location)]} { break } set url $meta(Location) if {![string match "http*" $url] && [regexp {https?://[^/]+} $PRIV(HEADURL) srvr]} { # attach the same http server info set url $srvr/$url } set token [::http::geturl $url -headers $headers -timeout 30000] ::http::wait $token set ncode [::http::ncode $token] } if {$ncode != 200} { return "expected http return code 200, received $ncode" } set status [::http::status $token] if {$status == "ok"} { set data [::http::data $token] regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion regexp {VERSION\s+"(\d+\.\d+[^\"]*)"} $data -> tkconVersion if {(![info exists rcsVersion] || ![info exists tkconVersion]) && [tk_messageBox -type yesno -icon warning \ -parent $PRIV(root) \ -title "Invalid tkcon source code" \ -message "Source code retrieved does not appear\ to be correct.\nContinue with save to \"$file\"?"] \ == "no"} { return "invalid tkcon source code retrieved" } set fid [open $file w] # We don't want newline mode to change fconfigure $fid -translation binary puts -nonewline $fid $data close $fid } else { return "expected http status ok, received $status" } } err] ::http::cleanup $token if {$code == 2} { tk_messageBox -type ok -icon info -parent $PRIV(root) \ -title "Failed to retrieve source" \ -message "Failed to retrieve latest tkcon source:\n$err\n$PRIV(HEADURL)" } elseif {$code} { return -code error $err } else { if {![info exists rcsVersion]} { set rcsVersion "UNKNOWN" } if {![info exists tkconVersion]} { set tkconVersion "UNKNOWN" } if {[tk_messageBox -type yesno -icon info -parent $PRIV(root) \ -title "Retrieved tkcon v$tkconVersion, RCS $rcsVersion" \ -message "Successfully retrieved tkcon v$tkconVersion,\ RCS $rcsVersion. Shall I resource (not restart) this\ version now?"] == "yes"} { set PRIV(SCRIPT) $file set PRIV(version) $tkconVersion.$rcsVersion ::tkcon::Resource } } } } ## 'send' package that handles multiple communication variants ## # Try using Tk send first, then look for a winsend interp, # then try dde and finally have a go at comm namespace eval ::send {} proc ::send::send {args} { set winfoInterpCmd [list ::winfo interps] array set opts [list displayof {} async 0] while {[string match -* [lindex $args 0]]} { switch -exact -- [lindex $args 0] { -displayof { set opts(displayof) [Pop args 1] lappend winfoInterpCmd -displayof $opts(displayof) } -async { set opts(async) 1 } -- { Pop args ; break } default { return -code error "bad option \"[lindex $args 0]\":\ should be -displayof, -async or --" } } Pop args } set app [Pop args] if {[llength [info commands ::winfo]] && [lsearch -exact [eval $winfoInterpCmd] $app] > -1} { set cmd [list ::send] if {$opts(async) == 1} {lappend cmd -async} if {$opts(displayof) != {}} {lappend cmd -displayof $opts(displayof)} lappend cmd $app eval $cmd $args } elseif {[llength [info commands ::winsend]] && [lsearch -exact [::winsend interps] $app] > -1} { eval [list ::winsend send $app] $args } elseif {[llength [info commands ::dde]] && [lsearch -exact [dde services TclEval {}] \ [list TclEval $app]] > -1} { eval [list ::dde eval $app] $args } elseif {[package provide comm] != {} && [regexp {^[0-9]+$} [lindex $app 0]]} { #if {$opts(displayof) != {} && [llength $app] == 1} { # lappend app $opts(displayof) #} eval [list ::comm::comm send $app] $args } else { return -code error "bad interp: \"$app\" could not be found" } } proc ::send::interps {args} { set winfoInterpCmd [list ::winfo interps] array set opts [list displayof {}] while {[string match -* [lindex $args 0]]} { switch -exact -- [lindex $args 0] { -displayof { set opts(displayof) [Pop args 1] lappend winfoInterpCmd -displayof $opts(displayof) } -- { Pop args ; break } default { return -code error "bad option \"[lindex $args 0]\":\ should be -displayof or --" } } Pop args } set interps {} if {[llength [info commands ::winfo]]} { set interps [concat $interps [eval $winfoInterpCmd]] } if {[llength [info commands ::winsend]]} { set interps [concat $interps [::winsend interps]] } if {[llength [info commands ::dde]]} { set servers {} foreach server [::dde services TclEval {}] { lappend servers [lindex $server 1] } set interps [concat $interps $servers] } if {[package provide comm] != {}} { set interps [concat $interps [::comm::comm interps]] } return $interps } proc ::send::appname {args} { set appname {} if {[llength [info commands ::tk]]} { set appname [eval ::tk appname $args] } if {[llength [info commands ::winsend]]} { set appname [concat $appname [eval ::winsend appname $args]] } if {[llength [info commands ::dde]]} { set appname [concat $appname [eval ::dde servername $args]] } # comm? can set port num and local/global interface. return [lsort -unique $appname] } proc ::send::Pop {varname {nth 0}} { upvar $varname args set r [lindex $args $nth] set args [lreplace $args $nth $nth] return $r } ## ## end 'send' package ## special case 'tk appname' in Tcl plugin if {$::tkcon::PRIV(WWW)} { rename tk ::tkcon::_tk proc tk {cmd args} { if {$cmd == "appname"} { return "tkcon/WWW" } else { return [uplevel 1 ::tkcon::_tk [list $cmd] $args] } } } ## ::tkcon::Resource - re'source's this script into current console ## Meant primarily for my development of this program. It follows ## links until the ultimate source is found. ## proc ::tkcon::Resource {} { uplevel \#0 { if {[catch {source -rsrc tkcon}]} { source $::tkcon::PRIV(SCRIPT) } } Bindings InitSlave $::tkcon::OPT(exec) } ## Initialize only if we haven't yet, and do other stuff that prepares to ## run. It only actually inits (and runs) tkcon if it is the main script. ## proc ::tkcon::AtSource {} { variable PRIV # the info script assumes we always call this while being sourced set PRIV(SCRIPT) [info script] if {!$PRIV(WWW) && [string length $PRIV(SCRIPT)]} { if {[info tclversion] >= 8.4} { set PRIV(SCRIPT) [file normalize $PRIV(SCRIPT)] } else { # we use a catch here because some wrap apps choke on 'file type' # because TclpLstat wasn't wrappable until 8.4. catch { while {[string match link [file type $PRIV(SCRIPT)]]} { set link [file readlink $PRIV(SCRIPT)] if {[string match relative [file pathtype $link]]} { set PRIV(SCRIPT) \ [file join [file dirname $PRIV(SCRIPT)] $link] } else { set PRIV(SCRIPT) $link } } catch {unset link} if {[string match relative [file pathtype $PRIV(SCRIPT)]]} { set PRIV(SCRIPT) [file join [pwd] $PRIV(SCRIPT)] } } } } # normalize argv0 if it was tkcon to ensure that we'll be able # to load slaves correctly. if {[info exists ::argv0] && [info script] == $::argv0} { set ::argv0 $PRIV(SCRIPT) } if {(![info exists PRIV(root)] || ![winfo exists $PRIV(root)]) \ && ([info exists ::argv0] && $PRIV(SCRIPT) == $::argv0)} { global argv if {[info exists argv]} { eval ::tkcon::Init $argv } else { ::tkcon::Init } } } tkcon::AtSource package provide tkcon $::tkcon::VERSION
Locations
Projects
Search
Status Monitor
Help
OpenBuildService.org
Documentation
API Documentation
Code of Conduct
Contact
Support
@OBShq
Terms
openSUSE Build Service is sponsored by
The Open Build Service is an
openSUSE project
.
Sign Up
Log In
Places
Places
All Projects
Status Monitor