Filename | /usr/local/lib/perl5/5.24/Net/Cmd.pm |
Statements | Executed 37 statements in 7.07ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 60µs | 60µs | BEGIN@13 | Net::Cmd::
1 | 1 | 1 | 30µs | 74µs | BEGIN@16 | Net::Cmd::
1 | 1 | 1 | 26µs | 90µs | BEGIN@19 | Net::Cmd::
1 | 1 | 1 | 24µs | 39µs | BEGIN@15 | Net::Cmd::
1 | 1 | 1 | 23µs | 216µs | BEGIN@35 | Net::Cmd::
1 | 1 | 1 | 23µs | 154µs | BEGIN@37 | Net::Cmd::
1 | 1 | 1 | 22µs | 79µs | BEGIN@72 | Net::Cmd::
1 | 1 | 1 | 22µs | 200µs | BEGIN@18 | Net::Cmd::
1 | 1 | 1 | 22µs | 182µs | BEGIN@20 | Net::Cmd::
1 | 1 | 1 | 22µs | 106µs | BEGIN@21 | Net::Cmd::
1 | 1 | 1 | 21µs | 155µs | BEGIN@36 | Net::Cmd::
1 | 1 | 1 | 18µs | 144µs | BEGIN@42 | Net::Cmd::
1 | 1 | 1 | 18µs | 159µs | BEGIN@40 | Net::Cmd::
1 | 1 | 1 | 18µs | 142µs | BEGIN@38 | Net::Cmd::
1 | 1 | 1 | 18µs | 144µs | BEGIN@39 | Net::Cmd::
1 | 1 | 1 | 11µs | 11µs | BEGIN@23 | Net::Cmd::
0 | 0 | 0 | 0s | 0s | CLOSE | Net::Cmd::
0 | 0 | 0 | 0s | 0s | |
0 | 0 | 0 | 0s | 0s | READ | Net::Cmd::
0 | 0 | 0 | 0s | 0s | READLINE | Net::Cmd::
0 | 0 | 0 | 0s | 0s | TIEHANDLE | Net::Cmd::
0 | 0 | 0 | 0s | 0s | _is_closed | Net::Cmd::
0 | 0 | 0 | 0s | 0s | _print_isa | Net::Cmd::
0 | 0 | 0 | 0s | 0s | _set_status_closed | Net::Cmd::
0 | 0 | 0 | 0s | 0s | _set_status_timeout | Net::Cmd::
0 | 0 | 0 | 0s | 0s | _syswrite_with_timeout | Net::Cmd::
0 | 0 | 0 | 0s | 0s | code | Net::Cmd::
0 | 0 | 0 | 0s | 0s | command | Net::Cmd::
0 | 0 | 0 | 0s | 0s | dataend | Net::Cmd::
0 | 0 | 0 | 0s | 0s | datasend | Net::Cmd::
0 | 0 | 0 | 0s | 0s | debug | Net::Cmd::
0 | 0 | 0 | 0s | 0s | debug_print | Net::Cmd::
0 | 0 | 0 | 0s | 0s | debug_text | Net::Cmd::
0 | 0 | 0 | 0s | 0s | getline | Net::Cmd::
0 | 0 | 0 | 0s | 0s | message | Net::Cmd::
0 | 0 | 0 | 0s | 0s | ok | Net::Cmd::
0 | 0 | 0 | 0s | 0s | parse_response | Net::Cmd::
0 | 0 | 0 | 0s | 0s | rawdatasend | Net::Cmd::
0 | 0 | 0 | 0s | 0s | read_until_dot | Net::Cmd::
0 | 0 | 0 | 0s | 0s | response | Net::Cmd::
0 | 0 | 0 | 0s | 0s | set_status | Net::Cmd::
0 | 0 | 0 | 0s | 0s | status | Net::Cmd::
0 | 0 | 0 | 0s | 0s | tied_fh | Net::Cmd::
0 | 0 | 0 | 0s | 0s | toascii | Net::Cmd::
0 | 0 | 0 | 0s | 0s | toebcdic | Net::Cmd::
0 | 0 | 0 | 0s | 0s | ungetline | Net::Cmd::
0 | 0 | 0 | 0s | 0s | unsupported | Net::Cmd::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # Net::Cmd.pm | ||||
2 | # | ||||
3 | # Versions up to 2.29_1 Copyright (c) 1995-2006 Graham Barr <gbarr@pobox.com>. | ||||
4 | # All rights reserved. | ||||
5 | # Changes in Version 2.29_2 onwards Copyright (C) 2013-2015 Steve Hay. All | ||||
6 | # rights reserved. | ||||
7 | # This module is free software; you can redistribute it and/or modify it under | ||||
8 | # the same terms as Perl itself, i.e. under the terms of either the GNU General | ||||
9 | # Public License or the Artistic License, as specified in the F<LICENCE> file. | ||||
10 | |||||
11 | package Net::Cmd; | ||||
12 | |||||
13 | 2 | 114µs | 1 | 60µs | # spent 60µs within Net::Cmd::BEGIN@13 which was called:
# once (60µs+0s) by Net::SMTP::BEGIN@20 at line 13 # spent 60µs making 1 call to Net::Cmd::BEGIN@13 |
14 | |||||
15 | 2 | 66µs | 2 | 54µs | # spent 39µs (24+15) within Net::Cmd::BEGIN@15 which was called:
# once (24µs+15µs) by Net::SMTP::BEGIN@20 at line 15 # spent 39µs making 1 call to Net::Cmd::BEGIN@15
# spent 15µs making 1 call to strict::import |
16 | 2 | 68µs | 2 | 117µs | # spent 74µs (30+43) within Net::Cmd::BEGIN@16 which was called:
# once (30µs+43µs) by Net::SMTP::BEGIN@20 at line 16 # spent 74µs making 1 call to Net::Cmd::BEGIN@16
# spent 43µs making 1 call to warnings::import |
17 | |||||
18 | 2 | 62µs | 2 | 378µs | # spent 200µs (22+178) within Net::Cmd::BEGIN@18 which was called:
# once (22µs+178µs) by Net::SMTP::BEGIN@20 at line 18 # spent 200µs making 1 call to Net::Cmd::BEGIN@18
# spent 178µs making 1 call to Exporter::import |
19 | 2 | 62µs | 2 | 155µs | # spent 90µs (26+64) within Net::Cmd::BEGIN@19 which was called:
# once (26µs+64µs) by Net::SMTP::BEGIN@20 at line 19 # spent 90µs making 1 call to Net::Cmd::BEGIN@19
# spent 64µs making 1 call to Exporter::import |
20 | 2 | 67µs | 2 | 341µs | # spent 182µs (22+160) within Net::Cmd::BEGIN@20 which was called:
# once (22µs+160µs) by Net::SMTP::BEGIN@20 at line 20 # spent 182µs making 1 call to Net::Cmd::BEGIN@20
# spent 160µs making 1 call to Exporter::import |
21 | 2 | 116µs | 2 | 190µs | # spent 106µs (22+84) within Net::Cmd::BEGIN@21 which was called:
# once (22µs+84µs) by Net::SMTP::BEGIN@20 at line 21 # spent 106µs making 1 call to Net::Cmd::BEGIN@21
# spent 84µs making 1 call to Exporter::import |
22 | |||||
23 | # spent 11µs within Net::Cmd::BEGIN@23 which was called:
# once (11µs+0s) by Net::SMTP::BEGIN@20 at line 29 | ||||
24 | 1 | 11µs | if ($^O eq 'os390') { | ||
25 | require Convert::EBCDIC; | ||||
26 | |||||
27 | # Convert::EBCDIC->import; | ||||
28 | } | ||||
29 | 1 | 123µs | 1 | 11µs | } # spent 11µs making 1 call to Net::Cmd::BEGIN@23 |
30 | |||||
31 | 1 | 2µs | our $VERSION = "3.08_01"; | ||
32 | 1 | 22µs | our @ISA = qw(Exporter); | ||
33 | 1 | 4µs | our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); | ||
34 | |||||
35 | 2 | 69µs | 2 | 409µs | # spent 216µs (23+193) within Net::Cmd::BEGIN@35 which was called:
# once (23µs+193µs) by Net::SMTP::BEGIN@20 at line 35 # spent 216µs making 1 call to Net::Cmd::BEGIN@35
# spent 193µs making 1 call to constant::import |
36 | 2 | 55µs | 2 | 289µs | # spent 155µs (21+134) within Net::Cmd::BEGIN@36 which was called:
# once (21µs+134µs) by Net::SMTP::BEGIN@20 at line 36 # spent 155µs making 1 call to Net::Cmd::BEGIN@36
# spent 134µs making 1 call to constant::import |
37 | 2 | 54µs | 2 | 286µs | # spent 154µs (23+131) within Net::Cmd::BEGIN@37 which was called:
# once (23µs+131µs) by Net::SMTP::BEGIN@20 at line 37 # spent 154µs making 1 call to Net::Cmd::BEGIN@37
# spent 131µs making 1 call to constant::import |
38 | 2 | 53µs | 2 | 267µs | # spent 142µs (18+125) within Net::Cmd::BEGIN@38 which was called:
# once (18µs+125µs) by Net::SMTP::BEGIN@20 at line 38 # spent 142µs making 1 call to Net::Cmd::BEGIN@38
# spent 125µs making 1 call to constant::import |
39 | 2 | 56µs | 2 | 271µs | # spent 144µs (18+127) within Net::Cmd::BEGIN@39 which was called:
# once (18µs+127µs) by Net::SMTP::BEGIN@20 at line 39 # spent 144µs making 1 call to Net::Cmd::BEGIN@39
# spent 127µs making 1 call to constant::import |
40 | 2 | 62µs | 2 | 300µs | # spent 159µs (18+141) within Net::Cmd::BEGIN@40 which was called:
# once (18µs+141µs) by Net::SMTP::BEGIN@20 at line 40 # spent 159µs making 1 call to Net::Cmd::BEGIN@40
# spent 141µs making 1 call to constant::import |
41 | |||||
42 | 2 | 471µs | 2 | 270µs | # spent 144µs (18+126) within Net::Cmd::BEGIN@42 which was called:
# once (18µs+126µs) by Net::SMTP::BEGIN@20 at line 42 # spent 144µs making 1 call to Net::Cmd::BEGIN@42
# spent 125µs making 1 call to constant::import |
43 | |||||
44 | 1 | 4µs | my %debug = (); | ||
45 | |||||
46 | 1 | 4µs | my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef; | ||
47 | |||||
48 | sub toebcdic { | ||||
49 | my $cmd = shift; | ||||
50 | |||||
51 | unless (exists ${*$cmd}{'net_cmd_asciipeer'}) { | ||||
52 | my $string = $_[0]; | ||||
53 | my $ebcdicstr = $tr->toebcdic($string); | ||||
54 | ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/; | ||||
55 | } | ||||
56 | |||||
57 | ${*$cmd}{'net_cmd_asciipeer'} | ||||
58 | ? $tr->toebcdic($_[0]) | ||||
59 | : $_[0]; | ||||
60 | } | ||||
61 | |||||
62 | |||||
63 | sub toascii { | ||||
64 | my $cmd = shift; | ||||
65 | ${*$cmd}{'net_cmd_asciipeer'} | ||||
66 | ? $tr->toascii($_[0]) | ||||
67 | : $_[0]; | ||||
68 | } | ||||
69 | |||||
70 | |||||
71 | sub _print_isa { | ||||
72 | 2 | 5.51ms | 2 | 136µs | # spent 79µs (22+57) within Net::Cmd::BEGIN@72 which was called:
# once (22µs+57µs) by Net::SMTP::BEGIN@20 at line 72 # spent 79µs making 1 call to Net::Cmd::BEGIN@72
# spent 57µs making 1 call to strict::unimport |
73 | |||||
74 | my $pkg = shift; | ||||
75 | my $cmd = $pkg; | ||||
76 | |||||
77 | $debug{$pkg} ||= 0; | ||||
78 | |||||
79 | my %done = (); | ||||
80 | my @do = ($pkg); | ||||
81 | my %spc = ($pkg, ""); | ||||
82 | |||||
83 | while ($pkg = shift @do) { | ||||
84 | next if defined $done{$pkg}; | ||||
85 | |||||
86 | $done{$pkg} = 1; | ||||
87 | |||||
88 | my $v = | ||||
89 | defined ${"${pkg}::VERSION"} | ||||
90 | ? "(" . ${"${pkg}::VERSION"} . ")" | ||||
91 | : ""; | ||||
92 | |||||
93 | my $spc = $spc{$pkg}; | ||||
94 | $cmd->debug_print(1, "${spc}${pkg}${v}\n"); | ||||
95 | |||||
96 | if (@{"${pkg}::ISA"}) { | ||||
97 | @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"}; | ||||
98 | unshift(@do, @{"${pkg}::ISA"}); | ||||
99 | } | ||||
100 | } | ||||
101 | } | ||||
102 | |||||
103 | |||||
104 | sub debug { | ||||
105 | @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])'; | ||||
106 | |||||
107 | my ($cmd, $level) = @_; | ||||
108 | my $pkg = ref($cmd) || $cmd; | ||||
109 | my $oldval = 0; | ||||
110 | |||||
111 | if (ref($cmd)) { | ||||
112 | $oldval = ${*$cmd}{'net_cmd_debug'} || 0; | ||||
113 | } | ||||
114 | else { | ||||
115 | $oldval = $debug{$pkg} || 0; | ||||
116 | } | ||||
117 | |||||
118 | return $oldval | ||||
119 | unless @_ == 2; | ||||
120 | |||||
121 | $level = $debug{$pkg} || 0 | ||||
122 | unless defined $level; | ||||
123 | |||||
124 | _print_isa($pkg) | ||||
125 | if ($level && !exists $debug{$pkg}); | ||||
126 | |||||
127 | if (ref($cmd)) { | ||||
128 | ${*$cmd}{'net_cmd_debug'} = $level; | ||||
129 | } | ||||
130 | else { | ||||
131 | $debug{$pkg} = $level; | ||||
132 | } | ||||
133 | |||||
134 | $oldval; | ||||
135 | } | ||||
136 | |||||
137 | |||||
138 | sub message { | ||||
139 | @_ == 1 or croak 'usage: $obj->message()'; | ||||
140 | |||||
141 | my $cmd = shift; | ||||
142 | |||||
143 | wantarray | ||||
144 | ? @{${*$cmd}{'net_cmd_resp'}} | ||||
145 | : join("", @{${*$cmd}{'net_cmd_resp'}}); | ||||
146 | } | ||||
147 | |||||
148 | |||||
149 | sub debug_text { $_[2] } | ||||
150 | |||||
151 | |||||
152 | sub debug_print { | ||||
153 | my ($cmd, $out, $text) = @_; | ||||
154 | print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text); | ||||
155 | } | ||||
156 | |||||
157 | |||||
158 | sub code { | ||||
159 | @_ == 1 or croak 'usage: $obj->code()'; | ||||
160 | |||||
161 | my $cmd = shift; | ||||
162 | |||||
163 | ${*$cmd}{'net_cmd_code'} = $cmd->DEF_REPLY_CODE | ||||
164 | unless exists ${*$cmd}{'net_cmd_code'}; | ||||
165 | |||||
166 | ${*$cmd}{'net_cmd_code'}; | ||||
167 | } | ||||
168 | |||||
169 | |||||
170 | sub status { | ||||
171 | @_ == 1 or croak 'usage: $obj->status()'; | ||||
172 | |||||
173 | my $cmd = shift; | ||||
174 | |||||
175 | substr(${*$cmd}{'net_cmd_code'}, 0, 1); | ||||
176 | } | ||||
177 | |||||
178 | |||||
179 | sub set_status { | ||||
180 | @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)'; | ||||
181 | |||||
182 | my $cmd = shift; | ||||
183 | my ($code, $resp) = @_; | ||||
184 | |||||
185 | $resp = defined $resp ? [$resp] : [] | ||||
186 | unless ref($resp); | ||||
187 | |||||
188 | (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp); | ||||
189 | |||||
190 | 1; | ||||
191 | } | ||||
192 | |||||
193 | sub _syswrite_with_timeout { | ||||
194 | my $cmd = shift; | ||||
195 | my $line = shift; | ||||
196 | |||||
197 | my $len = length($line); | ||||
198 | my $offset = 0; | ||||
199 | my $win = ""; | ||||
200 | vec($win, fileno($cmd), 1) = 1; | ||||
201 | my $timeout = $cmd->timeout || undef; | ||||
202 | my $initial = time; | ||||
203 | my $pending = $timeout; | ||||
204 | |||||
205 | local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; | ||||
206 | |||||
207 | while ($len) { | ||||
208 | my $wout; | ||||
209 | my $nfound = select(undef, $wout = $win, undef, $pending); | ||||
210 | if ((defined $nfound and $nfound > 0) or -f $cmd) # -f for testing on win32 | ||||
211 | { | ||||
212 | my $w = syswrite($cmd, $line, $len, $offset); | ||||
213 | if (! defined($w) ) { | ||||
214 | my $err = $!; | ||||
215 | $cmd->close; | ||||
216 | $cmd->_set_status_closed($err); | ||||
217 | return; | ||||
218 | } | ||||
219 | $len -= $w; | ||||
220 | $offset += $w; | ||||
221 | } | ||||
222 | elsif ($nfound == -1) { | ||||
223 | if ( $! == EINTR ) { | ||||
224 | if ( defined($timeout) ) { | ||||
225 | redo if ($pending = $timeout - ( time - $initial ) ) > 0; | ||||
226 | $cmd->_set_status_timeout; | ||||
227 | return; | ||||
228 | } | ||||
229 | redo; | ||||
230 | } | ||||
231 | my $err = $!; | ||||
232 | $cmd->close; | ||||
233 | $cmd->_set_status_closed($err); | ||||
234 | return; | ||||
235 | } | ||||
236 | else { | ||||
237 | $cmd->_set_status_timeout; | ||||
238 | return; | ||||
239 | } | ||||
240 | } | ||||
241 | |||||
242 | return 1; | ||||
243 | } | ||||
244 | |||||
245 | sub _set_status_timeout { | ||||
246 | my $cmd = shift; | ||||
247 | my $pkg = ref($cmd) || $cmd; | ||||
248 | |||||
249 | $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Timeout"); | ||||
250 | carp(ref($cmd) . ": " . (caller(1))[3] . "(): timeout") if $cmd->debug; | ||||
251 | } | ||||
252 | |||||
253 | sub _set_status_closed { | ||||
254 | my $cmd = shift; | ||||
255 | my $err = shift; | ||||
256 | my $pkg = ref($cmd) || $cmd; | ||||
257 | |||||
258 | $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Connection closed"); | ||||
259 | carp(ref($cmd) . ": " . (caller(1))[3] | ||||
260 | . "(): unexpected EOF on command channel: $err") if $cmd->debug; | ||||
261 | } | ||||
262 | |||||
263 | sub _is_closed { | ||||
264 | my $cmd = shift; | ||||
265 | if (!defined fileno($cmd)) { | ||||
266 | $cmd->_set_status_closed($!); | ||||
267 | return 1; | ||||
268 | } | ||||
269 | return 0; | ||||
270 | } | ||||
271 | |||||
272 | sub command { | ||||
273 | my $cmd = shift; | ||||
274 | |||||
275 | return $cmd | ||||
276 | if $cmd->_is_closed; | ||||
277 | |||||
278 | $cmd->dataend() | ||||
279 | if (exists ${*$cmd}{'net_cmd_last_ch'}); | ||||
280 | |||||
281 | if (scalar(@_)) { | ||||
282 | my $str = join( | ||||
283 | " ", | ||||
284 | map { | ||||
285 | /\n/ | ||||
286 | ? do { my $n = $_; $n =~ tr/\n/ /; $n } | ||||
287 | : $_; | ||||
288 | } @_ | ||||
289 | ); | ||||
290 | $str = $cmd->toascii($str) if $tr; | ||||
291 | $str .= "\015\012"; | ||||
292 | |||||
293 | $cmd->debug_print(1, $str) | ||||
294 | if ($cmd->debug); | ||||
295 | |||||
296 | # though documented to return undef on failure, the legacy behavior | ||||
297 | # was to return $cmd even on failure, so this odd construct does that | ||||
298 | $cmd->_syswrite_with_timeout($str) | ||||
299 | or return $cmd; | ||||
300 | } | ||||
301 | |||||
302 | $cmd; | ||||
303 | } | ||||
304 | |||||
305 | |||||
306 | sub ok { | ||||
307 | @_ == 1 or croak 'usage: $obj->ok()'; | ||||
308 | |||||
309 | my $code = $_[0]->code; | ||||
310 | 0 < $code && $code < 400; | ||||
311 | } | ||||
312 | |||||
313 | |||||
314 | sub unsupported { | ||||
315 | my $cmd = shift; | ||||
316 | |||||
317 | $cmd->set_status(580, 'Unsupported command'); | ||||
318 | |||||
319 | 0; | ||||
320 | } | ||||
321 | |||||
322 | |||||
323 | sub getline { | ||||
324 | my $cmd = shift; | ||||
325 | |||||
326 | ${*$cmd}{'net_cmd_lines'} ||= []; | ||||
327 | |||||
328 | return shift @{${*$cmd}{'net_cmd_lines'}} | ||||
329 | if scalar(@{${*$cmd}{'net_cmd_lines'}}); | ||||
330 | |||||
331 | my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : ""; | ||||
332 | |||||
333 | return | ||||
334 | if $cmd->_is_closed; | ||||
335 | |||||
336 | my $fd = fileno($cmd); | ||||
337 | my $rin = ""; | ||||
338 | vec($rin, $fd, 1) = 1; | ||||
339 | |||||
340 | my $buf; | ||||
341 | |||||
342 | until (scalar(@{${*$cmd}{'net_cmd_lines'}})) { | ||||
343 | my $timeout = $cmd->timeout || undef; | ||||
344 | my $rout; | ||||
345 | |||||
346 | my $select_ret = select($rout = $rin, undef, undef, $timeout); | ||||
347 | if ($select_ret > 0) { | ||||
348 | unless (sysread($cmd, $buf = "", 1024)) { | ||||
349 | my $err = $!; | ||||
350 | $cmd->close; | ||||
351 | $cmd->_set_status_closed($err); | ||||
352 | return; | ||||
353 | } | ||||
354 | |||||
355 | substr($buf, 0, 0) = $partial; ## prepend from last sysread | ||||
356 | |||||
357 | my @buf = split(/\015?\012/, $buf, -1); ## break into lines | ||||
358 | |||||
359 | $partial = pop @buf; | ||||
360 | |||||
361 | push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf); | ||||
362 | |||||
363 | } | ||||
364 | else { | ||||
365 | $cmd->_set_status_timeout; | ||||
366 | return; | ||||
367 | } | ||||
368 | } | ||||
369 | |||||
370 | ${*$cmd}{'net_cmd_partial'} = $partial; | ||||
371 | |||||
372 | if ($tr) { | ||||
373 | foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) { | ||||
374 | $ln = $cmd->toebcdic($ln); | ||||
375 | } | ||||
376 | } | ||||
377 | |||||
378 | shift @{${*$cmd}{'net_cmd_lines'}}; | ||||
379 | } | ||||
380 | |||||
381 | |||||
382 | sub ungetline { | ||||
383 | my ($cmd, $str) = @_; | ||||
384 | |||||
385 | ${*$cmd}{'net_cmd_lines'} ||= []; | ||||
386 | unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); | ||||
387 | } | ||||
388 | |||||
389 | |||||
390 | sub parse_response { | ||||
391 | return () | ||||
392 | unless $_[1] =~ s/^(\d\d\d)(.?)//o; | ||||
393 | ($1, $2 eq "-"); | ||||
394 | } | ||||
395 | |||||
396 | |||||
397 | sub response { | ||||
398 | my $cmd = shift; | ||||
399 | my ($code, $more) = (undef) x 2; | ||||
400 | |||||
401 | $cmd->set_status($cmd->DEF_REPLY_CODE, undef); # initialize the response | ||||
402 | |||||
403 | while (1) { | ||||
404 | my $str = $cmd->getline(); | ||||
405 | |||||
406 | return CMD_ERROR | ||||
407 | unless defined($str); | ||||
408 | |||||
409 | $cmd->debug_print(0, $str) | ||||
410 | if ($cmd->debug); | ||||
411 | |||||
412 | ($code, $more) = $cmd->parse_response($str); | ||||
413 | unless (defined $code) { | ||||
414 | carp("$cmd: response(): parse error in '$str'") if ($cmd->debug); | ||||
415 | $cmd->ungetline($str); | ||||
416 | $@ = $str; # $@ used as tunneling hack | ||||
417 | return CMD_ERROR; | ||||
418 | } | ||||
419 | |||||
420 | ${*$cmd}{'net_cmd_code'} = $code; | ||||
421 | |||||
422 | push(@{${*$cmd}{'net_cmd_resp'}}, $str); | ||||
423 | |||||
424 | last unless ($more); | ||||
425 | } | ||||
426 | |||||
427 | return unless defined $code; | ||||
428 | substr($code, 0, 1); | ||||
429 | } | ||||
430 | |||||
431 | |||||
432 | sub read_until_dot { | ||||
433 | my $cmd = shift; | ||||
434 | my $fh = shift; | ||||
435 | my $arr = []; | ||||
436 | |||||
437 | while (1) { | ||||
438 | my $str = $cmd->getline() or return; | ||||
439 | |||||
440 | $cmd->debug_print(0, $str) | ||||
441 | if ($cmd->debug & 4); | ||||
442 | |||||
443 | last if ($str =~ /^\.\r?\n/o); | ||||
444 | |||||
445 | $str =~ s/^\.\././o; | ||||
446 | |||||
447 | if (defined $fh) { | ||||
448 | print $fh $str; | ||||
449 | } | ||||
450 | else { | ||||
451 | push(@$arr, $str); | ||||
452 | } | ||||
453 | } | ||||
454 | |||||
455 | $arr; | ||||
456 | } | ||||
457 | |||||
458 | |||||
459 | sub datasend { | ||||
460 | my $cmd = shift; | ||||
461 | my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; | ||||
462 | my $line = join("", @$arr); | ||||
463 | |||||
464 | # Perls < 5.10.1 (with the exception of 5.8.9) have a performance problem with | ||||
465 | # the substitutions below when dealing with strings stored internally in | ||||
466 | # UTF-8, so downgrade them (if possible). | ||||
467 | # Data passed to datasend() should be encoded to octets upstream already so | ||||
468 | # shouldn't even have the UTF-8 flag on to start with, but if it so happens | ||||
469 | # that the octets are stored in an upgraded string (as can sometimes occur) | ||||
470 | # then they would still downgrade without fail anyway. | ||||
471 | # Only Unicode codepoints > 0xFF stored in an upgraded string will fail to | ||||
472 | # downgrade. We fail silently in that case, and a "Wide character in print" | ||||
473 | # warning will be emitted later by syswrite(). | ||||
474 | utf8::downgrade($line, 1) if $] < 5.010001 && $] != 5.008009; | ||||
475 | |||||
476 | return 0 | ||||
477 | if $cmd->_is_closed; | ||||
478 | |||||
479 | my $last_ch = ${*$cmd}{'net_cmd_last_ch'}; | ||||
480 | |||||
481 | # We have not send anything yet, so last_ch = "\012" means we are at the start of a line | ||||
482 | $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch; | ||||
483 | |||||
484 | return 1 unless length $line; | ||||
485 | |||||
486 | if ($cmd->debug) { | ||||
487 | foreach my $b (split(/\n/, $line)) { | ||||
488 | $cmd->debug_print(1, "$b\n"); | ||||
489 | } | ||||
490 | } | ||||
491 | |||||
492 | $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; | ||||
493 | |||||
494 | my $first_ch = ''; | ||||
495 | |||||
496 | if ($last_ch eq "\015") { | ||||
497 | # Remove \012 so it does not get prefixed with another \015 below | ||||
498 | # and escape the . if there is one following it because the fixup | ||||
499 | # below will not find it | ||||
500 | $first_ch = "\012" if $line =~ s/^\012(\.?)/$1$1/; | ||||
501 | } | ||||
502 | elsif ($last_ch eq "\012") { | ||||
503 | # Fixup below will not find the . as the first character of the buffer | ||||
504 | $first_ch = "." if $line =~ /^\./; | ||||
505 | } | ||||
506 | |||||
507 | $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; | ||||
508 | |||||
509 | substr($line, 0, 0) = $first_ch; | ||||
510 | |||||
511 | ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1); | ||||
512 | |||||
513 | $cmd->_syswrite_with_timeout($line) | ||||
514 | or return; | ||||
515 | |||||
516 | 1; | ||||
517 | } | ||||
518 | |||||
519 | |||||
520 | sub rawdatasend { | ||||
521 | my $cmd = shift; | ||||
522 | my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; | ||||
523 | my $line = join("", @$arr); | ||||
524 | |||||
525 | return 0 | ||||
526 | if $cmd->_is_closed; | ||||
527 | |||||
528 | return 1 | ||||
529 | unless length($line); | ||||
530 | |||||
531 | if ($cmd->debug) { | ||||
532 | my $b = "$cmd>>> "; | ||||
533 | print STDERR $b, join("\n$b", split(/\n/, $line)), "\n"; | ||||
534 | } | ||||
535 | |||||
536 | $cmd->_syswrite_with_timeout($line) | ||||
537 | or return; | ||||
538 | |||||
539 | 1; | ||||
540 | } | ||||
541 | |||||
542 | |||||
543 | sub dataend { | ||||
544 | my $cmd = shift; | ||||
545 | |||||
546 | return 0 | ||||
547 | if $cmd->_is_closed; | ||||
548 | |||||
549 | my $ch = ${*$cmd}{'net_cmd_last_ch'}; | ||||
550 | my $tosend; | ||||
551 | |||||
552 | if (!defined $ch) { | ||||
553 | return 1; | ||||
554 | } | ||||
555 | elsif ($ch ne "\012") { | ||||
556 | $tosend = "\015\012"; | ||||
557 | } | ||||
558 | |||||
559 | $tosend .= ".\015\012"; | ||||
560 | |||||
561 | $cmd->debug_print(1, ".\n") | ||||
562 | if ($cmd->debug); | ||||
563 | |||||
564 | $cmd->_syswrite_with_timeout($tosend) | ||||
565 | or return 0; | ||||
566 | |||||
567 | delete ${*$cmd}{'net_cmd_last_ch'}; | ||||
568 | |||||
569 | $cmd->response() == CMD_OK; | ||||
570 | } | ||||
571 | |||||
572 | # read and write to tied filehandle | ||||
573 | sub tied_fh { | ||||
574 | my $cmd = shift; | ||||
575 | ${*$cmd}{'net_cmd_readbuf'} = ''; | ||||
576 | my $fh = gensym(); | ||||
577 | tie *$fh, ref($cmd), $cmd; | ||||
578 | return $fh; | ||||
579 | } | ||||
580 | |||||
581 | # tie to myself | ||||
582 | sub TIEHANDLE { | ||||
583 | my $class = shift; | ||||
584 | my $cmd = shift; | ||||
585 | return $cmd; | ||||
586 | } | ||||
587 | |||||
588 | # Tied filehandle read. Reads requested data length, returning | ||||
589 | # end-of-file when the dot is encountered. | ||||
590 | sub READ { | ||||
591 | my $cmd = shift; | ||||
592 | my ($len, $offset) = @_[1, 2]; | ||||
593 | return unless exists ${*$cmd}{'net_cmd_readbuf'}; | ||||
594 | my $done = 0; | ||||
595 | while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) { | ||||
596 | ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return; | ||||
597 | $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m; | ||||
598 | } | ||||
599 | |||||
600 | $_[0] = ''; | ||||
601 | substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len); | ||||
602 | substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = ''; | ||||
603 | delete ${*$cmd}{'net_cmd_readbuf'} if $done; | ||||
604 | |||||
605 | return length $_[0]; | ||||
606 | } | ||||
607 | |||||
608 | |||||
609 | sub READLINE { | ||||
610 | my $cmd = shift; | ||||
611 | |||||
612 | # in this context, we use the presence of readbuf to | ||||
613 | # indicate that we have not yet reached the eof | ||||
614 | return unless exists ${*$cmd}{'net_cmd_readbuf'}; | ||||
615 | my $line = $cmd->getline; | ||||
616 | return if $line =~ /^\.\r?\n/; | ||||
617 | $line; | ||||
618 | } | ||||
619 | |||||
620 | |||||
621 | sub PRINT { | ||||
622 | my $cmd = shift; | ||||
623 | my ($buf, $len, $offset) = @_; | ||||
624 | $len ||= length($buf); | ||||
625 | $offset += 0; | ||||
626 | return unless $cmd->datasend(substr($buf, $offset, $len)); | ||||
627 | ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend() | ||||
628 | return $len; | ||||
629 | } | ||||
630 | |||||
631 | |||||
632 | sub CLOSE { | ||||
633 | my $cmd = shift; | ||||
634 | my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; | ||||
635 | delete ${*$cmd}{'net_cmd_readbuf'}; | ||||
636 | delete ${*$cmd}{'net_cmd_sending'}; | ||||
637 | $r; | ||||
638 | } | ||||
639 | |||||
640 | 1 | 18µs | 1; | ||
641 | |||||
642 | __END__ |