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