command-init-tcl.c

Go to the documentation of this file.
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 ;

Generated on Fri Dec 22 14:47:58 2006 for DTN Reference Implementation by  doxygen 1.5.1