scripts/clientobj.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 class tlc::Clientobj {
   4         inherit tlc::Handlers
   5
   6         constructor {args} {}
   7         destructor {}
   8
   9         public {
  10                 variable ip             ""
  11                 variable port   ""
  12
  13                 method req_async {tag subcmd msg cb}
  14                 method req_sync {tag subcmd msg}
  15                 method register_protocol {name handler}
  16                 method select_protocol {name}
  17                 method parse_tabular {data}
  18                 method compile_tabular {data}
  19         }
  20
  21         private {
  22                 variable con
  23                 variable id             0
  24                 variable sync_res
  25                 variable async_res
  26                 variable pending
  27                 variable protocols
  28                 variable current_protocol       "default"
  29
  30                 common default_protocol
  31
  32                 method readable {}
  33                 method send {tag subcmd id msg}
  34                 method finish_sync {res id msg}
  35                 method prot_default {op args}
  36         }
  37 }
  38
  39
  40 body tlc::Clientobj::constructor {args} { #<<<1
  41         array set pending       {}
  42         array set protocols     {}
  43
  44         if {![info exists default_protocol]} {
  45                 set default_protocol    [tlc::Protocol ::#auto]
  46         }
  47
  48         eval configure $args
  49
  50         register_protocol default $default_protocol
  51
  52         set con [socket $ip $port]
  53         fconfigure $con -blocking 1 -translation binary -encoding binary
  54         fileevent $con readable [code $this readable]
  55 }
  56
  57
  58 body tlc::Clientobj::destructor {} { #<<<1
  59         close $con
  60         invoke_handlers close
  61 }
  62
  63
  64 body tlc::Clientobj::req_async {tag subcmd msg cb} { #<<<1
  65         set myid        [incr id]
  66         set async_res($myid)    $cb
  67
  68         send $tag $subcmd $myid $msg
  69 }
  70
  71
  72 body tlc::Clientobj::req_sync {tag subcmd msg} { #<<<1
  73         set myid        [incr id]
  74         set async_res($myid)    [code $this finish_sync $myid]
  75
  76         send $tag $subcmd $id $msg
  77
  78         vwait [scope pending($myid)]
  79         set res         [lindex $pending($myid) 0]
  80         set dat         [lindex $pending($myid) 1]
  81         #puts "Clientobj::req_sync: unsetting pending($id)"
  82         unset pending($myid)
  83
  84         if {$res} {
  85                 return $dat
  86         } else {
  87                 error $dat
  88         }
  89 }
  90
  91
  92 body tlc::Clientobj::finish_sync {id res msg} { #<<<1
  93         #puts "Clientobj::finish_sync: setting pending($id) to [list $res $msg]"
  94         set pending($id)        [list $res $msg]
  95 }
  96
  97
  98 body tlc::Clientobj::readable {} { #<<<1
  99         if {[eof $con]} {
 100                 delete object $this
 101                 return
 102         }
 103
 104         if {![info exists protocols($current_protocol)]} {
 105                 error "No protocol handler for selected protocol: ($current_protocol)"
 106         }
 107         set rl  [uplevel #0 $protocols($current_protocol) [list client_read $con]]
 108         set res         [lindex $rl 0]
 109         set previd      [lindex $rl 1]
 110         set dat         [lindex $rl 2]
 111
 112         if {[string is integer -strict $previd]} {
 113                 if {[info exists async_res($previd)]} {
 114                         set cb  $async_res($previd)
 115                         unset async_res($previd)
 116                         uplevel #0 $cb [list $res $dat]
 117                 }
 118         } else {
 119                 invoke_handlers servermsg_$previd $dat
 120         }
 121 }
 122
 123
 124 body tlc::Clientobj::send {tag subcmd id msg} { #<<<1
 125         if {![info exists protocols($current_protocol)]} {
 126                 error "No protocol handler for selected protocol: ($current_protocol)"
 127         }
 128         uplevel #0 $protocols($current_protocol) \
 129                         [list client_write $con $tag $subcmd $id $msg]
 130 }
 131
 132
 133 body tlc::Clientobj::register_protocol {name handler} { #<<<1
 134         set protocols($name)    $handler
 135 }
 136
 137
 138 body tlc::Clientobj::select_protocol {name} { #<<<1
 139         if {![info exists protocols($name)]} {
 140                 error "No protocol handler for selected protocol: ($name)"
 141         }
 142         send "set_protocol" $name "" ""
 143         set current_protocol    $name
 144 }
 145
 146
 147 body tlc::Clientobj::parse_tabular {data} { #<<<1
 148         if {![info exists protocols($current_protocol)]} {
 149                 error "No protocol handler for selected protocol: ($current_protocol)"
 150         }
 151         return [uplevel #0 $protocols($current_protocol) parse_tabular [list $data]]
 152 }
 153
 154
 155 body tlc::Clientobj::compile_tabular {data} { #<<<1
 156         if {![info exists protocols($current_protocol)]} {
 157                 error "No protocol handler for selected protocol: ($current_protocol)"
 158         }
 159         return [uplevel #0 $protocols($current_protocol) parse_tabular [list $data]]
 160 }
 161
 162