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 ;
