← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/bin/epoll_server.pl
  Run on Wed Jan 5 05:34:33 2011
Reported on Wed Jan 5 05:36:10 2011

File /usr/lib/perl5/5.10.1/Net/Cmd.pm
Statements Executed 2823
Statement Execution Time 1.24s
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
48221.18s1.18sNet::Cmd::::CORE:sselectNet::Cmd::CORE:sselect (opcode)
453231.7ms31.7msNet::Cmd::::CORE:syswriteNet::Cmd::CORE:syswrite (opcode)
30224.68ms11.6msNet::Cmd::::datasendNet::Cmd::datasend
42113.48ms1.18sNet::Cmd::::getlineNet::Cmd::getline
21723.19ms1.19sNet::Cmd::::responseNet::Cmd::response
15512.03ms23.7msNet::Cmd::::commandNet::Cmd::command
90521.60ms1.60msNet::Cmd::::debugNet::Cmd::debug
4211888µs1.18msNet::Cmd::::parse_responseNet::Cmd::parse_response
12312599µs599µsNet::Cmd::::CORE:substcontNet::Cmd::CORE:substcont (opcode)
6922486µs486µsNet::Cmd::::CORE:substNet::Cmd::CORE:subst (opcode)
311368µs430msNet::Cmd::::dataendNet::Cmd::dataend
2112327µs327µsNet::Cmd::::CORE:sysreadNet::Cmd::CORE:sysread (opcode)
1862197µs197µsNet::Cmd::::CMD_OKNet::Cmd::CMD_OK
111167µs182µsNet::Cmd::::BEGIN@12Net::Cmd::BEGIN@12
5122111µs111µsNet::Cmd::::CORE:matchNet::Cmd::CORE:match (opcode)
931101µs101µsNet::Cmd::::messageNet::Cmd::message
11145µs49µsNet::Cmd::::BEGIN@25Net::Cmd::BEGIN@25
11140µs142µsNet::Cmd::::BEGIN@15Net::Cmd::BEGIN@15
11133µs86µsNet::Cmd::::BEGIN@81Net::Cmd::BEGIN@81
11130µs226µsNet::Cmd::::BEGIN@14Net::Cmd::BEGIN@14
11129µs210µsNet::Cmd::::BEGIN@13Net::Cmd::BEGIN@13
31122µs22µsNet::Cmd::::CMD_MORENet::Cmd::CMD_MORE
11118µs18µsNet::Cmd::::BEGIN@17Net::Cmd::BEGIN@17
0000s0sNet::Cmd::::CLOSENet::Cmd::CLOSE
0000s0sNet::Cmd::::CMD_ERRORNet::Cmd::CMD_ERROR
0000s0sNet::Cmd::::CMD_INFONet::Cmd::CMD_INFO
0000s0sNet::Cmd::::CMD_PENDINGNet::Cmd::CMD_PENDING
0000s0sNet::Cmd::::CMD_REJECTNet::Cmd::CMD_REJECT
0000s0sNet::Cmd::::PRINTNet::Cmd::PRINT
0000s0sNet::Cmd::::READNet::Cmd::READ
0000s0sNet::Cmd::::READLINENet::Cmd::READLINE
0000s0sNet::Cmd::::TIEHANDLENet::Cmd::TIEHANDLE
0000s0sNet::Cmd::::__ANON__[:27]Net::Cmd::__ANON__[:27]
0000s0sNet::Cmd::::__ANON__[:36]Net::Cmd::__ANON__[:36]
0000s0sNet::Cmd::::_print_isaNet::Cmd::_print_isa
0000s0sNet::Cmd::::codeNet::Cmd::code
0000s0sNet::Cmd::::debug_printNet::Cmd::debug_print
0000s0sNet::Cmd::::debug_textNet::Cmd::debug_text
0000s0sNet::Cmd::::okNet::Cmd::ok
0000s0sNet::Cmd::::rawdatasendNet::Cmd::rawdatasend
0000s0sNet::Cmd::::read_until_dotNet::Cmd::read_until_dot
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# Copyright (c) 1995-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
4# This program is free software; you can redistribute it and/or
5# modify it under the same terms as Perl itself.
6
7package Net::Cmd;
8
9159µsrequire 5.001;
1013µsrequire Exporter;
11
12398µs2195µs
# spent 182µs (167+14) within Net::Cmd::BEGIN@12 which was called # once (167µs+14µs) by Net::SMTP::BEGIN@16 at line 12
use strict;
# spent 182µs making 1 call to Net::Cmd::BEGIN@12 # spent 14µs making 1 call to strict::import
13381µs2392µs
# spent 210µs (29+182) within Net::Cmd::BEGIN@13 which was called # once (29µs+182µs) by Net::SMTP::BEGIN@16 at line 13
use vars qw(@ISA @EXPORT $VERSION);
# spent 210µs making 1 call to Net::Cmd::BEGIN@13 # spent 182µs making 1 call to vars::import
143364µs2422µs
# spent 226µs (30+196) within Net::Cmd::BEGIN@14 which was called # once (30µs+196µs) by Net::SMTP::BEGIN@16 at line 14
use Carp;
# spent 226µs making 1 call to Net::Cmd::BEGIN@14 # spent 196µs making 1 call to Exporter::import
153180µs2244µs
# spent 142µs (40+102) within Net::Cmd::BEGIN@15 which was called # once (40µs+102µs) by Net::SMTP::BEGIN@16 at line 15
use Symbol 'gensym';
# spent 142µs making 1 call to Net::Cmd::BEGIN@15 # spent 102µs making 1 call to Exporter::import
16
17
# spent 18µs within Net::Cmd::BEGIN@17 which was called # once (18µs+0s) by Net::SMTP::BEGIN@16 at line 23
BEGIN {
18118µs if ($^O eq 'os390') {
19 require Convert::EBCDIC;
20
21 # Convert::EBCDIC->import;
22 }
231511µs118µs}
# spent 18µs making 1 call to Net::Cmd::BEGIN@17
24
25
# spent 49µs (45+4) within Net::Cmd::BEGIN@25 which was called # once (45µs+4µs) by Net::SMTP::BEGIN@16 at line 38
BEGIN {
26445µs if (!eval { require utf8 }) {
27 *is_utf8 = sub { 0 };
28 }
29 elsif (eval { utf8::is_utf8(undef); 1 }) {
# spent 4µs making 1 call to utf8::is_utf8
30 *is_utf8 = \&utf8::is_utf8;
31 }
32 elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) {
33 *is_utf8 = \&Encode::is_utf8;
34 }
35 else {
36 *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ };
37 }
3811.19ms149µs}
# spent 49µs making 1 call to Net::Cmd::BEGIN@25
39
4012µs$VERSION = "2.29";
41126µs@ISA = qw(Exporter);
4216µs@EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
43
44
45sub CMD_INFO {1}
4618189µs
# spent 197µs within Net::Cmd::CMD_OK which was called 18 times, avg 11µs/call: # 3 times (87µs+0s) by Net::SMTP::_RCPT at line 515 of Net/SMTP.pm, avg 29µs/call # 3 times (46µs+0s) by Net::SMTP::_MAIL at line 514 of Net/SMTP.pm, avg 15µs/call # 3 times (20µs+0s) by Net::SMTP::new at line 61 of Net/SMTP.pm, avg 7µs/call # 3 times (17µs+0s) by Net::Cmd::dataend at line 536, avg 6µs/call # 3 times (14µs+0s) by Net::SMTP::_EHLO at line 512 of Net/SMTP.pm, avg 5µs/call # 3 times (13µs+0s) by Net::SMTP::_QUIT at line 524 of Net/SMTP.pm, avg 4µs/call
sub CMD_OK {2}
47326µs
# spent 22µs within Net::Cmd::CMD_MORE which was called 3 times, avg 7µs/call: # 3 times (22µs+0s) by Net::SMTP::_DATA at line 525 of Net/SMTP.pm, avg 7µs/call
sub CMD_MORE {3}
48sub CMD_REJECT {4}
49sub CMD_ERROR {5}
50sub CMD_PENDING {0}
51
5212µsmy %debug = ();
53
5416µsmy $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
55
56
57sub toebcdic {
58 my $cmd = shift;
59
60 unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
61 my $string = $_[0];
62 my $ebcdicstr = $tr->toebcdic($string);
63 ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
64 }
65
66 ${*$cmd}{'net_cmd_asciipeer'}
67 ? $tr->toebcdic($_[0])
68 : $_[0];
69}
70
71
72sub toascii {
73 my $cmd = shift;
74 ${*$cmd}{'net_cmd_asciipeer'}
75 ? $tr->toascii($_[0])
76 : $_[0];
77}
78
79
80sub _print_isa {
8139.72ms2140µs
# spent 86µs (33+54) within Net::Cmd::BEGIN@81 which was called # once (33µs+54µs) by Net::SMTP::BEGIN@16 at line 81
no strict qw(refs);
# spent 86µs making 1 call to Net::Cmd::BEGIN@81 # spent 54µs making 1 call to strict::unimport
82
83 my $pkg = shift;
84 my $cmd = $pkg;
85
86 $debug{$pkg} ||= 0;
87
88 my %done = ();
89 my @do = ($pkg);
90 my %spc = ($pkg, "");
91
92 while ($pkg = shift @do) {
93 next if defined $done{$pkg};
94
95 $done{$pkg} = 1;
96
97 my $v =
98 defined ${"${pkg}::VERSION"}
99 ? "(" . ${"${pkg}::VERSION"} . ")"
100 : "";
101
102 my $spc = $spc{$pkg};
103 $cmd->debug_print(1, "${spc}${pkg}${v}\n");
104
105 if (@{"${pkg}::ISA"}) {
106 @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
107 unshift(@do, @{"${pkg}::ISA"});
108 }
109 }
110}
111
112
113
# spent 1.60ms within Net::Cmd::debug which was called 90 times, avg 18µs/call: # 42 times (689µs+0s) by Net::Cmd::response at line 350, avg 16µs/call # 27 times (413µs+0s) by Net::Cmd::datasend at line 413, avg 15µs/call # 15 times (376µs+0s) by Net::Cmd::command at line 235, avg 25µs/call # 3 times (75µs+0s) by Net::SMTP::new at line 59 of Net/SMTP.pm, avg 25µs/call # 3 times (44µs+0s) by Net::Cmd::dataend at line 529, avg 15µs/call
sub debug {
1145521.92ms @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
115
116 my ($cmd, $level) = @_;
117 my $pkg = ref($cmd) || $cmd;
118 my $oldval = 0;
119
120 if (ref($cmd)) {
121 $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
122 }
123 else {
124 $oldval = $debug{$pkg} || 0;
125 }
126
127 return $oldval
128 unless @_ == 2;
129
130 $level = $debug{$pkg} || 0
131 unless defined $level;
132
133 _print_isa($pkg)
134 if ($level && !exists $debug{$pkg});
135
136 if (ref($cmd)) {
137 ${*$cmd}{'net_cmd_debug'} = $level;
138 }
139 else {
140 $debug{$pkg} = $level;
141 }
142
143 $oldval;
144}
145
146
147
# spent 101µs within Net::Cmd::message which was called 9 times, avg 11µs/call: # 3 times (35µs+0s) by Net::SMTP::hello at line 172 of Net/SMTP.pm, avg 12µs/call # 3 times (34µs+0s) by Net::SMTP::new at line 69 of Net/SMTP.pm, avg 11µs/call # 3 times (32µs+0s) by Net::SMTP::new at line 70 of Net/SMTP.pm, avg 11µs/call
sub message {
14827158µs @_ == 1 or croak 'usage: $obj->message()';
149
150 my $cmd = shift;
151
152 wantarray
153 ? @{${*$cmd}{'net_cmd_resp'}}
154 : join("", @{${*$cmd}{'net_cmd_resp'}});
155}
156
157
158sub debug_text { $_[2] }
159
160
161sub debug_print {
162 my ($cmd, $out, $text) = @_;
163 print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
164}
165
166
167sub code {
168 @_ == 1 or croak 'usage: $obj->code()';
169
170 my $cmd = shift;
171
172 ${*$cmd}{'net_cmd_code'} = "000"
173 unless exists ${*$cmd}{'net_cmd_code'};
174
175 ${*$cmd}{'net_cmd_code'};
176}
177
178
179sub status {
180 @_ == 1 or croak 'usage: $obj->status()';
181
182 my $cmd = shift;
183
184 substr(${*$cmd}{'net_cmd_code'}, 0, 1);
185}
186
187
188sub set_status {
189 @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
190
191 my $cmd = shift;
192 my ($code, $resp) = @_;
193
194 $resp = [$resp]
195 unless ref($resp);
196
197 (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
198
199 1;
200}
201
202
203
# spent 23.7ms (2.03+21.7) within Net::Cmd::command which was called 15 times, avg 1.58ms/call: # 3 times (453µs+9.90ms) by Net::SMTP::_RCPT at line 515 of Net/SMTP.pm, avg 3.45ms/call # 3 times (346µs+7.87ms) by Net::SMTP::_MAIL at line 514 of Net/SMTP.pm, avg 2.74ms/call # 3 times (364µs+2.47ms) by Net::SMTP::_DATA at line 525 of Net/SMTP.pm, avg 943µs/call # 3 times (596µs+637µs) by Net::SMTP::_EHLO at line 512 of Net/SMTP.pm, avg 411µs/call # 3 times (266µs+792µs) by Net::SMTP::_QUIT at line 524 of Net/SMTP.pm, avg 353µs/call
sub command {
20424923.3ms my $cmd = shift;
205
206 unless (defined fileno($cmd)) {
207 $cmd->set_status("599", "Connection closed");
208 return $cmd;
209 }
210
211
212 $cmd->dataend()
213 if (exists ${*$cmd}{'net_cmd_last_ch'});
214
215 if (scalar(@_)) {
216 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
217
218 my $str = join(
219 " ",
220 map {
221 /\n/
222 ? do { my $n = $_; $n =~ tr/\n/ /; $n }
# spent 58µs making 24 calls to Net::Cmd::CORE:match, avg 2µs/call
223 : $_;
224 } @_
225 );
226 $str = $cmd->toascii($str) if $tr;
227 $str .= "\015\012";
228
229 my $len = length $str;
230 my $swlen;
231
232 $cmd->close
# spent 21.2ms making 15 calls to Net::Cmd::CORE:syswrite, avg 1.42ms/call
233 unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
234
235 $cmd->debug_print(1, $str)
# spent 376µs making 15 calls to Net::Cmd::debug, avg 25µs/call
236 if ($cmd->debug);
237
238 ${*$cmd}{'net_cmd_resp'} = []; # the response
239 ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
240 }
241
242 $cmd;
243}
244
245
246sub ok {
247 @_ == 1 or croak 'usage: $obj->ok()';
248
249 my $code = $_[0]->code;
250 0 < $code && $code < 400;
251}
252
253
254sub unsupported {
255 my $cmd = shift;
256
257 ${*$cmd}{'net_cmd_resp'} = ['Unsupported command'];
258 ${*$cmd}{'net_cmd_code'} = 580;
259 0;
260}
261
262
263
# spent 1.18s (3.48ms+1.18) within Net::Cmd::getline which was called 42 times, avg 28.2ms/call: # 42 times (3.48ms+1.18s) by Net::Cmd::response at line 345, avg 28.2ms/call
sub getline {
2645251.18s my $cmd = shift;
265
266 ${*$cmd}{'net_cmd_lines'} ||= [];
267
268 return shift @{${*$cmd}{'net_cmd_lines'}}
269 if scalar(@{${*$cmd}{'net_cmd_lines'}});
270
271 my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
272 my $fd = fileno($cmd);
273
274 return undef
275 unless defined $fd;
276
277 my $rin = "";
278 vec($rin, $fd, 1) = 1;
279
280 my $buf;
281
282 until (scalar(@{${*$cmd}{'net_cmd_lines'}})) {
283 my $timeout = $cmd->timeout || undef;
# spent 347µs making 21 calls to IO::Socket::timeout, avg 17µs/call
284 my $rout;
285
286 my $select_ret = select($rout = $rin, undef, undef, $timeout);
# spent 1.18s making 21 calls to Net::Cmd::CORE:sselect, avg 56.2ms/call
287 if ($select_ret > 0) {
288 unless (sysread($cmd, $buf = "", 1024)) {
# spent 327µs making 21 calls to Net::Cmd::CORE:sysread, avg 16µs/call
289 carp(ref($cmd) . ": Unexpected EOF on command channel")
290 if $cmd->debug;
291 $cmd->close;
292 return undef;
293 }
294
295 substr($buf, 0, 0) = $partial; ## prepend from last sysread
296
297 my @buf = split(/\015?\012/, $buf, -1); ## break into lines
298
299 $partial = pop @buf;
300
301 push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf);
302
303 }
304 else {
305 my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
306 carp("$cmd: $msg") if ($cmd->debug);
307 return undef;
308 }
309 }
310
311 ${*$cmd}{'net_cmd_partial'} = $partial;
312
313 if ($tr) {
314 foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) {
315 $ln = $cmd->toebcdic($ln);
316 }
317 }
318
319 shift @{${*$cmd}{'net_cmd_lines'}};
320}
321
322
323sub ungetline {
324 my ($cmd, $str) = @_;
325
326 ${*$cmd}{'net_cmd_lines'} ||= [];
327 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
328}
329
330
331
# spent 1.18ms (888µs+294µs) within Net::Cmd::parse_response which was called 42 times, avg 28µs/call: # 42 times (888µs+294µs) by Net::Cmd::response at line 353, avg 28µs/call
sub parse_response {
332 return ()
333841.25ms42294µs unless $_[1] =~ s/^(\d\d\d)(.?)//o;
# spent 294µs making 42 calls to Net::Cmd::CORE:subst, avg 7µs/call
334 ($1, $2 eq "-");
335}
336
337
338
# spent 1.19s (3.19ms+1.19) within Net::Cmd::response which was called 21 times, avg 56.6ms/call: # 3 times (214µs+460ms) by Net::SMTP::_RCPT at line 515 of Net/SMTP.pm, avg 153ms/call # 3 times (283µs+424ms) by Net::Cmd::dataend at line 536, avg 141ms/call # 3 times (400µs+252ms) by Net::SMTP::new at line 61 of Net/SMTP.pm, avg 84.1ms/call # 3 times (287µs+22.9ms) by Net::SMTP::_MAIL at line 514 of Net/SMTP.pm, avg 7.73ms/call # 3 times (260µs+19.9ms) by Net::SMTP::_DATA at line 525 of Net/SMTP.pm, avg 6.74ms/call # 3 times (140µs+6.10ms) by Net::SMTP::_QUIT at line 524 of Net/SMTP.pm, avg 2.08ms/call # 3 times (1.61ms+1.88ms) by Net::SMTP::_EHLO at line 512 of Net/SMTP.pm, avg 1.16ms/call
sub response {
3394413.00ms my $cmd = shift;
340 my ($code, $more) = (undef) x 2;
341
342 ${*$cmd}{'net_cmd_resp'} ||= [];
343
344 while (1) {
345 my $str = $cmd->getline();
# spent 1.18s making 42 calls to Net::Cmd::getline, avg 28.2ms/call
346
347 return CMD_ERROR
348 unless defined($str);
349
350 $cmd->debug_print(0, $str)
# spent 689µs making 42 calls to Net::Cmd::debug, avg 16µs/call
351 if ($cmd->debug);
352
353 ($code, $more) = $cmd->parse_response($str);
# spent 1.18ms making 42 calls to Net::Cmd::parse_response, avg 28µs/call
354 unless (defined $code) {
355 $cmd->ungetline($str);
356 last;
357 }
358
359 ${*$cmd}{'net_cmd_code'} = $code;
360
361 push(@{${*$cmd}{'net_cmd_resp'}}, $str);
362
363 last unless ($more);
364 }
365
366 substr($code, 0, 1);
367}
368
369
370sub read_until_dot {
371 my $cmd = shift;
372 my $fh = shift;
373 my $arr = [];
374
375 while (1) {
376 my $str = $cmd->getline() or return undef;
377
378 $cmd->debug_print(0, $str)
379 if ($cmd->debug & 4);
380
381 last if ($str =~ /^\.\r?\n/o);
382
383 $str =~ s/^\.\././o;
384
385 if (defined $fh) {
386 print $fh $str;
387 }
388 else {
389 push(@$arr, $str);
390 }
391 }
392
393 $arr;
394}
395
396
397
# spent 11.6ms (4.68+6.96) within Net::Cmd::datasend which was called 30 times, avg 388µs/call: # 27 times (4.55ms+6.95ms) by Mail::Mailer::smtp::pipe::PRINT at line 99 of Mail/Mailer/smtp.pm, avg 426µs/call # 3 times (129µs+14µs) by Net::SMTP::data at line 425 of Net/SMTP.pm, avg 48µs/call
sub datasend {
39886110.7ms my $cmd = shift;
399 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
400 my $line = join("", @$arr);
401
402 # encode to individual utf8 bytes if
403 # $line is a string (in internal UTF-8)
404 utf8::encode($line) if is_utf8($line);
# spent 142µs making 30 calls to utf8::is_utf8, avg 5µs/call
405
406 return 0 unless defined(fileno($cmd));
407
408 my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
409 $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
410
411 return 1 unless length $line;
412
413 if ($cmd->debug) {
# spent 413µs making 27 calls to Net::Cmd::debug, avg 15µs/call
414 foreach my $b (split(/\n/, $line)) {
415 $cmd->debug_print(1, "$b\n");
416 }
417 }
418
419 $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
420
421 my $first_ch = '';
422
423 if ($last_ch eq "\015") {
424 $first_ch = "\012" if $line =~ s/^\012//;
425 }
426 elsif ($last_ch eq "\012") {
427 $first_ch = "." if $line =~ /^\./;
# spent 53µs making 27 calls to Net::Cmd::CORE:match, avg 2µs/call
428 }
429
430 $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
# spent 599µs making 123 calls to Net::Cmd::CORE:substcont, avg 5µs/call # spent 191µs making 27 calls to Net::Cmd::CORE:subst, avg 7µs/call
431
432 substr($line, 0, 0) = $first_ch;
433
434 ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1);
435
436 my $len = length($line);
437 my $offset = 0;
438 my $win = "";
439 vec($win, fileno($cmd), 1) = 1;
440 my $timeout = $cmd->timeout || undef;
# spent 303µs making 27 calls to IO::Socket::timeout, avg 11µs/call
441
442 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
443
444 while ($len) {
445 my $wout;
446 my $s = select(undef, $wout = $win, undef, $timeout);
# spent 185µs making 27 calls to Net::Cmd::CORE:sselect, avg 7µs/call
447 if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
448 {
449 my $w = syswrite($cmd, $line, $len, $offset);
# spent 5.08ms making 27 calls to Net::Cmd::CORE:syswrite, avg 188µs/call
450 unless (defined($w)) {
451 carp("$cmd: $!") if $cmd->debug;
452 return undef;
453 }
454 $len -= $w;
455 $offset += $w;
456 }
457 else {
458 carp("$cmd: Timeout") if ($cmd->debug);
459 return undef;
460 }
461 }
462
463 1;
464}
465
466
467sub rawdatasend {
468 my $cmd = shift;
469 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
470 my $line = join("", @$arr);
471
472 return 0 unless defined(fileno($cmd));
473
474 return 1
475 unless length($line);
476
477 if ($cmd->debug) {
478 my $b = "$cmd>>> ";
479 print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
480 }
481
482 my $len = length($line);
483 my $offset = 0;
484 my $win = "";
485 vec($win, fileno($cmd), 1) = 1;
486 my $timeout = $cmd->timeout || undef;
487
488 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
489 while ($len) {
490 my $wout;
491 if (select(undef, $wout = $win, undef, $timeout) > 0) {
492 my $w = syswrite($cmd, $line, $len, $offset);
493 unless (defined($w)) {
494 carp("$cmd: $!") if $cmd->debug;
495 return undef;
496 }
497 $len -= $w;
498 $offset += $w;
499 }
500 else {
501 carp("$cmd: Timeout") if ($cmd->debug);
502 return undef;
503 }
504 }
505
506 1;
507}
508
509
510
# spent 430ms (368µs+429) within Net::Cmd::dataend which was called 3 times, avg 143ms/call: # 3 times (368µs+429ms) by Mail::Mailer::smtp::epilogue at line 58 of Mail/Mailer/smtp.pm, avg 143ms/call
sub dataend {
511335.72ms my $cmd = shift;
512
513 return 0 unless defined(fileno($cmd));
514
515 my $ch = ${*$cmd}{'net_cmd_last_ch'};
516 my $tosend;
517
518 if (!defined $ch) {
519 return 1;
520 }
521 elsif ($ch ne "\012") {
522 $tosend = "\015\012";
523 }
524
525 $tosend .= ".\015\012";
526
527 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
528
529 $cmd->debug_print(1, ".\n")
# spent 44µs making 3 calls to Net::Cmd::debug, avg 15µs/call
530 if ($cmd->debug);
531
532 syswrite($cmd, $tosend, length $tosend);
# spent 5.42ms making 3 calls to Net::Cmd::CORE:syswrite, avg 1.81ms/call
533
534 delete ${*$cmd}{'net_cmd_last_ch'};
535
536 $cmd->response() == CMD_OK;
# spent 424ms making 3 calls to Net::Cmd::response, avg 141ms/call # spent 17µs making 3 calls to Net::Cmd::CMD_OK, avg 6µs/call
537}
538
539# read and write to tied filehandle
540sub tied_fh {
541 my $cmd = shift;
542 ${*$cmd}{'net_cmd_readbuf'} = '';
543 my $fh = gensym();
544 tie *$fh, ref($cmd), $cmd;
545 return $fh;
546}
547
548# tie to myself
549sub TIEHANDLE {
550 my $class = shift;
551 my $cmd = shift;
552 return $cmd;
553}
554
555# Tied filehandle read. Reads requested data length, returning
556# end-of-file when the dot is encountered.
557sub READ {
558 my $cmd = shift;
559 my ($len, $offset) = @_[1, 2];
560 return unless exists ${*$cmd}{'net_cmd_readbuf'};
561 my $done = 0;
562 while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
563 ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
564 $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
565 }
566
567 $_[0] = '';
568 substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len);
569 substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = '';
570 delete ${*$cmd}{'net_cmd_readbuf'} if $done;
571
572 return length $_[0];
573}
574
575
576sub READLINE {
577 my $cmd = shift;
578
579 # in this context, we use the presence of readbuf to
580 # indicate that we have not yet reached the eof
581 return unless exists ${*$cmd}{'net_cmd_readbuf'};
582 my $line = $cmd->getline;
583 return if $line =~ /^\.\r?\n/;
584 $line;
585}
586
587
588sub PRINT {
589 my $cmd = shift;
590 my ($buf, $len, $offset) = @_;
591 $len ||= length($buf);
592 $offset += 0;
593 return unless $cmd->datasend(substr($buf, $offset, $len));
594 ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
595 return $len;
596}
597
598
599sub CLOSE {
600 my $cmd = shift;
601 my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
602 delete ${*$cmd}{'net_cmd_readbuf'};
603 delete ${*$cmd}{'net_cmd_sending'};
604 $r;
605}
606
6071919µs1;
608
609__END__
610
611
612=head1 NAME
613
614Net::Cmd - Network Command class (as used by FTP, SMTP etc)
615
616=head1 SYNOPSIS
617
618 use Net::Cmd;
619
620 @ISA = qw(Net::Cmd);
621
622=head1 DESCRIPTION
623
624C<Net::Cmd> is a collection of methods that can be inherited by a sub class
625of C<IO::Handle>. These methods implement the functionality required for a
626command based protocol, for example FTP and SMTP.
627
628=head1 USER METHODS
629
630These methods provide a user interface to the C<Net::Cmd> object.
631
632=over 4
633
634=item debug ( VALUE )
635
636Set the level of debug information for this object. If C<VALUE> is not given
637then the current state is returned. Otherwise the state is changed to
638C<VALUE> and the previous state returned.
639
640Different packages
641may implement different levels of debug but a non-zero value results in
642copies of all commands and responses also being sent to STDERR.
643
644If C<VALUE> is C<undef> then the debug level will be set to the default
645debug level for the class.
646
647This method can also be called as a I<static> method to set/get the default
648debug level for a given class.
649
650=item message ()
651
652Returns the text message returned from the last command
653
654=item code ()
655
656Returns the 3-digit code from the last command. If a command is pending
657then the value 0 is returned
658
659=item ok ()
660
661Returns non-zero if the last code value was greater than zero and
662less than 400. This holds true for most command servers. Servers
663where this does not hold may override this method.
664
665=item status ()
666
667Returns the most significant digit of the current status code. If a command
668is pending then C<CMD_PENDING> is returned.
669
670=item datasend ( DATA )
671
672Send data to the remote server, converting LF to CRLF. Any line starting
673with a '.' will be prefixed with another '.'.
674C<DATA> may be an array or a reference to an array.
675
676=item dataend ()
677
678End the sending of data to the remote server. This is done by ensuring that
679the data already sent ends with CRLF then sending '.CRLF' to end the
680transmission. Once this data has been sent C<dataend> calls C<response> and
681returns true if C<response> returns CMD_OK.
682
683=back
684
685=head1 CLASS METHODS
686
687These methods are not intended to be called by the user, but used or
688over-ridden by a sub-class of C<Net::Cmd>
689
690=over 4
691
692=item debug_print ( DIR, TEXT )
693
694Print debugging information. C<DIR> denotes the direction I<true> being
695data being sent to the server. Calls C<debug_text> before printing to
696STDERR.
697
698=item debug_text ( TEXT )
699
700This method is called to print debugging information. TEXT is
701the text being sent. The method should return the text to be printed
702
703This is primarily meant for the use of modules such as FTP where passwords
704are sent, but we do not want to display them in the debugging information.
705
706=item command ( CMD [, ARGS, ... ])
707
708Send a command to the command server. All arguments a first joined with
709a space character and CRLF is appended, this string is then sent to the
710command server.
711
712Returns undef upon failure
713
714=item unsupported ()
715
716Sets the status code to 580 and the response text to 'Unsupported command'.
717Returns zero.
718
719=item response ()
720
721Obtain a response from the server. Upon success the most significant digit
722of the status code is returned. Upon failure, timeout etc., I<undef> is
723returned.
724
725=item parse_response ( TEXT )
726
727This method is called by C<response> as a method with one argument. It should
728return an array of 2 values, the 3-digit status code and a flag which is true
729when this is part of a multi-line response and this line is not the list.
730
731=item getline ()
732
733Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
734upon failure.
735
736B<NOTE>: If you do use this method for any reason, please remember to add
737some C<debug_print> calls into your method.
738
739=item ungetline ( TEXT )
740
741Unget a line of text from the server.
742
743=item rawdatasend ( DATA )
744
745Send data to the remote server without performing any conversions. C<DATA>
746is a scalar.
747
748=item read_until_dot ()
749
750Read data from the remote server until a line consisting of a single '.'.
751Any lines starting with '..' will have one of the '.'s removed.
752
753Returns a reference to a list containing the lines, or I<undef> upon failure.
754
755=item tied_fh ()
756
757Returns a filehandle tied to the Net::Cmd object. After issuing a
758command, you may read from this filehandle using read() or <>. The
759filehandle will return EOF when the final dot is encountered.
760Similarly, you may write to the filehandle in order to send data to
761the server after issuing a command that expects data to be written.
762
763See the Net::POP3 and Net::SMTP modules for examples of this.
764
765=back
766
767=head1 EXPORTS
768
769C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
770C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
771of C<response> and C<status>. The sixth is C<CMD_PENDING>.
772
773=head1 AUTHOR
774
775Graham Barr <gbarr@pobox.com>
776
777=head1 COPYRIGHT
778
779Copyright (c) 1995-2006 Graham Barr. All rights reserved.
780This program is free software; you can redistribute it and/or modify
781it under the same terms as Perl itself.
782
783=cut
# spent 111µs within Net::Cmd::CORE:match which was called 51 times, avg 2µs/call: # 27 times (53µs+0s) by Net::Cmd::datasend at line 427 of Net/Cmd.pm, avg 2µs/call # 24 times (58µs+0s) by Net::Cmd::command at line 222 of Net/Cmd.pm, avg 2µs/call
sub Net::Cmd::CORE:match; # xsub
# spent 1.18s within Net::Cmd::CORE:sselect which was called 48 times, avg 24.6ms/call: # 27 times (185µs+0s) by Net::Cmd::datasend at line 446 of Net/Cmd.pm, avg 7µs/call # 21 times (1.18s+0s) by Net::Cmd::getline at line 286 of Net/Cmd.pm, avg 56.2ms/call
sub Net::Cmd::CORE:sselect; # xsub
# spent 486µs within Net::Cmd::CORE:subst which was called 69 times, avg 7µs/call: # 42 times (294µs+0s) by Net::Cmd::parse_response at line 333 of Net/Cmd.pm, avg 7µs/call # 27 times (191µs+0s) by Net::Cmd::datasend at line 430 of Net/Cmd.pm, avg 7µs/call
sub Net::Cmd::CORE:subst; # xsub
# spent 599µs within Net::Cmd::CORE:substcont which was called 123 times, avg 5µs/call: # 123 times (599µs+0s) by Net::Cmd::datasend at line 430 of Net/Cmd.pm, avg 5µs/call
sub Net::Cmd::CORE:substcont; # xsub
# spent 327µs within Net::Cmd::CORE:sysread which was called 21 times, avg 16µs/call: # 21 times (327µs+0s) by Net::Cmd::getline at line 288 of Net/Cmd.pm, avg 16µs/call
sub Net::Cmd::CORE:sysread; # xsub
# spent 31.7ms within Net::Cmd::CORE:syswrite which was called 45 times, avg 705µs/call: # 27 times (5.08ms+0s) by Net::Cmd::datasend at line 449 of Net/Cmd.pm, avg 188µs/call # 15 times (21.2ms+0s) by Net::Cmd::command at line 232 of Net/Cmd.pm, avg 1.42ms/call # 3 times (5.42ms+0s) by Net::Cmd::dataend at line 532 of Net/Cmd.pm, avg 1.81ms/call
sub Net::Cmd::CORE:syswrite; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.