asynch.tcl

   1 #!/usr/bin/tclsh8.5
   2
   3 # This [sub]program is Copyright (C) 1997-1999 Ian Jackson
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2, or (at your option)
   8 # any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software Foundation,
  17 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  18 #
  19 # $Id$
  20
  21 proc asynch_startcmd {} {
  22     global asynch_sofar
  23     set asynch_sofar {}
  24     puts -nonewline "% "
  25     flush stdout
  26 }
  27
  28 proc morecmd {} {
  29     global asynch_sofar asynch_result asynch_code errorInfo
  30     set r [read -nonewline stdin]
  31     if {[eof stdin]} {
  32         fconfigure stdin -blocking true
  33         puts -nonewline "\n"
  34         exit 0
  35     }
  36     append asynch_sofar $r
  37     if {[info complete $asynch_sofar]} {
  38         uplevel #0 {set asynch_code [catch $asynch_sofar asynch_result]}
  39         if {$asynch_code} {
  40             puts "** $errorInfo"
  41             flush stdout
  42         } elseif {[string length $asynch_result]} {
  43             puts "=> $asynch_result"
  44         }
  45         flush stdout
  46         asynch_startcmd
  47     }
  48 }
  49
  50 if {[llength $argv] && ![string compare [lindex $argv 0] "-d"]} {
  51     set tcl_traceExec 1
  52     set argv [lreplace $argv 0 0]
  53 } elseif {[llength $argv] && ![string compare [lindex $argv 0] "-dd"]} {
  54     set tcl_traceExec 2
  55     set argv [lreplace $argv 0 0]
  56 }
  57
  58 if {[llength $argv] &&
  59     [regexp {^-a(\d+)$} [lindex $argv 0] asynch_dummy asynch_appdebug]} {
  60     set argv [lreplace $argv 0 0]
  61 }
  62
  63 if {[llength $argv]} {
  64     set asynch_script [lindex $argv 0]
  65     set argv [lreplace $argv 0 0]
  66     source $asynch_script
  67 }
  68
  69 asynch_startcmd
  70 fileevent stdin readable morecmd
  71 fconfigure stdin -blocking false
  72 vwait asynch_quitting