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
|
# -*- tcl -*-
# # ## ### ##### ######## #############
# (C) 2011,2019 Andreas Kupries
# Facade concatenating the contents of the channels it was constructed
# with. Owns the sub-ordinate channels and closes them on exhaustion and/or
# when closed itself.
# @@ Meta Begin
# Package tcl::chan::cat 1.0.4
# Meta as::author {Andreas Kupries}
# Meta as::copyright 2011
# Meta as::license BSD
# Meta description Facade concatenating the contents of the channels it
# Meta description was constructed with. Owns the sub-ordinate channels
# Meta description and closes them on exhaustion and/or when closed itself.
# Meta platform tcl
# Meta require TclOO
# Meta require tcl::chan::core
# Meta require {Tcl 8.5}
# @@ Meta End
# # ## ### ##### ######## #############
package require Tcl 8.5 9
package require TclOO
package require tcl::chan::core
# # ## ### ##### ######## #############
namespace eval ::tcl::chan {}
proc ::tcl::chan::cat {args} {
return [::chan create {read} [cat::implementation new {*}$args]]
}
oo::class create ::tcl::chan::cat::implementation {
superclass ::tcl::chan::core ; # -> initialize, finalize.
# We are not using the standard event handling class, because here
# it will not be timer-driven. We propagate anything related to
# events to catin and catout instead and let them handle things.
constructor {args} {
set channels $args
# Disable translation (and hence encoding) in the wrapped channels.
# This will happen in our generic layer instead.
foreach c $channels {
fconfigure $c -translation binary
}
set delay 10
set watching 0
return
}
destructor {
foreach c $channels {
::close $c
}
return
}
variable channels timer delay watching
method watch {c requestmask} {
if {"read" in $requestmask} {
# Activate event handling. Either drive an eof home via
# timers, or activate things in the foremost sub-ordinate.
set watching 1
if {![llength $channels]} {
set timer [after $delay [namespace code [list my Post $c]]]
} else {
chan event [lindex $channels 0] readable [list chan postevent $c read]
}
} else {
# Stop events. Either kill timer, or disable in the
# foremost sub-ordinate.
set watching 0
if {![llength $channels]} {
catch { after cancel $timer }
} else {
chan event [lindex $channels 0] readable {}
}
}
return
}
method read {c n} {
if {![llength $channels]} {
# This signals EOF higher up.
return {}
}
set buf {}
while {([string length $buf] < $n) &&
[llength $channels]} {
set in [lindex $channels 0]
set toread [expr {$n - [string length $buf]}]
append buf [::read $in $toread]
if {[eof $in]} {
close $in
set channels [lrange $channels 1 end]
# The close of the exhausted subordinate killed any
# fileevent handling we may have had attached to this
# channel. Update the settings (i.e. move to the next
# subordinate, or to timer-based, to drive the eof
# home).
if {$watching} {
my watch $c read
}
}
}
# When `buf` is empty, all channels have been exhausted and
# closed, therefore returning this empty string will cause an
# EOF higher up.
return $buf
}
method Post {c} {
set timer [after $delay [namespace code [list my Post $c]]]
chan postevent $c read
return
}
}
# # ## ### ##### ######## #############
package provide tcl::chan::cat 1.0.4
return
|
