tcl-hacks

Check-in [b93d0b1571]
Login

Check-in [b93d0b1571]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:refchan pipe ?
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: b93d0b1571a42e1515e16e168450b1f21412e02a
User & Date: aspect 2019-04-26 14:22:28.639
Context
2019-10-31
02:54
(no comment) check-in: 075928d0e2 user: aspect tags: trunk
2019-04-26
14:22
refchan pipe ? check-in: b93d0b1571 user: aspect tags: trunk
14:22
Fix tclish symlink resolution check-in: 3eaba8d90c user: aspect tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Added tmp/refpipe.tcl.
































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
# making a [chan pipe] out of refpipes
# passes the rudimentary synchronous test cases, does it pass async?
namespace eval refpipe {

    oo::class create Buffer {
        variable Size
        variable Data
        variable Block
        variable Watch
        constructor {size} {
            set Size $size
            set Block 1
            set Watch {}
            set Data {}
        }
        method initialize {chan mode} {
            return {initialize finalize blocking watch write read configure}
        }
        method finalize {chan} {
            puts "[self class] [self] finalize!"
            my destroy
        }
        method blocking {chan mode} {
            puts "[self class] [self] blocking $mode"
            set Block $mode
        }
        method watch {chan events} {
            set Watch $events
        }
        method configure {chan key val} {
            if {$key ne "-size"} {
                return -code error "Bad option \"$key\", should be \"-size\""
            }
            if {![string is integer $val]} {
                return -code error "Expected integer but got \"$val\""
            }
            set Size $val
        }
        method Postevent {chan event} {
            if {$event in $Watch} {
                # (see http://core.tcl.tk/tcl/tktview?name=67a5eabbd3)
                after idle [list chan postevent $chan $event]
            }
        }
        method write {chan data} {
            if {[string length $Data] + [string length $data] > $Size} {
                if {$Block} {
                    throw {POSIX EPIPE} "Buffer is full!"
                } else {
                    throw EAGAIN EAGAIN
                }
            }
            append Data $data
            my Postevent $chan "read"
            if {[string length $Data] < $Size} {
                my Postevent $chan "write"
            }
            return [string length $data]
        }
        method read {chan bytes} {
            if {$Data eq ""} {
                if {$Block} {
                    return ""
                } else {
                    throw EAGAIN EAGAIN
                }
            }
            set r [string range $Data 0 $bytes]
            set Data [string replace $Data 0 $bytes]
            return $r
        }
    }

    oo::class create Writer {
        variable Buffer
        variable Watch
        variable Block
        constructor {buffer} {
            set Buffer $buffer
            set Block 1
            set Watch {}
        }
        method initialize {chan mode} {
            return {initialize finalize blocking watch write}
        }
        method finalize {chan} {
            puts "[self class] [self] finalize!"
            my destroy
        }
        method blocking {chan mode} {
            set Block $mode
        }
        method watch {chan events} {
            set Watch $events
        }
        method Postevent {chan event} {
            if {$event in $Watch} {
                # (see http://core.tcl.tk/tcl/tktview?name=67a5eabbd3)
                after idle [list chan postevent $chan $event]
            }
        }
        method write {chan data} {
            puts -nonewline $Buffer $data
            return [string length $data]
        }
    }

    oo::class create Reader {
        variable Buffer
        variable Watch
        variable Block
        constructor {buffer} {
            set Buffer $buffer
            set Block 1
            set Watch {}
        }
        method initialize {chan mode} {
            return {initialize finalize blocking watch read}
        }
        method finalize {chan} {
            puts "[self class] [self] finalize!"
            chan configure $Buffer -size 0
            my destroy
        }
        method blocking {chan mode} {
            set Block $mode
        }
        method watch {chan events} {
            set Watch $events
        }
        method Postevent {chan event} {
            if {$event in $Watch} {
                # (see http://core.tcl.tk/tcl/tktview?name=67a5eabbd3)
                after idle [list chan postevent $chan $event]
            }
        }
        method read {chan size} {
            read $Buffer $size
        }
    }


    proc buffer {{size Inf}} {
        set fd [chan create {read write} [Buffer new $size]]
        chan configure $fd -buffering none
        return $fd
    }

    proc pipe {{size Inf}} {
        set buf [buffer $size]
        set rd [chan create read [Reader new $buf]]
        set wr [chan create write [Writer new $buf]]
        chan configure $wr -buffering none
        list $rd $wr
    }
}

proc ok {result args} {
    set r [uplevel 1 $args]
    if {$r eq $result} {
        puts "OK: got expected \"$result\""
    } else {
        puts "ERR: expected \"$result\" but got \"$r\""
    }
}

proc err {code args} {
    set rc [catch {uplevel 1 $args} res opts]
    set errcode {}
    catch {set errcode [dict get $opts -errorcode]}
    if {$errcode eq $code} {
        puts "OK: got expected {$code} \"$res\""
    } else {
        puts "ERR: expected error {$code} but got $rc \"$res\" $opts"
    }
}

proc main {} {
    set buf [refpipe::buffer 10]
    chan configure $buf -buffering none
    ok ""               puts $buf "Hello"
    err {POSIX EPIPE}   puts $buf "World"
    ok "Hello"          gets $buf
    ok ""               gets $buf
    ok 1                eof $buf
    ok ""               puts $buf "Hi"
    ok ""               puts $buf "Mate"
    ok "Hi"             gets $buf
    ok "Mate"           gets $buf
    ok ""               close $buf
    puts "buf ok"

    lassign [refpipe::pipe] rd wr
    ok ""               puts $wr "Hello"
    ok ""               puts $wr "World"
    ok ""               close $wr
    ok "Hello"          gets $rd
    ok "World"          gets $rd
    ok ""               gets $rd
    ok 1                eof $rd
    puts done!

    lassign [refpipe::pipe] rd wr
    close $rd
    err {POSIX EPIPE}   puts $wr "Hello"
}

main