scripts/serverobj.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 class tlc::Server {
   4         inherit tlc::Handlers
   5
   6         constructor {args} {}
   7         destructor {}
   8
   9         public {
  10                 variable port           7371    rebind
  11                 variable ip                     ""              rebind
  12                 variable con_class      "Con"
  13
  14                 method get_protocols {}
  15                 method register_protocol {name handler}
  16         }
  17
  18         private {
  19                 variable listen
  20                 variable afterid        ""
  21                 variable protocols
  22
  23                 method rebind {}
  24                 method _rebind {}
  25                 method newmsg {conobj tag subcmd id msg}
  26                 method closeclient {conobj}
  27         }
  28 }
  29
  30
  31 body tlc::Server::constructor {args} { #<<<1
  32         eval configure $args
  33         register_protocol default [tlc::Protocol ::#auto]
  34         rebind
  35 }
  36
  37
  38 body tlc::Server::destructor {} { #<<<1
  39         close $listen
  40         after cancel $afterid
  41 }
  42
  43
  44 body tlc::Server::rebind {} { #<<<1
  45         if {$afterid != ""} return
  46         set afterid     [after idle [code $this _rebind]]
  47 }
  48
  49
  50 body tlc::Server::_rebind {} { #<<<1
  51         after cancel $afterid
  52         set afterid             ""
  53         if {$ip == ""} {
  54                 set listen      [socket -server [list $con_class #auto \
  55                                 [list -newmsg_cb [code $this newmsg] -server $this -close_cb [code $this closeclient]]] $port]
  56         } else {
  57                 set listen      [socket -server [list $con_class #auto \
  58                                 [list -newmsg_cb [code $this newmsg] -server $this -close_cb [code $this closeclient]]] -myaddr $ip $port]
  59         }
  60 }
  61
  62
  63 body tlc::Server::newmsg {conobj tag subcmd id msg} { #<<<1
  64         log debug "invoking handler for $tag, $subcmd, $id, $msg on $conobj"
  65         if {[set ecode [catch {
  66                 if {![handlers_available $tag]} {
  67                         error "No handlers available for $tag"
  68                 }
  69                 invoke_handlers $tag $conobj $subcmd $id $msg
  70         } msg]]} {
  71                 if {$ecode != 1} return
  72                 log error "tlc::Server::newmsg: error processing callbacks for $tag:\n$::errorInfo"
  73                 $conobj send 0 $id "Internal error"
  74         }
  75 }
  76
  77
  78 body tlc::Server::closeclient {conobj} { #<<<1
  79         # TODO: possible (unlikely) namespace collision of "closeclient" with tags
  80         invoke_handlers closeclient $conobj
  81 }
  82
  83
  84 body tlc::Server::register_protocol {name handler} { #<<<1
  85         set protocols($name)    $handler
  86 }
  87
  88
  89 body tlc::Server::get_protocols {} { #<<<1
  90         return [array get protocols]
  91 }
  92
  93