tkcon.tcl

来自「算断裂的」· TCL 代码 · 共 2,077 行 · 第 1/5 页

#!/bin/sh
# \
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 <[e-mail]>, Jan Nijtmans <[e-mail]>
## Crimmins <[e-mail]>, Wart <[e-mail]>
##
## Copyright 1995-1999 Jeffrey Hobbs
## Initiated: Thu Aug 17 15:36:47 PDT 1995
##
## [e-mail]
##
## source standard_disclaimer.tcl
## source bourbon_ware.tcl
##

## FIX NOTES - ideas on the block:
## can tkConSplitCmd be used for debugging?
## can return/error be overridden for debugging?

if {$tcl_version>=8.0} {
    package require -exact Tk $tcl_version
} elseif {[catch {package require -exact Tk [expr {$tcl_version-3.4}]}]} {
    return -code error "TkCon requires at least Tcl7.6/Tk4.2"
}

catch {package require bogus-package-name}
foreach pkg [info loaded {}] {
    set file [lindex $pkg 0]
    set name [lindex $pkg 1]
    if {![catch {set version [package require $name]}]} {
	if {[string match {} [package ifneeded $name $version]]} {
	    package ifneeded $name $version [list load $file $name]
	}
    }
}
catch {unset pkg file name version}

set TKCON(WWW) [info exists embed_args]

## tkConInit - inits tkCon
#
# Calls:	tkConInitUI
# Outputs:	errors found in tkCon resource file
##
;proc tkConInit {} {
    global auto_path tcl_platform env tcl_pkgPath \
	    TKCON argc argv tcl_interactive errorInfo

    if {![info exists argv]} {
	set argv {}
	set argc 0
    }

    set tcl_interactive 1

    if {[info exists TKCON(name)]} {
	set title $TKCON(name)
    } else {
	tkConMainInit
	set title Main
    }

    # get bg color from the main toplevel
    array set TKCON {
	color,bg	{}
	color,blink	\#FFFF00
	color,cursor	\#000000
	color,disabled	\#4D4D4D
	color,proc	\#008800
	color,var	\#FFC0D0
	color,prompt	\#8F4433
	color,stdin	\#000000
	color,stdout	\#0000FF
	color,stderr	\#FF0000

	autoload	{}
	blinktime	500
	blinkrange	1
	buffer		512
	calcmode	0
	cols		80
	debugPrompt	{(level \#$level) debug [history nextid] > }
	dead		{}
	expandorder	{Pathname Variable Procname}
	font		{}
	history		48
	hoterrors	1
	library		{}
	lightbrace	1
	lightcmd	1
	maineval	{}
	maxmenu		15
	nontcl		0
	rows		20
	scrollypos	right
	showmenu	1
	showmultiple	1
	slaveeval	{}
	slaveexit	close
	subhistory	1

	exec		slave
	app		{}
	appname		{}
	apptype		slave
	namesp		::
	cmd		{}
	cmdbuf		{}
	cmdsave		{}
	event		1
	deadapp		0
	deadsock	0
	debugging	0
	gc-delay	60000
	histid		0
	find		{}
	find,case	0
	find,reg	0
	errorInfo	{}
	slavealias	{ edit more less tkcon }
	slaveprocs	{
	    alias clear dir dump echo idebug lremove
	    tkcon_puts tclindex observe observe_var unalias which what
	}
	version		1.6
	release		{31 March 1999}
	docs		"http://www.purl.org/net/hobbs/tcl/script/tkcon/\nhttp://www.hobbs.wservice.com/tcl/script/tkcon/"
	email		{[e-mail]}
	root		.
    }
    ## NOTES FOR STAYING IN PRIMARY INTERPRETER:
    ## If you set TKCON(exec) to {}, then instead of a multiple interpreter
    ## 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 TKCON(exec) {}

    if {$TKCON(WWW)} {
	lappend TKCON(slavealias) history
	set TKCON(prompt1) {[history nextid] % }
    } else {
	lappend TKCON(slaveprocs) tcl_unknown unknown
	set TKCON(prompt1) {([file tail [pwd]]) [history nextid] % }
    }

    ## If there appear to be children of '.', then make sure we use
    ## a disassociated toplevel.
    if {[llength [winfo children .]]} {
	set TKCON(root) .tkcon
    }

    ## Do platform specific configuration here
    ### Use tkcon.cfg filename for resource filename on non-unix systems
    ### Determine what directory the resource file should be in
    ### Windows could possibly use env(WINDIR)
    switch $tcl_platform(platform) {
	macintosh	{
	    set envHome PREF_FOLDER
	    cd [file dirname [info script]]
	    set TKCON(rcfile) tkcon.cfg
	}
	windows		{
	    set envHome HOME
	    set TKCON(rcfile) tkcon.cfg
	}
	unix		{
	    set envHome HOME
	    set TKCON(rcfile) .tkconrc
	}
    }
    if {[info exists env($envHome)]} {
	set TKCON(rcfile) [file join $env($envHome) $TKCON(rcfile)]
    }

    ## 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 $argv -rcfile]] != -1} {
	set TKCON(rcfile) [lindex $argv [incr i]]
    }

    if {!$TKCON(WWW) && [file exists $TKCON(rcfile)]} {
	set code [catch [list uplevel \#0 source $TKCON(rcfile)] err]
    }

    if {[info exists env(TK_CON_LIBRARY)]} {
	uplevel \#0 lappend auto_path $env(TK_CON_LIBRARY)
    } else {
	uplevel \#0 lappend auto_path $TKCON(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 truth {^(1|yes|true|on)$}
    for {set i 0} {$i < $argc} {incr i} {
	set arg [lindex $argv $i]
	if {[string match {-*} $arg]} {
	    set val [lindex $argv [incr i]]
	    ## Handle arg based options
	    switch -glob -- $arg {
		-- - -argv	{
		    set argv [concat -- [lrange $argv $i end]]
		    set argc [llength $argv]
		    break
		}
		-color,*	{ set TKCON([string range $arg 1 end]) $val }
		-exec	{ set TKCON(exec) $val }
		-main - -e - -eval	{ append TKCON(maineval) \n$val\n }
		-package - -load	{ lappend TKCON(autoload) $val }
		-slave	{ append TKCON(slaveeval) \n$val\n }
		-nontcl	{ set TKCON(nontcl) [regexp -nocase $truth $val] }
		-root	{ set TKCON(root) $val }
		-font	{ set TKCON(font) $val }
		-rcfile	{}
		default	{ lappend slaveargs $arg; incr i -1 }
	    }
	} elseif {[file isfile $arg]} {
	    lappend slavefiles $arg
	} else {
	    lappend slaveargs $arg
	}
    }

    ## Create slave executable
    if {[string compare {} $TKCON(exec)]} {
	uplevel \#0 tkConInitSlave $TKCON(exec) $slaveargs
    } else {
	set argc [llength $slaveargs]
	set argv $slaveargs
	uplevel \#0 $slaveargs
    }
    history keep $TKCON(history)

    ## Attach to the slave, tkConEvalAttached will then be effective
    tkConAttach $TKCON(appname) $TKCON(apptype)
    tkConInitUI $title

    ## 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 {![catch {rename gets tkcon_tcl_gets}]} {
	#interp alias {} gets {} tkcon_gets
    #}

    ## Autoload specified packages in slave
    set pkgs [tkConEvalSlave package names]
    foreach pkg $TKCON(autoload) {
	puts -nonewline "autoloading package \"$pkg\" ... "
	if {[lsearch -exact $pkgs $pkg]>-1} {
	    if {[catch {tkConEvalSlave package require [list $pkg]} pkgerr]} {
		puts stderr "error:\n$pkgerr"
		append TKCON(errorInfo) $errorInfo\n
	    } else { puts "OK" }
	} else {
	    puts stderr "error: package does not exist"
	}
    }

    ## Evaluate maineval in slave
    if {[string compare {} $TKCON(maineval)] && \
	    [catch {uplevel \#0 $TKCON(maineval)} merr]} {
	puts stderr "error in eval:\n$merr"
	append TKCON(errorInfo) $errorInfo\n
    }

    ## Source extra command line argument files into slave executable
    foreach fn $slavefiles {
	puts -nonewline "slave sourcing \"$fn\" ... "
	if {[catch {tkConEvalSlave source [list $fn]} fnerr]} {
	    puts stderr "error:\n$fnerr"
	    append TKCON(errorInfo) $errorInfo\n
	} else { puts "OK" }
    }

    ## Evaluate slaveeval in slave
    if {[string compare {} $TKCON(slaveeval)] && \
	    [catch {interp eval $TKCON(exec) $TKCON(slaveeval)} serr]} {
	puts stderr "error in slave eval:\n$serr"
	append TKCON(errorInfo) $errorInfo\n
    }
    ## Output any error/output that may have been returned from rcfile
    if {[info exists code] && $code && [string compare {} $err]} {
	puts stderr "error in $TKCON(rcfile):\n$err"
	append TKCON(errorInfo) $errorInfo
    }
    if {[string compare {} $TKCON(exec)]} {
	tkConStateCheckpoint [concat $TKCON(name) $TKCON(exec)] slave
    }
    tkConStateCheckpoint $TKCON(name) slave
}

## tkConInitSlave - 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 tkConInitSlave {slave args} {
    global TKCON argv0 tcl_interactive tcl_library env
    if {[string match {} $slave]} {
	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 tkConSafeSource $slave
	$slave alias load tkConSafeLoad $slave
	$slave alias open tkConSafeOpen $slave
	$slave alias file file
	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 }
    }
    $slave alias exit exit
    interp eval $slave {
	catch {rename puts tkcon_tcl_puts}
	#catch {rename gets tkcon_tcl_gets}
	catch {package require bogus-package-name}
    }
    foreach cmd $TKCON(slaveprocs) { $slave eval [dump proc $cmd] }
    foreach cmd $TKCON(slavealias) { $slave alias $cmd $cmd }
    interp alias $slave ls $slave dir -full
    interp alias $slave puts $slave tkcon_puts
    #interp alias $slave gets $slave tkcon_gets
    if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]}
    interp eval $slave set tcl_interactive $tcl_interactive \; \
	    set argc [llength $args] \; \
	    set argv  [list $args] \; history keep $TKCON(history) \; {
	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]]
	}
    }
}

## tkConInitInterp - inits an interpreter by placing key
## procs and aliases in it.
# ARGS: name	- interp name
#	type	- interp type (slave|interp)
##
;proc tkConInitInterp {name type} {
    global TKCON
    ## Don't allow messing up a local master interpreter
    if {[string match namespace $type] || ([string match slave $type] && \
	    [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} return
    set old [tkConAttach]
    if {$TKCON(A:version) >= 8.0} { set oldname $TKCON(namesp) }
    catch {
	tkConAttach $name $type
	tkConEvalAttached {
	    catch {rename puts tkcon_tcl_puts}
	    #catch {rename gets tkcon_tcl_gets}
	}
	foreach cmd $TKCON(slaveprocs) { tkConEvalAttached [dump proc $cmd] }
	switch -exact $type {
	    slave {
		foreach cmd $TKCON(slavealias) {
		    tkConMain interp alias $name $cmd $TKCON(name) $cmd
		}
	    }
	    interp {
		set thistkcon [tk appname]
		foreach cmd $TKCON(slavealias) {
		    tkConEvalAttached "proc $cmd args { send [list $thistkcon] $cmd \$args }"
		}
	    }
	}
	## Catch in case it's a 7.4 (no 'interp alias') interp
	tkConEvalAttached {
	    catch {interp alias {} ls {} dir -full}
	    if {[catch {interp alias {} puts {} tkcon_puts}]} {
		catch {rename tkcon_puts puts}
	    }
	    #if {[catch {interp alias {} gets {} tkcon_gets}]} {
		#catch {rename tkcon_gets gets}
	    #}
	}
	return
    } {err}
    eval tkConAttach $old