00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017 static const char* INIT_COMMAND =
00018 "#\n"
00019 "# This file is converted into a big C string during the build\n"
00020 "# process and evaluated in the command interpreter at startup\n"
00021 "# time.\n"
00022 "#\n"
00023 "\n"
00024 "#\n"
00025 "# For the vwait in event_loop to work, we need to make sure there's at\n"
00026 "# least one event outstanding at all times, otherwise 'vwait forever'\n"
00027 "# doesn't work\n"
00028 "#\n"
00029 "proc after_forever {} {\n"
00030 " global forever_timer\n"
00031 " set forever_timer [after 1000000 after_forever]\n"
00032 "}\n"
00033 "\n"
00034 "#\n"
00035 "# Run the event loop and no command line interpreter\n"
00036 "#\n"
00037 "proc event_loop {} {\n"
00038 " global event_loop_wait\n"
00039 " after_forever\n"
00040 " set event_loop_wait 0\n"
00041 " vwait event_loop_wait\n"
00042 " command_log notice \"exiting event loop\"\n"
00043 "}\n"
00044 "\n"
00045 "proc do_nothing {} {\n"
00046 "}\n"
00047 "\n"
00048 "#\n"
00049 "# Kill the event loop\n"
00050 "#\n"
00051 "proc exit_event_loop {} {\n"
00052 " global forever_timer event_loop_wait stdin\n"
00053 " command_log notice \"kicking event loop to exit\"\n"
00054 " set event_loop_wait 1\n"
00055 " if [catch {\n"
00056 " ::tclreadline::readline eof\n"
00057 " } err] {\n"
00058 " }\n"
00059 " after 0 do_nothing\n"
00060 "}\n"
00061 "\n"
00062 "#\n"
00063 "# Wrapper proc to handle the fact that we may or may not have a log\n"
00064 "# procedure defined\n"
00065 "#\n"
00066 "proc command_log {level string} {\n"
00067 " if {[info commands log] != \"\"} {\n"
00068 " log /command $level $string\n"
00069 " } else {\n"
00070 " puts $string\n"
00071 " }\n"
00072 "}\n"
00073 "\n"
00074 "#\n"
00075 "# Callback when there's data ready to be processed.\n"
00076 "#\n"
00077 "proc command_process {input output} {\n"
00078 " global command command_prompt command_info tell_encode event_loop_wait\n"
00079 "\n"
00080 " # Grab the line, and check for eof\n"
00081 " if {[gets $input line] == -1} {\n"
00082 " if {\"$input\" == \"stdin\"} {\n"
00083 " set event_loop_wait 1\n"
00084 " return\n"
00085 " } else {\n"
00086 " command_log debug \"closed connection $command_info($input)\"\n"
00087 " fileevent $input readable \"\"\n"
00088 " catch {close $input}\n"
00089 " return\n"
00090 " }\n"
00091 " }\n"
00092 "\n"
00093 " # handle exit from a socket connection\n"
00094 " if {($input != \"stdin\") && ($line == \"exit\")} {\n"
00095 " command_log notice \"connection $command_info($input) exiting\"\n"
00096 " fileevent $input readable \"\"\n"
00097 " catch {close $input}\n"
00098 " return\n"
00099 " }\n"
00100 " \n"
00101 " # handle tell_encode / no_tell_encode commands\n"
00102 " if {$line == \"tell_encode\"} {\n"
00103 " set tell_encode($output) 1\n"
00104 " puts $output \"\\ntell_encode\"\n"
00105 " flush $output\n"
00106 " return\n"
00107 " } elseif {$line == \"no_tell_encode\"} {\n"
00108 " set tell_encode($output) 0\n"
00109 " puts $output \"\\nno_tell_encode\"\n"
00110 " flush $output\n"
00111 " return\n"
00112 " }\n"
00113 "\n"
00114 " if {$tell_encode($output)} {\n"
00115 " # if we're in tell encoding mode, decode the message\n"
00116 "\n"
00117 " if {$command($input) != \"\"} {\n"
00118 " error \"unexpected partial command '$command($input)' in tell mode\"\n"
00119 " }\n"
00120 " regsub -all -- {\\\\n} $line \"\\n\" command($input)\n"
00121 " } else {\n"
00122 " # otherwise, append the line to the batched up command, and\n"
00123 " # check if it's complete\n"
00124 " \n"
00125 " append command($input) $line\n"
00126 " if {![info complete $command($input)]} {\n"
00127 " return\n"
00128 " }\n"
00129 " }\n"
00130 " \n"
00131 " # trim and evaluate the command\n"
00132 " set command($input) [string trim $command($input)]\n"
00133 " set cmd_error 0\n"
00134 " if {[catch {uplevel \\#0 $command($input)} result]} {\n"
00135 " if {$result == \"exit_command\"} {\n"
00136 " if {$input == \"stdin\"} {\n"
00137 " set event_loop_wait 1\n"
00138 " return\n"
00139 " } else {\n"
00140 " real_exit\n"
00141 " }\n"
00142 " }\n"
00143 " global errorInfo\n"
00144 " set result \"error: $result\\nwhile executing\\n$errorInfo\"\n"
00145 " set cmd_error 1\n"
00146 " }\n"
00147 " set command($input) \"\"\n"
00148 "\n"
00149 " if {$tell_encode($output)} {\n"
00150 " regsub -all -- {\\n} $result {\\\\n} result\n"
00151 " puts $output \"$cmd_error $result\"\n"
00152 " } else {\n"
00153 " puts $output $result\n"
00154 " } \n"
00155 " \n"
00156 " if {! $tell_encode($output)} {\n"
00157 " puts -nonewline $output $command_prompt\n"
00158 " }\n"
00159 " flush $output\n"
00160 "}\n"
00161 "\n"
00162 "#\n"
00163 "# Run the simple (i.e. no tclreadline) command loop\n"
00164 "#\n"
00165 "proc simple_command_loop {prompt} {\n"
00166 " global command command_prompt forever tell_encode\n"
00167 " set command_prompt \"$prompt\"\n"
00168 " \n"
00169 " puts -nonewline $command_prompt\n"
00170 " flush stdout\n"
00171 "\n"
00172 " set command(stdin) \"\"\n"
00173 " set tell_encode(stdout) 0\n"
00174 " set event_loop_wait 0\n"
00175 " fileevent stdin readable \"command_process stdin stdout\"\n"
00176 "\n"
00177 " vwait event_loop_wait\n"
00178 "\n"
00179 " command_log notice \"exiting simple command loop\"\n"
00180 "}\n"
00181 "\n"
00182 "#\n"
00183 "# Run the command loop with the given prompt\n"
00184 "#\n"
00185 "proc command_loop {prompt} {\n"
00186 " global command_prompt event_loop_wait\n"
00187 " \n"
00188 " set command_prompt \"$prompt\"\n"
00189 " set event_loop_wait 0\n"
00190 "\n"
00191 " # Handle the behavior that we want for the 'exit' proc -- when running\n"
00192 " # as the console loop (either tclreadline or not), we just want it to\n"
00193 " # exit the loop so the caller knows to clean up properly. To implement\n"
00194 " # that, we error with the special string \"exit_command\" which is\n"
00195 " # caught by callers who DTRT with it.\n"
00196 " rename exit real_exit\n"
00197 " proc exit {} {\n"
00198 " error \"exit_command\"\n"
00199 " }\n"
00200 "\n"
00201 " if [catch {\n"
00202 " package require tclreadline\n"
00203 " tclreadline::readline initialize \"\"\n"
00204 " tclreadline::readline eofchar \"error exit_command\"\n"
00205 " tclreadline_loop\n"
00206 " \n"
00207 " } err] {\n"
00208 " command_log info \"can't load tclreadline: $err\"\n"
00209 " command_log info \"fall back to simple command loop\"\n"
00210 " simple_command_loop $prompt\n"
00211 " }\n"
00212 " puts \"\"\n"
00213 "\n"
00214 " # fix up the exit proc\n"
00215 " rename exit \"\"\n"
00216 " rename real_exit exit\n"
00217 "}\n"
00218 "\n"
00219 "#\n"
00220 "#\n"
00221 "proc tclreadline_completer {text start end line} {\n"
00222 " global event_loop_wait\n"
00223 " if {$event_loop_wait == 1} {\n"
00224 " error \"exit_command\"\n"
00225 " }\n"
00226 " return \"\"\n"
00227 "}\n"
00228 "\n"
00229 "#\n"
00230 "# Custom main loop for tclreadline (allows us to exit on eof)\n"
00231 "# Copied from tclreadline's internal Loop method\n"
00232 "#\n"
00233 "proc tclreadline_loop {} {\n"
00234 " global event_loop_wait\n"
00235 " \n"
00236 " tclreadline::readline builtincompleter 0\n"
00237 " tclreadline::readline customcompleter tclreadline_completer\n"
00238 " \n"
00239 " uplevel \\#0 {\n"
00240 " while {1} {\n"
00241 " if {$event_loop_wait == 1} {\n"
00242 " return\n"
00243 " }\n"
00244 " \n"
00245 " if [info exists tcl_prompt2] {\n"
00246 " set prompt2 $tcl_prompt2\n"
00247 " } else {\n"
00248 " set prompt2 \">\"\n"
00249 " }\n"
00250 "\n"
00251 " if {[catch {\n"
00252 " set LINE [::tclreadline::readline read $command_prompt]\n"
00253 " while {![::tclreadline::readline complete $LINE]} {\n"
00254 " append LINE \"\\n\"\n"
00255 " append LINE [tclreadline::readline read ${prompt2}]\n"
00256 " }\n"
00257 " \n"
00258 " } errorMsg]} {\n"
00259 " if {$errorMsg == \"exit_command\"} {\n"
00260 " break\n"
00261 " }\n"
00262 " puts stderr \"tclreadline_loop error. $errorMsg\"\n"
00263 " continue\n"
00264 " }\n"
00265 "\n"
00266 " # Magnus Eriksson <magnus.eriksson@netinsight.se> proposed\n"
00267 " # to add the line also to tclsh's history.\n"
00268 " #\n"
00269 " # I decided to add only lines which are different from\n"
00270 " # the previous one to the history. This is different\n"
00271 " # from tcsh's behaviour, but I found it quite convenient\n"
00272 " # while using mshell on os9.\n"
00273 " #\n"
00274 " if {[string length $LINE] && [history event 0] != $LINE} {\n"
00275 " history add $LINE\n"
00276 " }\n"
00277 "\n"
00278 " if [catch {\n"
00279 " \n"
00280 " set result [eval $LINE]\n"
00281 " if {$result != \"\"} {\n"
00282 " puts $result\n"
00283 " }\n"
00284 " set result \"\"\n"
00285 " } ::tclreadline::errorMsg] {\n"
00286 " if {$::tclreadline::errorMsg == \"exit_command\"} {\n"
00287 " break\n"
00288 " }\n"
00289 " puts stderr $::tclreadline::errorMsg\n"
00290 " puts stderr [list while evaluating $LINE]\n"
00291 " }\n"
00292 " }\n"
00293 " }\n"
00294 "}\n"
00295 "\n"
00296 "\n"
00297 "#\n"
00298 "# Proc that's called when a new command connection arrives\n"
00299 "#\n"
00300 "proc command_connection {chan host port} {\n"
00301 " global command command_info command_prompt tell_encode\n"
00302 "\n"
00303 " set command_info($chan) \"$host:$port\"\n"
00304 " set command($chan) \"\"\n"
00305 " set tell_encode($chan) 0\n"
00306 " log /command debug \"new command connection $chan from $host:$port\"\n"
00307 " fileevent $chan readable \"command_process $chan $chan\"\n"
00308 "\n"
00309 " puts -nonewline $chan $command_prompt\n"
00310 " flush $chan\n"
00311 "}\n"
00312 "\n"
00313 "#\n"
00314 "# Run a command server on the given addr:port\n"
00315 "#\n"
00316 "proc command_server {prompt addr port} {\n"
00317 " global command_prompt\n"
00318 " set command_prompt \"$prompt\"\n"
00319 " socket -server command_connection -myaddr $addr $port \n"
00320 "}\n"
00321 "\n"
00322 "#\n"
00323 "# Define a bgerror proc to print the error stack when errors occur in\n"
00324 "# event handlers\n"
00325 "#\n"
00326 "proc bgerror {err} {\n"
00327 " global errorInfo\n"
00328 " puts \"tcl error: $err\\n$errorInfo\"\n"
00329 "}\n"
00330 "\n"
00331 ;