← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Tue Nov 7 05:38:10 2017
Reported on Tue Nov 7 06:16:04 2017

Filename/usr/local/lib/perl5/5.24/Net/Cmd.pm
StatementsExecuted 37 statements in 7.46ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11156µs56µsNet::Cmd::::BEGIN@13Net::Cmd::BEGIN@13
11134µs229µsNet::Cmd::::BEGIN@20Net::Cmd::BEGIN@20
11130µs156µsNet::Cmd::::BEGIN@21Net::Cmd::BEGIN@21
11126µs123µsNet::Cmd::::BEGIN@19Net::Cmd::BEGIN@19
11125µs41µsNet::Cmd::::BEGIN@15Net::Cmd::BEGIN@15
11125µs208µsNet::Cmd::::BEGIN@40Net::Cmd::BEGIN@40
11124µs213µsNet::Cmd::::BEGIN@42Net::Cmd::BEGIN@42
11123µs238µsNet::Cmd::::BEGIN@37Net::Cmd::BEGIN@37
11123µs75µsNet::Cmd::::BEGIN@72Net::Cmd::BEGIN@72
11123µs225µsNet::Cmd::::BEGIN@18Net::Cmd::BEGIN@18
11122µs244µsNet::Cmd::::BEGIN@35Net::Cmd::BEGIN@35
11122µs200µsNet::Cmd::::BEGIN@39Net::Cmd::BEGIN@39
11121µs44µsNet::Cmd::::BEGIN@16Net::Cmd::BEGIN@16
11121µs204µsNet::Cmd::::BEGIN@36Net::Cmd::BEGIN@36
11120µs263µsNet::Cmd::::BEGIN@38Net::Cmd::BEGIN@38
11112µs12µsNet::Cmd::::BEGIN@23Net::Cmd::BEGIN@23
0000s0sNet::Cmd::::CLOSENet::Cmd::CLOSE
0000s0sNet::Cmd::::PRINTNet::Cmd::PRINT
0000s0sNet::Cmd::::READNet::Cmd::READ
0000s0sNet::Cmd::::READLINENet::Cmd::READLINE
0000s0sNet::Cmd::::TIEHANDLENet::Cmd::TIEHANDLE
0000s0sNet::Cmd::::_is_closedNet::Cmd::_is_closed
0000s0sNet::Cmd::::_print_isaNet::Cmd::_print_isa
0000s0sNet::Cmd::::_set_status_closedNet::Cmd::_set_status_closed
0000s0sNet::Cmd::::_set_status_timeoutNet::Cmd::_set_status_timeout
0000s0sNet::Cmd::::_syswrite_with_timeoutNet::Cmd::_syswrite_with_timeout
0000s0sNet::Cmd::::codeNet::Cmd::code
0000s0sNet::Cmd::::commandNet::Cmd::command
0000s0sNet::Cmd::::dataendNet::Cmd::dataend
0000s0sNet::Cmd::::datasendNet::Cmd::datasend
0000s0sNet::Cmd::::debugNet::Cmd::debug
0000s0sNet::Cmd::::debug_printNet::Cmd::debug_print
0000s0sNet::Cmd::::debug_textNet::Cmd::debug_text
0000s0sNet::Cmd::::getlineNet::Cmd::getline
0000s0sNet::Cmd::::messageNet::Cmd::message
0000s0sNet::Cmd::::okNet::Cmd::ok
0000s0sNet::Cmd::::parse_responseNet::Cmd::parse_response
0000s0sNet::Cmd::::rawdatasendNet::Cmd::rawdatasend
0000s0sNet::Cmd::::read_until_dotNet::Cmd::read_until_dot
0000s0sNet::Cmd::::responseNet::Cmd::response
0000s0sNet::Cmd::::set_statusNet::Cmd::set_status
0000s0sNet::Cmd::::statusNet::Cmd::status
0000s0sNet::Cmd::::tied_fhNet::Cmd::tied_fh
0000s0sNet::Cmd::::toasciiNet::Cmd::toascii
0000s0sNet::Cmd::::toebcdicNet::Cmd::toebcdic
0000s0sNet::Cmd::::ungetlineNet::Cmd::ungetline
0000s0sNet::Cmd::::unsupportedNet::Cmd::unsupported
Call graph for these subroutines as a Graphviz dot language file.
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
11package Net::Cmd;
12
132109µs156µs
# spent 56µs within Net::Cmd::BEGIN@13 which was called: # once (56µs+0s) by Net::SMTP::BEGIN@20 at line 13
use 5.008001;
# spent 56µs making 1 call to Net::Cmd::BEGIN@13
14
15278µs257µs
# spent 41µs (25+16) within Net::Cmd::BEGIN@15 which was called: # once (25µs+16µs) by Net::SMTP::BEGIN@20 at line 15
use strict;
# spent 41µs making 1 call to Net::Cmd::BEGIN@15 # spent 16µs making 1 call to strict::import
16278µs267µs
# spent 44µs (21+23) within Net::Cmd::BEGIN@16 which was called: # once (21µs+23µs) by Net::SMTP::BEGIN@20 at line 16
use warnings;
# spent 44µs making 1 call to Net::Cmd::BEGIN@16 # spent 23µs making 1 call to warnings::import
17
18267µs2427µs
# spent 225µs (23+202) within Net::Cmd::BEGIN@18 which was called: # once (23µs+202µs) by Net::SMTP::BEGIN@20 at line 18
use Carp;
# spent 225µs making 1 call to Net::Cmd::BEGIN@18 # spent 202µs making 1 call to Exporter::import
19275µs2220µs
# spent 123µs (26+97) within Net::Cmd::BEGIN@19 which was called: # once (26µs+97µs) by Net::SMTP::BEGIN@20 at line 19
use Exporter;
# spent 123µs making 1 call to Net::Cmd::BEGIN@19 # spent 97µs making 1 call to Exporter::import
20286µs2424µs
# spent 229µs (34+195) within Net::Cmd::BEGIN@20 which was called: # once (34µs+195µs) by Net::SMTP::BEGIN@20 at line 20
use Symbol 'gensym';
# spent 229µs making 1 call to Net::Cmd::BEGIN@20 # spent 195µs making 1 call to Exporter::import
212113µs2282µs
# spent 156µs (30+126) within Net::Cmd::BEGIN@21 which was called: # once (30µs+126µs) by Net::SMTP::BEGIN@20 at line 21
use Errno 'EINTR';
# spent 156µs making 1 call to Net::Cmd::BEGIN@21 # spent 126µs making 1 call to Exporter::import
22
23
# spent 12µs within Net::Cmd::BEGIN@23 which was called: # once (12µs+0s) by Net::SMTP::BEGIN@20 at line 29
BEGIN {
24110µs if ($^O eq 'os390') {
25 require Convert::EBCDIC;
26
27 # Convert::EBCDIC->import;
28 }
291146µs112µs}
# spent 12µs making 1 call to Net::Cmd::BEGIN@23
30
3112µsour $VERSION = "3.08_01";
32122µsour @ISA = qw(Exporter);
3314µsour @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
34
35267µs2466µs
# spent 244µs (22+222) within Net::Cmd::BEGIN@35 which was called: # once (22µs+222µs) by Net::SMTP::BEGIN@20 at line 35
use constant CMD_INFO => 1;
# spent 244µs making 1 call to Net::Cmd::BEGIN@35 # spent 222µs making 1 call to constant::import
36263µs2387µs
# spent 204µs (21+183) within Net::Cmd::BEGIN@36 which was called: # once (21µs+183µs) by Net::SMTP::BEGIN@20 at line 36
use constant CMD_OK => 2;
# spent 204µs making 1 call to Net::Cmd::BEGIN@36 # spent 183µs making 1 call to constant::import
37274µs2453µs
# spent 238µs (23+215) within Net::Cmd::BEGIN@37 which was called: # once (23µs+215µs) by Net::SMTP::BEGIN@20 at line 37
use constant CMD_MORE => 3;
# spent 238µs making 1 call to Net::Cmd::BEGIN@37 # spent 215µs making 1 call to constant::import
382108µs2506µs
# spent 263µs (20+243) within Net::Cmd::BEGIN@38 which was called: # once (20µs+243µs) by Net::SMTP::BEGIN@20 at line 38
use constant CMD_REJECT => 4;
# spent 263µs making 1 call to Net::Cmd::BEGIN@38 # spent 243µs making 1 call to constant::import
39267µs2379µs
# spent 200µs (22+178) within Net::Cmd::BEGIN@39 which was called: # once (22µs+178µs) by Net::SMTP::BEGIN@20 at line 39
use constant CMD_ERROR => 5;
# spent 200µs making 1 call to Net::Cmd::BEGIN@39 # spent 178µs making 1 call to constant::import
40273µs2392µs
# spent 208µs (25+184) within Net::Cmd::BEGIN@40 which was called: # once (25µs+184µs) by Net::SMTP::BEGIN@20 at line 40
use constant CMD_PENDING => 0;
# spent 208µs making 1 call to Net::Cmd::BEGIN@40 # spent 184µs making 1 call to constant::import
41
422436µs2402µs
# spent 213µs (24+189) within Net::Cmd::BEGIN@42 which was called: # once (24µs+189µs) by Net::SMTP::BEGIN@20 at line 42
use constant DEF_REPLY_CODE => 421;
# spent 213µs making 1 call to Net::Cmd::BEGIN@42 # spent 189µs making 1 call to constant::import
43
4417µsmy %debug = ();
45
4614µsmy $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
47
48sub 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
63sub toascii {
64 my $cmd = shift;
65 ${*$cmd}{'net_cmd_asciipeer'}
66 ? $tr->toascii($_[0])
67 : $_[0];
68}
69
70
71sub _print_isa {
7225.75ms2127µs
# spent 75µs (23+52) within Net::Cmd::BEGIN@72 which was called: # once (23µs+52µs) by Net::SMTP::BEGIN@20 at line 72
no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
# spent 75µs making 1 call to Net::Cmd::BEGIN@72 # spent 52µ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
104sub 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
138sub 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
149sub debug_text { $_[2] }
150
151
152sub debug_print {
153 my ($cmd, $out, $text) = @_;
154 print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
155}
156
157
158sub 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
170sub 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
179sub 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
193sub _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
245sub _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
253sub _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
263sub _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
272sub 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
306sub ok {
307 @_ == 1 or croak 'usage: $obj->ok()';
308
309 my $code = $_[0]->code;
310 0 < $code && $code < 400;
311}
312
313
314sub unsupported {
315 my $cmd = shift;
316
317 $cmd->set_status(580, 'Unsupported command');
318
319 0;
320}
321
322
323sub 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
382sub ungetline {
383 my ($cmd, $str) = @_;
384
385 ${*$cmd}{'net_cmd_lines'} ||= [];
386 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
387}
388
389
390sub parse_response {
391 return ()
392 unless $_[1] =~ s/^(\d\d\d)(.?)//o;
393 ($1, $2 eq "-");
394}
395
396
397sub 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
432sub 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
459sub 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
520sub 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
543sub 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
573sub 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
582sub 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.
590sub 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
609sub 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
621sub 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
632sub 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
640120µs1;
641
642__END__
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.