line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyrights 2011-2015 by [Mark Overmeer]. |
2
|
|
|
|
|
|
|
# For other contributors see ChangeLog. |
3
|
|
|
|
|
|
|
# See the manual pages for details on the licensing terms. |
4
|
|
|
|
|
|
|
# Pod stripped from pm file by OODoc 2.02. |
5
|
8
|
|
|
8
|
|
821
|
use warnings; |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
248
|
|
6
|
8
|
|
|
8
|
|
40
|
use strict; |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
307
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
package IOMux::Handler::Write; |
9
|
8
|
|
|
8
|
|
38
|
use vars '$VERSION'; |
|
8
|
|
|
|
|
10
|
|
|
8
|
|
|
|
|
346
|
|
10
|
|
|
|
|
|
|
$VERSION = '1.00'; |
11
|
|
|
|
|
|
|
|
12
|
8
|
|
|
8
|
|
39
|
use base 'IOMux::Handler'; |
|
8
|
|
|
|
|
22
|
|
|
8
|
|
|
|
|
2115
|
|
13
|
|
|
|
|
|
|
|
14
|
8
|
|
|
8
|
|
45
|
use Log::Report 'iomux'; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
59
|
|
15
|
8
|
|
|
8
|
|
2106
|
use Fcntl; |
|
8
|
|
|
|
|
20
|
|
|
8
|
|
|
|
|
2541
|
|
16
|
8
|
|
|
8
|
|
45
|
use POSIX 'errno_h'; |
|
8
|
|
|
|
|
9
|
|
|
8
|
|
|
|
|
66
|
|
17
|
8
|
|
|
8
|
|
3760
|
use File::Spec ();; |
|
8
|
|
|
|
|
21
|
|
|
8
|
|
|
|
|
210
|
|
18
|
8
|
|
|
8
|
|
39
|
use File::Basename 'basename'; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
457
|
|
19
|
|
|
|
|
|
|
|
20
|
8
|
|
|
8
|
|
44
|
use constant PIPE_BUF_SIZE => 4096; |
|
8
|
|
|
|
|
13
|
|
|
8
|
|
|
|
|
8306
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub init($) |
24
|
8
|
|
|
8
|
0
|
41
|
{ my ($self, $args) = @_; |
25
|
8
|
|
|
|
|
167
|
$self->SUPER::init($args); |
26
|
8
|
|
50
|
|
|
83
|
$self->{IMHW_write_size} = $args->{write_size} || 4096; |
27
|
8
|
|
|
|
|
21
|
$self; |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
#------------------- |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub writeSize(;$) |
33
|
0
|
|
|
0
|
1
|
0
|
{ my $self = shift; |
34
|
0
|
0
|
|
|
|
0
|
@_ ? $self->{IMHW_write_size} = shift : $self->{IMHW_write_size}; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
#----------------------- |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub print(@) |
40
|
6
|
|
|
6
|
1
|
1476
|
{ my $self = shift; |
41
|
|
|
|
|
|
|
$self->write( !ref $_[0] ? (@_>1 ? \join('',@_) : \shift) |
42
|
6
|
50
|
|
|
|
40
|
: ref $_[0] eq 'ARRAY' ? \join('',@{$_[0]}) : $_[0] ); |
|
0
|
0
|
|
|
|
0
|
|
|
|
50
|
|
|
|
|
|
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub say(@) |
47
|
0
|
|
|
0
|
1
|
0
|
{ my $self = shift; |
48
|
|
|
|
|
|
|
$self->write |
49
|
|
|
|
|
|
|
( !ref $_[0] ? \join('',@_, "\n") |
50
|
0
|
0
|
|
|
|
0
|
: ref $_[0] eq 'ARRAY' ? \join('',@{$_[0]}, "\n") |
|
0
|
0
|
|
|
|
0
|
|
51
|
|
|
|
|
|
|
: $_[0]."\n" |
52
|
|
|
|
|
|
|
); |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub printf($@) |
57
|
0
|
|
|
0
|
1
|
0
|
{ my $self = shift; |
58
|
0
|
|
|
|
|
0
|
$self->write(\sprintf(@_)); |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub write($;$) |
63
|
12
|
|
|
12
|
1
|
1808
|
{ my ($self, $blob, $more) = @_; |
64
|
|
|
|
|
|
|
|
65
|
12
|
50
|
|
|
|
70
|
if(exists $self->{IMHW_outbuf}) |
66
|
|
|
|
|
|
|
{ # There is already output waiting, glue this |
67
|
0
|
|
|
|
|
0
|
${$self->{IMHW_outbuf}} .= $$blob; |
|
0
|
|
|
|
|
0
|
|
68
|
0
|
|
|
|
|
0
|
$self->{IMHW_more} = $more; |
69
|
0
|
|
|
|
|
0
|
return; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
|
73
|
12
|
|
|
|
|
41
|
my $bytes_written = syswrite $self->fh, $$blob, $self->{IMHW_write_size}; |
74
|
12
|
50
|
|
|
|
81
|
if(!defined $bytes_written) |
|
|
50
|
|
|
|
|
|
75
|
0
|
0
|
0
|
|
|
0
|
{ unless($!==EWOULDBLOCK || $!==EINTR) |
76
|
0
|
|
|
|
|
0
|
{ $self->close; |
77
|
0
|
|
|
|
|
0
|
fault __x"write to {name} failed", name => $self->name; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
# we cannot send the bytes yet |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
elsif($bytes_written==length $$blob) |
82
|
|
|
|
|
|
|
{ # we got rit of all at once. Cheap! No need to wait in mux |
83
|
12
|
50
|
|
|
|
38
|
$more->($self) if $more; |
84
|
|
|
|
|
|
|
$self->{IMHW_is_closing}->($self) |
85
|
12
|
50
|
|
|
|
32
|
if $self->{IMHW_is_closing}; |
86
|
12
|
|
|
|
|
33
|
return; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
else |
89
|
|
|
|
|
|
|
{ # some bytes sent |
90
|
0
|
|
|
|
|
0
|
substr($$blob, 0, $bytes_written) = ''; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# start waiting for write-ready flag, to send more |
94
|
0
|
|
|
|
|
0
|
$self->{IMHW_outbuf} = $blob; |
95
|
0
|
|
|
|
|
0
|
$self->{IMHW_more} = $more; |
96
|
0
|
|
|
|
|
0
|
$self->fdset(1, 0, 1, 0); |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
#------------------------- |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub muxInit($) |
103
|
7
|
|
|
7
|
1
|
18
|
{ my ($self, $mux) = @_; |
104
|
7
|
|
|
|
|
57
|
$self->SUPER::muxInit($mux); |
105
|
|
|
|
|
|
|
# $self->fdset(1, 0, 1, 0); |
106
|
7
|
|
|
|
|
387
|
$self->fdset(0, 0, 1, 0); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub muxWriteFlagged() |
110
|
0
|
|
|
0
|
1
|
0
|
{ my $self = shift; |
111
|
0
|
|
|
|
|
0
|
my $outbuf = $self->{IMHW_outbuf}; |
112
|
0
|
0
|
|
|
|
0
|
unless($outbuf) |
113
|
|
|
|
|
|
|
{ # trigger follow-up event, which may produce more data to be sent |
114
|
0
|
|
|
|
|
0
|
$self->muxOutbufferEmpty; |
115
|
0
|
|
|
|
|
0
|
$outbuf = $self->{IMHW_outbuf}; |
116
|
0
|
0
|
|
|
|
0
|
unless(defined $outbuf) |
117
|
|
|
|
|
|
|
{ # nothing can be produced on call, so we don't need the |
118
|
|
|
|
|
|
|
# empty-write signals on the moment (enabled at next write) |
119
|
0
|
|
|
|
|
0
|
return; |
120
|
|
|
|
|
|
|
} |
121
|
0
|
0
|
|
|
|
0
|
unless(length $$outbuf) |
122
|
|
|
|
|
|
|
{ # retry callback at next interval |
123
|
0
|
|
|
|
|
0
|
delete $self->{IMHW_outbuf}; |
124
|
0
|
|
|
|
|
0
|
return; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
0
|
|
|
|
|
0
|
my $bytes_written = syswrite $self->fh, $$outbuf, $self->{IMHW_write_size}; |
129
|
0
|
0
|
|
|
|
0
|
if(!defined $bytes_written) |
|
|
0
|
|
|
|
|
|
130
|
|
|
|
|
|
|
{ # should happen, but we're kind |
131
|
0
|
0
|
0
|
|
|
0
|
return if $! == EWOULDBLOCK || $! == EINTR || $! == EAGAIN; |
|
|
|
0
|
|
|
|
|
132
|
0
|
|
|
|
|
0
|
warning __x"write to {name} failed: {err}" |
133
|
|
|
|
|
|
|
, name => $self->name, err => $!; |
134
|
0
|
|
|
|
|
0
|
$self->close; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
elsif($bytes_written==length $$outbuf) |
137
|
0
|
|
|
|
|
0
|
{ delete $self->{IMHW_outbuf}; |
138
|
0
|
|
|
|
|
0
|
$self->muxOutbufferEmpty; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
else |
141
|
0
|
|
|
|
|
0
|
{ substr($$outbuf, 0, $bytes_written) = ''; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub muxOutbufferEmpty() |
147
|
0
|
|
|
0
|
1
|
0
|
{ my $self = shift; |
148
|
0
|
|
|
|
|
0
|
my $more = delete $self->{IMHW_more}; |
149
|
0
|
0
|
|
|
|
0
|
return $more->() if defined $more; |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
0
|
$self->fdset(0, 0, 1, 0); |
152
|
|
|
|
|
|
|
$self->{IMHW_is_closing}->($self) |
153
|
0
|
0
|
|
|
|
0
|
if $self->{IMHW_is_closing}; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
|
157
|
0
|
|
|
0
|
1
|
0
|
sub muxOutputWaiting() { exists shift->{IMHW_outbuf} } |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
# Closing write handlers is a little complex: it should be delayed |
160
|
|
|
|
|
|
|
# until the write buffer is empty. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub close(;$) |
163
|
10
|
|
|
10
|
1
|
1002
|
{ my ($self, $cb) = @_; |
164
|
10
|
50
|
|
|
|
29
|
if($self->{IMHW_outbuf}) |
165
|
|
|
|
|
|
|
{ # delay closing until write buffer is empty |
166
|
0
|
|
|
0
|
|
0
|
$self->{IMHW_is_closing} = sub { $self->SUPER::close($cb)}; |
|
0
|
|
|
|
|
0
|
|
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
else |
169
|
|
|
|
|
|
|
{ # can close immediately |
170
|
10
|
|
|
|
|
58
|
$self->SUPER::close($cb); |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
1; |