tcl_tests/yarrowc.tcl

   1 set argport 7670
   2 if {[lindex $argv 0] eq "-port"} {
   3         set argport [lindex $argv 1]
   4         set argv [lrange $argv 2 end]
   5 }
   6 set request [lindex $argv 0]
   7 set len [switch $request ping {expr -1} protocol {expr -2} version {expr -3} check {expr 1} default {expr $request}]
   8 set read_data {}
   9
  10 proc get_port {} {
  11         if {[regexp {^\d+$} $::argport]} {return $::argport}
  12         set f [open $::argport r]
  13         set r [read -nonewline $f]
  14         close $f
  15         return $r
  16 }
  17
  18 proc get_data {socket} {
  19         set read_data [read $socket]
  20         if {$read_data eq ""} {
  21                 close $socket
  22                 handle_data
  23         } else {
  24                 append ::read_data $read_data
  25         }
  26 }
  27
  28 proc handle_data {} {
  29         global len read_data
  30         if {$len > 0} {
  31                 if {$::request eq "check" && $read_data ne ""} {exit 0}
  32                 if {$read_data eq ""} {
  33                         puts stderr "not ready"
  34                         exit 1
  35                 }
  36                 binary scan $read_data H* data
  37                 set data [regsub -all ".{48}" [regsub -all ".." $data "& "] "&\n"]
  38                 if {[string index $data end] eq "\n"} {set data [string replace $data end end]}
  39                 puts $data
  40         } else {
  41                 if {$len == -1 || $len == -3} {
  42                         if {[string length $read_data] < 4} {error "Not enough data"}
  43                         binary scan $read_data I rlen
  44                         set read_data [string range $read_data 4 end]
  45                         puts [encoding convertfrom utf-8 $read_data]
  46                         if {[string length $read_data] != $rlen} {
  47                                 puts stderr "Real string length [string length $read_data] != claimed $rlen!"
  48                                 exit 2
  49                         }
  50                 } elseif {$len == -2} {
  51                         if {[string length $read_data] < 4} {error "Not enough data"}
  52                         if {[string length $read_data] > 4} {error "Excess data"}
  53                         binary scan $read_data I r
  54                         puts $r
  55                 }
  56         }
  57         exit 0
  58 }
  59
  60 set port [get_port]
  61
  62 if {[info exists errmsg] && $errmsg ne ""} {error $errmsg}
  63 if {$port eq ""} {error "Cannot find port number"}
  64
  65 set s [socket localhost $port]
  66 fconfigure $s -encoding binary -buffering none -blocking 0
  67 fileevent $s readable [list get_data $s]
  68 puts -nonewline $s [binary format I $len]
  69 after 4000 {puts stderr "Timeout.  Read for now: '$read_data'"; exit 2}
  70 vwait forever