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