scripts/protocol_mpack.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 class tlc::Protocol_mpack {
   4         inherit tlc::Protocol
   5
   6         public {
   7                 method server_read {con}
   8                 method server_write {con res id msg}
   9                 method client_read {con}
  10                 method client_write {con tag subcmd id msg}
  11                 method parse_tabular {data}
  12                 method compile_tabular {data}
  13         }
  14 }
  15
  16
  17 body tlc::Protocol_mpack::server_read {con} { #<<<1
  18         set cmd         [gets $con]
  19         set cmdlist     [split $cmd :]
  20         set tag         [lindex $cmdlist 0]
  21         set subcmd      [lindex $cmdlist 1]
  22         set id          [lindex $cmdlist 2]
  23         set len         [lindex $cmdlist 3]
  24         if {![string is integer -strict $len]} {
  25                 return
  26         }
  27         set dat         [read $con $len]
  28
  29         return [list $tag $subcmd $id $dat]
  30 }
  31
  32
  33 body tlc::Protocol_mpack::server_write {con res id msg} { #<<<1
  34         set lmsg        $msg
  35         puts $con [join [list $res $id [string bytelength $lmsg]] :]
  36         puts -nonewline $con $lmsg
  37         flush $con
  38 }
  39
  40
  41 body tlc::Protocol_mpack::client_read {con} { #<<<1
  42         set cmd         [gets $con]
  43         set cmdlist     [split $cmd :]
  44         if {[catch {
  45                 set res         [lindex $cmdlist 0]
  46                 set previd      [lindex $cmdlist 1]
  47                 set len         [lindex $cmdlist 2]
  48         } msg]} {
  49                 error "Error parsing control line: ($cmd):\n%::errorInfo"
  50         }
  51         if {![string is integer -strict $len]} {
  52                 return
  53         }
  54         set dat         [read $con $len]
  55
  56         return [list $res $previd $dat]
  57 }
  58
  59
  60 body tlc::Protocol_mpack::client_write {con tag subcmd id msg} { #<<<1
  61         set lmsg        $msg
  62         puts $con [join [list $tag $subcmd $id [string bytelength $lmsg]] :]
  63         puts -nonewline $con $lmsg
  64         flush $con
  65 }
  66
  67
  68 body tlc::Protocol_mpack::parse_tabular {data} { #<<<1
  69         set build       {}
  70         # WARNING: this is for demo purposes only!  "split" won't skip quoted
  71         # tokens properly
  72         foreach srow    [split $data \n] {
  73                 set row         {}
  74                 foreach col [split $srow :] {
  75                         lappend row     [string map {"\\:" ":" "\\\\" "\\" "\\n" "\n"} $col]
  76                 }
  77                 lappend build   $row
  78         }
  79         return $build
  80 }
  81
  82
  83 body tlc::Protocol_mpack::compile_tabular {data} { #<<<1
  84         set build       ""
  85         foreach srow $data {
  86                 set row         {}
  87                 foreach col $srow {
  88                         lappend row     [string map {":" "\\:" "\\" "\\\\" "\n" "\\n"} $col]
  89                 }
  90                 append build [join $row :] "\n"
  91         }
  92         return $build
  93 }
  94
  95