1# -*- tcl -*- 2# # ## ### ##### ######## ############# 3# (C) 2009 Andreas Kupries 4 5# @@ Meta Begin 6# Package tcl::chan::fifo 1 7# Meta as::author {Andreas Kupries} 8# Meta as::copyright 2009 9# Meta as::license BSD 10# Meta description Re-implementation of Memchan's fifo 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. No arguments. Result is the 15# Meta description handle of the new channel. 16# Meta platform tcl 17# Meta require TclOO 18# Meta require tcl::chan::events 19# Meta require {Tcl 8.5} 20# @@ Meta End 21# # ## ### ##### ######## ############# 22 23package require Tcl 8.5 24package require TclOO 25package require tcl::chan::events 26 27# # ## ### ##### ######## ############# 28 29namespace eval ::tcl::chan {} 30 31proc ::tcl::chan::fifo {} { 32 return [::chan create {read write} [fifo::implementation new]] 33} 34 35oo::class create ::tcl::chan::fifo::implementation { 36 superclass ::tcl::chan::events ; # -> initialize, finalize, watch 37 38 method initialize {args} { 39 my allow write 40 next {*}$args 41 } 42 43 method read {c n} { 44 set max [string length $read] 45 set last [expr {$at + $n - 1}] 46 set result {} 47 48 # last+1 <= max 49 # <=> at+n <= max 50 # <=> n <= max-at 51 52 if {$n <= ($max - $at)} { 53 # The request is less than what we have left in the read 54 # buffer, we take it, and move the read pointer forward. 55 56 append result [string range $read $at $last] 57 incr at $n 58 incr $size -$n 59 } else { 60 # We need the whole remaining read buffer, and more. For 61 # the latter we shift the write buffer contents over into 62 # the read buffer, and then read from the latter again. 63 64 append result [string range $read $at end] 65 incr n -[string length $result] 66 67 set at 0 68 set read $write 69 set write {} 70 set size [string length $read] 71 set max $size 72 73 # at == 0 74 if {$n <= $max} { 75 # The request is less than what we have in the updated 76 # read buffer, we take it, and move the read pointer 77 # forward. 78 79 append result [string range $read 0 $last] 80 set at $n 81 incr $size -$n 82 } else { 83 # We need the whole remaining read buffer, and 84 # more. As we took the data from write already we have 85 # nothing left, and update accordingly. 86 87 append result $read 88 89 set at 0 90 set read {} 91 set size 0 92 } 93 } 94 95 my Readable 96 97 if {$result eq {}} { 98 return -code error EAGAIN 99 } 100 101 return $result 102 } 103 104 method write {c bytes} { 105 append write $bytes 106 set n [string length $bytes] 107 incr size $n 108 my Readable 109 return $n 110 } 111 112 # # ## ### ##### ######## ############# 113 114 variable at read write size 115 116 # # ## ### ##### ######## ############# 117 118 constructor {} { 119 set at 0 120 set read {} 121 set write {} 122 set size 0 123 next 124 } 125 126 method Readable {} { 127 if {$size} { 128 my allow read 129 } else { 130 my disallow read 131 } 132 return 133 } 134} 135 136# # ## ### ##### ######## ############# 137package provide tcl::chan::fifo 1 138return 139