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