1# -*- tcl -*- 2# # ## ### ##### ######## ############# 3# (C) 2009 Andreas Kupries 4 5# @@ Meta Begin 6# Package tcl::chan::halfpipe 1 7# Meta as::author {Andreas Kupries} 8# Meta as::copyright 2009 9# Meta as::license BSD 10# Meta description Implementation of one half of a pipe 11# Meta description channel. Based on Tcl 8.5's channel 12# Meta description reflection support. Exports a single 13# Meta description command for the creation of new 14# Meta description channels. Option arguments. Result is the 15# Meta description handle of the new channel, and the object 16# Meta description command of the handler object. 17# Meta platform tcl 18# Meta require TclOO 19# Meta require tcl::chan::events 20# Meta require {Tcl 8.5} 21# @@ Meta End 22# # ## ### ##### ######## ############# 23 24package require Tcl 8.5 25package require TclOO 26package require tcl::chan::events 27 28# # ## ### ##### ######## ############# 29 30namespace eval ::tcl::chan {} 31 32proc ::tcl::chan::halfpipe {args} { 33 set handler [halfpipe::implementation new {*}$args] 34 return [list [::chan create {read write} $handler] $handler] 35} 36 37oo::class create ::tcl::chan::halfpipe::implementation { 38 superclass ::tcl::chan::events ; # -> initialize, finalize, watch 39 40 method initialize {args} { 41 my allow write 42 next {*}$args 43 } 44 45 method finalize {c} { 46 my Call -close-command $c 47 next $c 48 } 49 50 method read {c n} { 51 set max [string length $read] 52 set last [expr {$at + $n - 1}] 53 set result {} 54 55 # last+1 <= max 56 # <=> at+n <= max 57 # <=> n <= max-at 58 59 if {$n <= ($max - $at)} { 60 # The request is less than what we have left in the read 61 # buffer, we take it, and move the read pointer forward. 62 63 append result [string range $read $at $last] 64 incr at $n 65 incr $size -$n 66 } else { 67 # We need the whole remaining read buffer, and more. For 68 # the latter we shift the write buffer contents over into 69 # the read buffer, and then read from the latter again. 70 71 append result [string range $read $at end] 72 incr n -[string length $result] 73 74 set at 0 75 set read $write 76 set write {} 77 set size [string length $read] 78 set max $size 79 80 # at == 0 81 if {$n <= $max} { 82 # The request is less than what we have in the updated 83 # read buffer, we take it, and move the read pointer 84 # forward. 85 86 append result [string range $read 0 $last] 87 set at $n 88 incr $size -$n 89 } else { 90 # We need the whole remaining read buffer, and 91 # more. As we took the data from write already we have 92 # nothing left, and update accordingly. 93 94 append result $read 95 96 set at 0 97 set read {} 98 set size 0 99 } 100 } 101 102 my Readable 103 104 if {$result eq {}} { 105 return -code error EAGAIN 106 } 107 108 return $result 109 } 110 111 method write {c bytes} { 112 my Call -write-command $c $bytes 113 return [string length $bytes] 114 } 115 116 # # ## ### ##### ######## ############# 117 118 method put {bytes} { 119 append write $bytes 120 set n [string length $bytes] 121 incr size $n 122 my Readable 123 return $n 124 } 125 126 # # ## ### ##### ######## ############# 127 128 variable at read write size options 129 130 # # ## ### ##### ######## ############# 131 132 constructor {args} { 133 array set options { 134 -write-command {} 135 -empty-command {} 136 -close-command {} 137 } 138 # todo: validity checking of options (legal names, legal 139 # values, etc.) 140 array set options $args 141 set at 0 142 set read {} 143 set write {} 144 set size 0 145 next 146 } 147 148 method Readable {} { 149 if {$size} { 150 my allow read 151 } else { 152 my variable channel 153 my disallow read 154 my Call -empty-command $channel 155 } 156 return 157 } 158 159 method Call {o args} { 160 if {![llength $options($o)]} return 161 uplevel \#0 [list {*}$options($o) {*}$args] 162 return 163 } 164} 165 166# # ## ### ##### ######## ############# 167package provide tcl::chan::halfpipe 1 168return 169