blob: b72e2185eb66b0410737d5c75dc52d3e52d34e48 (
plain)
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
|
# -*- tcl -*-
# # ## ### ##### ######## #############
# (C) 2011 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.1
# 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
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 encoding and translation processing in the wrapped channels.
# This will happen in our generic layer instead.
foreach c $channels {
fconfigure $c -translation binary
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 {
set c [lindex $channels 0]
fileevent readable $c [list chan postevent $c read]
}
} else {
# Stop events. Kill timer, or disable in the foremost
# sub-ordinate.
set watching 0
if {![llength $channels]} {
catch { after cancel $timer }
} else {
fileevent readable [lindex $channels 0] {}
}
}
return
}
method read {c n} {
if {![llength $channels]} {
# Actually should be EOF signal.
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 above also killed any fileevent handling
# we might have attached to this channel. We may have
# to update the settings (i.e. move to next channel,
# or to timer-based, to drive the eof home).
if {$watching} {
my watch $c read
}
}
}
if {$buf eq {}} {
return -code error EAGAIN
}
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.2
return
|
