From 68e1211a4b1382a292387c73e96568bd2b2b6e1e Mon Sep 17 00:00:00 2001 From: cascade Date: Fri, 25 Jun 2004 21:07:32 +0000 Subject: [PATCH] Initial revision --- src/WOKsite/.tclshrc | 2 + src/WOKsite/interp.tcl | 176 ++++++++++++++++++++++++++++++++++++++++ src/WOKsite/tclshrc.tcl | 2 + 3 files changed, 180 insertions(+) create mode 100755 src/WOKsite/.tclshrc create mode 100755 src/WOKsite/interp.tcl create mode 100755 src/WOKsite/tclshrc.tcl diff --git a/src/WOKsite/.tclshrc b/src/WOKsite/.tclshrc new file mode 100755 index 0000000..e339dbb --- /dev/null +++ b/src/WOKsite/.tclshrc @@ -0,0 +1,2 @@ +global env +source $env(HOME)/tclshrc_Wok diff --git a/src/WOKsite/interp.tcl b/src/WOKsite/interp.tcl new file mode 100755 index 0000000..53d5a93 --- /dev/null +++ b/src/WOKsite/interp.tcl @@ -0,0 +1,176 @@ +## Message-Id: <199703122050.MAA13073@cs.uoregon.edu> +## To: Jim Graham +## Subject: Re: loading of image in tk +## Date: Wed, 12 Mar 1997 12:50:06 -0800 +## From: Jeffrey Hobbs + +# Modified by Jim Graham...still a lot left to do, but..... Thanks +# to Brent Welch for the help with getting my enhancements to work, +# as well as for flat out showing me how to do some of them. :-) +# +# Thanks again to Brent Welch for helping me with yet another bug +# (one that I looked straight at, and couldn't see...). + + +proc unknown {args} { + + global auto_noexec auto_noload env unknown_pending tcl_interactive + global errorCode errorInfo + +# 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; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if {$ret != 0} { + 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 + } + } + } + +# *FIND ME* +# This is the original +# {([info level] == 1) && ([info script] == "") && [info exists tcl_interactive] && $tcl_interactive} + + if {([info level] == 1)} { + if ![info exists auto_noexec] { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set redir "" + if {[info commands console] == ""} { + set redir ">&@stdout <@stdin" + } + return [uplevel exec $redir $new [lrange $args 1 end]] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + if {$name == "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name dummy event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if [info exists newcmd] { + tclLog $newcmd + history change $newcmd 0 + return [uplevel $newcmd] + } + + set ret [catch {set cmds [info commands $name*]} msg] + 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" + } + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds] != 0} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + + +# ------------------------------ CUT HERE ------------------------------ # +############################################################################ + +# Back to interp.tcl! + +set long_command "" + +if ![info exists tcl_prompt1] { + if {[info exists jstrackrc]} { + set tcl_prompt1 {puts -nonewline "JStrack ([history nextid]) % "} + } elseif {[info exists tk_version]} { + set tcl_prompt1 {puts -nonewline "wish ([history nextid]) % "} + } else { + set tcl_prompt1 {puts -nonewline "tclsh ([history nextid]) % "} + } +} + +proc read_stdin {} { + global eventLoop tcl_prompt1 long_command jdg_hist_file + set l [gets stdin] + if {[eof stdin]} { + set eventLoop "done" ;# terminate the vwait (eventloop) + } else { + if [string compare $l ""] { + append long_command "$l" + set l $long_command + if {[info complete $l]} { + if [catch {uplevel \#0 history add [list $l] exec} err] { + puts stderr $err + } elseif {[string compare $err ""]} { + puts $err + } else { + if {[info exists jdg_hist_file]} { + set f [open $jdg_hist_file a] + puts $f $l + close $f + } + } + set long_command "" + catch $tcl_prompt1 + } else { + append long_command \n + puts -nonewline "> " + } + } elseif {[string compare $long_command ""] == 0} { + catch $tcl_prompt1 + } else { + puts -nonewline "> " + } + flush stdout + } +} + +# set up our keyboard read event handler: +# Vector stdin data to the socket + +fileevent stdin readable read_stdin + +catch $tcl_prompt1 +flush stdout +# wait for and handle or stdin events... +vwait eventLoop + + + diff --git a/src/WOKsite/tclshrc.tcl b/src/WOKsite/tclshrc.tcl new file mode 100755 index 0000000..e339dbb --- /dev/null +++ b/src/WOKsite/tclshrc.tcl @@ -0,0 +1,2 @@ +global env +source $env(HOME)/tclshrc_Wok -- 2.39.5