scripts/conobj.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 class tlc::Con {
   4         inherit tlc::Handlers
   5
   6         constructor {parms a_con cl_ip cl_port} {}
   7         destructor {}
   8
   9         public {
  10                 variable newmsg_cb      {}
  11                 variable close_cb       {}
  12                 variable server
  13
  14                 method send {res id msg}
  15                 method parse_tabular {data}
  16                 method compile_tabular {data}
  17         }
  18
  19         private {
  20                 variable con
  21                 variable protocols
  22                 variable current_protocol       "default"
  23
  24                 method readable {}
  25                 method prot_default {op args}
  26         }
  27 }
  28
  29
  30 body tlc::Con::constructor {parms a_con cl_ip cl_port} { #<<<1
  31         array set protocols     {}
  32
  33         eval configure $parms
  34
  35         if {![info exists server]} {
  36                 error "Must set -server"
  37         }
  38
  39         set con         $a_con
  40
  41         array set protocols     [$server get_protocols]
  42
  43         fconfigure $con -blocking 1 -translation binary -encoding binary
  44         fileevent $con readable [code $this readable]
  45 }
  46
  47
  48 body tlc::Con::destructor {} { #<<<1
  49         catch {close $con}
  50         invoke_handlers close $this
  51         uplevel #0 $close_cb [list $this]
  52 }
  53
  54
  55 body tlc::Con::readable {} { #<<<1
  56         if {![info exists protocols($current_protocol)]} return
  57         set res [uplevel #0 $protocols($current_protocol) [list server_read $con]]
  58
  59         if {[eof $con]} {
  60                 delete object $this
  61                 return
  62         }
  63
  64         set tag         [lindex $res 0]
  65         set subcmd      [lindex $res 1]
  66         set id          [lindex $res 2]
  67         set dat         [lindex $res 3]
  68         if {$tag == "set_protocol"} {
  69                 set current_protocol    $subcmd
  70                 return
  71         }
  72
  73         uplevel #0 $newmsg_cb [list $this $tag $subcmd $id $dat]
  74 }
  75
  76
  77 body tlc::Con::send {res id msg} { #<<<1
  78         if {![info exists protocols($current_protocol)]} {
  79                 error "No handler for currently registered protocol"
  80         }
  81         uplevel #0 $protocols($current_protocol) \
  82                         [list server_write $con $res $id $msg]
  83 }
  84
  85
  86 body tlc::Con::parse_tabular {data} { #<<<1
  87         if {![info exists protocols($current_protocol)]} {
  88                 error "No handler for currently registered protocol"
  89         }
  90         return [uplevel #0 $protocols($current_protocol) \
  91                         [list parse_tabular $data]]
  92 }
  93
  94
  95 body tlc::Con::compile_tabular {data} { #<<<1
  96         if {![info exists protocols($current_protocol)]} {
  97                 error "No handler for currently registered protocol"
  98         }
  99         return [uplevel #0 $protocols($current_protocol) \
 100                         [list compile_tabular $data]]
 101 }
 102
 103