Commit | Line | Data |
---|---|---|
b3f6f6a6 | 1 | # Net::Cmd.pm |
406c51ee | 2 | # |
8f2f8ba0 | 3 | # Copyright (C) 1995-2006 Graham Barr. All rights reserved. |
27b896ab | 4 | # Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. |
a4f8ff46 SH |
5 | # This module is free software; you can redistribute it and/or modify it under |
6 | # the same terms as Perl itself, i.e. under the terms of either the GNU General | |
7 | # Public License or the Artistic License, as specified in the F<LICENCE> file. | |
406c51ee JH |
8 | |
9 | package Net::Cmd; | |
10 | ||
2e173144 | 11 | use 5.008001; |
406c51ee JH |
12 | |
13 | use strict; | |
2e173144 CBW |
14 | use warnings; |
15 | ||
406c51ee | 16 | use Carp; |
2e173144 | 17 | use Exporter; |
12df23ee | 18 | use Symbol 'gensym'; |
bfdb5bfe | 19 | use Errno 'EINTR'; |
406c51ee | 20 | |
686337f3 JH |
21 | BEGIN { |
22 | if ($^O eq 'os390') { | |
23 | require Convert::EBCDIC; | |
b3f6f6a6 RGS |
24 | |
25 | # Convert::EBCDIC->import; | |
686337f3 JH |
26 | } |
27 | } | |
28 | ||
6258b1f3 | 29 | our $VERSION = "3.13"; |
2e173144 CBW |
30 | our @ISA = qw(Exporter); |
31 | our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); | |
406c51ee | 32 | |
2e173144 CBW |
33 | use constant CMD_INFO => 1; |
34 | use constant CMD_OK => 2; | |
35 | use constant CMD_MORE => 3; | |
36 | use constant CMD_REJECT => 4; | |
37 | use constant CMD_ERROR => 5; | |
38 | use constant CMD_PENDING => 0; | |
b3f6f6a6 | 39 | |
2e173144 | 40 | use constant DEF_REPLY_CODE => 421; |
406c51ee JH |
41 | |
42 | my %debug = (); | |
43 | ||
686337f3 JH |
44 | my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef; |
45 | ||
b3f6f6a6 RGS |
46 | sub toebcdic { |
47 | my $cmd = shift; | |
48 | ||
49 | unless (exists ${*$cmd}{'net_cmd_asciipeer'}) { | |
50 | my $string = $_[0]; | |
51 | my $ebcdicstr = $tr->toebcdic($string); | |
52 | ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/; | |
686337f3 JH |
53 | } |
54 | ||
55 | ${*$cmd}{'net_cmd_asciipeer'} | |
56 | ? $tr->toebcdic($_[0]) | |
57 | : $_[0]; | |
58 | } | |
59 | ||
b3f6f6a6 RGS |
60 | |
61 | sub toascii { | |
686337f3 JH |
62 | my $cmd = shift; |
63 | ${*$cmd}{'net_cmd_asciipeer'} | |
64 | ? $tr->toascii($_[0]) | |
65 | : $_[0]; | |
66 | } | |
67 | ||
406c51ee | 68 | |
b3f6f6a6 | 69 | sub _print_isa { |
2e173144 | 70 | no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) |
406c51ee | 71 | |
b3f6f6a6 RGS |
72 | my $pkg = shift; |
73 | my $cmd = $pkg; | |
406c51ee | 74 | |
b3f6f6a6 | 75 | $debug{$pkg} ||= 0; |
406c51ee | 76 | |
b3f6f6a6 RGS |
77 | my %done = (); |
78 | my @do = ($pkg); | |
79 | my %spc = ($pkg, ""); | |
406c51ee | 80 | |
b3f6f6a6 RGS |
81 | while ($pkg = shift @do) { |
82 | next if defined $done{$pkg}; | |
406c51ee | 83 | |
b3f6f6a6 | 84 | $done{$pkg} = 1; |
406c51ee | 85 | |
b3f6f6a6 RGS |
86 | my $v = |
87 | defined ${"${pkg}::VERSION"} | |
88 | ? "(" . ${"${pkg}::VERSION"} . ")" | |
89 | : ""; | |
406c51ee | 90 | |
b3f6f6a6 RGS |
91 | my $spc = $spc{$pkg}; |
92 | $cmd->debug_print(1, "${spc}${pkg}${v}\n"); | |
93 | ||
94 | if (@{"${pkg}::ISA"}) { | |
95 | @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"}; | |
96 | unshift(@do, @{"${pkg}::ISA"}); | |
406c51ee JH |
97 | } |
98 | } | |
406c51ee JH |
99 | } |
100 | ||
406c51ee | 101 | |
b3f6f6a6 | 102 | sub debug { |
27b896ab | 103 | @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([$level])'; |
406c51ee | 104 | |
b3f6f6a6 RGS |
105 | my ($cmd, $level) = @_; |
106 | my $pkg = ref($cmd) || $cmd; | |
107 | my $oldval = 0; | |
108 | ||
109 | if (ref($cmd)) { | |
110 | $oldval = ${*$cmd}{'net_cmd_debug'} || 0; | |
406c51ee | 111 | } |
b3f6f6a6 RGS |
112 | else { |
113 | $oldval = $debug{$pkg} || 0; | |
406c51ee JH |
114 | } |
115 | ||
b3f6f6a6 | 116 | return $oldval |
406c51ee JH |
117 | unless @_ == 2; |
118 | ||
b3f6f6a6 | 119 | $level = $debug{$pkg} || 0 |
406c51ee JH |
120 | unless defined $level; |
121 | ||
b3f6f6a6 RGS |
122 | _print_isa($pkg) |
123 | if ($level && !exists $debug{$pkg}); | |
406c51ee | 124 | |
b3f6f6a6 RGS |
125 | if (ref($cmd)) { |
126 | ${*$cmd}{'net_cmd_debug'} = $level; | |
406c51ee | 127 | } |
b3f6f6a6 RGS |
128 | else { |
129 | $debug{$pkg} = $level; | |
406c51ee JH |
130 | } |
131 | ||
b3f6f6a6 | 132 | $oldval; |
406c51ee JH |
133 | } |
134 | ||
406c51ee | 135 | |
b3f6f6a6 RGS |
136 | sub message { |
137 | @_ == 1 or croak 'usage: $obj->message()'; | |
138 | ||
139 | my $cmd = shift; | |
406c51ee | 140 | |
b3f6f6a6 RGS |
141 | wantarray |
142 | ? @{${*$cmd}{'net_cmd_resp'}} | |
143 | : join("", @{${*$cmd}{'net_cmd_resp'}}); | |
406c51ee JH |
144 | } |
145 | ||
b3f6f6a6 | 146 | |
406c51ee JH |
147 | sub debug_text { $_[2] } |
148 | ||
b3f6f6a6 RGS |
149 | |
150 | sub debug_print { | |
151 | my ($cmd, $out, $text) = @_; | |
152 | print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text); | |
406c51ee JH |
153 | } |
154 | ||
406c51ee | 155 | |
b3f6f6a6 RGS |
156 | sub code { |
157 | @_ == 1 or croak 'usage: $obj->code()'; | |
158 | ||
159 | my $cmd = shift; | |
406c51ee | 160 | |
2e173144 | 161 | ${*$cmd}{'net_cmd_code'} = $cmd->DEF_REPLY_CODE |
b3f6f6a6 | 162 | unless exists ${*$cmd}{'net_cmd_code'}; |
406c51ee | 163 | |
b3f6f6a6 | 164 | ${*$cmd}{'net_cmd_code'}; |
406c51ee JH |
165 | } |
166 | ||
406c51ee | 167 | |
b3f6f6a6 RGS |
168 | sub status { |
169 | @_ == 1 or croak 'usage: $obj->status()'; | |
406c51ee | 170 | |
b3f6f6a6 RGS |
171 | my $cmd = shift; |
172 | ||
173 | substr(${*$cmd}{'net_cmd_code'}, 0, 1); | |
406c51ee JH |
174 | } |
175 | ||
406c51ee | 176 | |
b3f6f6a6 | 177 | sub set_status { |
27b896ab | 178 | @_ == 3 or croak 'usage: $obj->set_status($code, $resp)'; |
b3f6f6a6 RGS |
179 | |
180 | my $cmd = shift; | |
181 | my ($code, $resp) = @_; | |
406c51ee | 182 | |
2e173144 | 183 | $resp = defined $resp ? [$resp] : [] |
b3f6f6a6 | 184 | unless ref($resp); |
406c51ee | 185 | |
b3f6f6a6 | 186 | (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp); |
406c51ee | 187 | |
b3f6f6a6 | 188 | 1; |
406c51ee JH |
189 | } |
190 | ||
bfdb5bfe SH |
191 | sub _syswrite_with_timeout { |
192 | my $cmd = shift; | |
193 | my $line = shift; | |
406c51ee | 194 | |
bfdb5bfe SH |
195 | my $len = length($line); |
196 | my $offset = 0; | |
197 | my $win = ""; | |
198 | vec($win, fileno($cmd), 1) = 1; | |
199 | my $timeout = $cmd->timeout || undef; | |
200 | my $initial = time; | |
201 | my $pending = $timeout; | |
202 | ||
203 | local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; | |
204 | ||
205 | while ($len) { | |
206 | my $wout; | |
207 | my $nfound = select(undef, $wout = $win, undef, $pending); | |
208 | if ((defined $nfound and $nfound > 0) or -f $cmd) # -f for testing on win32 | |
209 | { | |
210 | my $w = syswrite($cmd, $line, $len, $offset); | |
211 | if (! defined($w) ) { | |
212 | my $err = $!; | |
213 | $cmd->close; | |
214 | $cmd->_set_status_closed($err); | |
215 | return; | |
216 | } | |
217 | $len -= $w; | |
218 | $offset += $w; | |
219 | } | |
220 | elsif ($nfound == -1) { | |
221 | if ( $! == EINTR ) { | |
222 | if ( defined($timeout) ) { | |
223 | redo if ($pending = $timeout - ( time - $initial ) ) > 0; | |
224 | $cmd->_set_status_timeout; | |
225 | return; | |
226 | } | |
227 | redo; | |
228 | } | |
229 | my $err = $!; | |
230 | $cmd->close; | |
231 | $cmd->_set_status_closed($err); | |
232 | return; | |
233 | } | |
234 | else { | |
235 | $cmd->_set_status_timeout; | |
236 | return; | |
237 | } | |
238 | } | |
239 | ||
240 | return 1; | |
241 | } | |
2e173144 CBW |
242 | |
243 | sub _set_status_timeout { | |
b3f6f6a6 | 244 | my $cmd = shift; |
2e173144 CBW |
245 | my $pkg = ref($cmd) || $cmd; |
246 | ||
247 | $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Timeout"); | |
248 | carp(ref($cmd) . ": " . (caller(1))[3] . "(): timeout") if $cmd->debug; | |
249 | } | |
250 | ||
251 | sub _set_status_closed { | |
252 | my $cmd = shift; | |
bfdb5bfe | 253 | my $err = shift; |
2e173144 CBW |
254 | my $pkg = ref($cmd) || $cmd; |
255 | ||
256 | $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Connection closed"); | |
257 | carp(ref($cmd) . ": " . (caller(1))[3] | |
bfdb5bfe | 258 | . "(): unexpected EOF on command channel: $err") if $cmd->debug; |
2e173144 | 259 | } |
b3f6f6a6 | 260 | |
2e173144 CBW |
261 | sub _is_closed { |
262 | my $cmd = shift; | |
263 | if (!defined fileno($cmd)) { | |
bfdb5bfe | 264 | $cmd->_set_status_closed($!); |
2e173144 | 265 | return 1; |
686337f3 | 266 | } |
2e173144 CBW |
267 | return 0; |
268 | } | |
686337f3 | 269 | |
2e173144 CBW |
270 | sub command { |
271 | my $cmd = shift; | |
272 | ||
273 | return $cmd | |
274 | if $cmd->_is_closed; | |
686337f3 | 275 | |
b3f6f6a6 RGS |
276 | $cmd->dataend() |
277 | if (exists ${*$cmd}{'net_cmd_last_ch'}); | |
406c51ee | 278 | |
b3f6f6a6 | 279 | if (scalar(@_)) { |
b3f6f6a6 RGS |
280 | my $str = join( |
281 | " ", | |
282 | map { | |
283 | /\n/ | |
284 | ? do { my $n = $_; $n =~ tr/\n/ /; $n } | |
285 | : $_; | |
286 | } @_ | |
287 | ); | |
288 | $str = $cmd->toascii($str) if $tr; | |
289 | $str .= "\015\012"; | |
406c51ee | 290 | |
b3f6f6a6 RGS |
291 | $cmd->debug_print(1, $str) |
292 | if ($cmd->debug); | |
406c51ee | 293 | |
bfdb5bfe SH |
294 | # though documented to return undef on failure, the legacy behavior |
295 | # was to return $cmd even on failure, so this odd construct does that | |
296 | $cmd->_syswrite_with_timeout($str) | |
297 | or return $cmd; | |
406c51ee JH |
298 | } |
299 | ||
b3f6f6a6 | 300 | $cmd; |
406c51ee JH |
301 | } |
302 | ||
406c51ee | 303 | |
b3f6f6a6 RGS |
304 | sub ok { |
305 | @_ == 1 or croak 'usage: $obj->ok()'; | |
306 | ||
307 | my $code = $_[0]->code; | |
308 | 0 < $code && $code < 400; | |
406c51ee JH |
309 | } |
310 | ||
406c51ee | 311 | |
b3f6f6a6 RGS |
312 | sub unsupported { |
313 | my $cmd = shift; | |
314 | ||
2e173144 CBW |
315 | $cmd->set_status(580, 'Unsupported command'); |
316 | ||
b3f6f6a6 | 317 | 0; |
406c51ee JH |
318 | } |
319 | ||
406c51ee | 320 | |
b3f6f6a6 RGS |
321 | sub getline { |
322 | my $cmd = shift; | |
323 | ||
324 | ${*$cmd}{'net_cmd_lines'} ||= []; | |
406c51ee | 325 | |
b3f6f6a6 | 326 | return shift @{${*$cmd}{'net_cmd_lines'}} |
406c51ee JH |
327 | if scalar(@{${*$cmd}{'net_cmd_lines'}}); |
328 | ||
b3f6f6a6 | 329 | my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : ""; |
686337f3 | 330 | |
2e173144 CBW |
331 | return |
332 | if $cmd->_is_closed; | |
406c51ee | 333 | |
2e173144 | 334 | my $fd = fileno($cmd); |
b3f6f6a6 RGS |
335 | my $rin = ""; |
336 | vec($rin, $fd, 1) = 1; | |
406c51ee | 337 | |
b3f6f6a6 | 338 | my $buf; |
406c51ee | 339 | |
b3f6f6a6 | 340 | until (scalar(@{${*$cmd}{'net_cmd_lines'}})) { |
6258b1f3 | 341 | my $timeout = $cmd->timeout || undef; |
b3f6f6a6 | 342 | my $rout; |
7cf5cf7c | 343 | |
6258b1f3 RL |
344 | my $select_ret = select($rout = $rin, undef, undef, $timeout); |
345 | if ($select_ret > 0) { | |
346 | unless (sysread($cmd, $buf = "", 1024)) { | |
bfdb5bfe | 347 | my $err = $!; |
b3f6f6a6 | 348 | $cmd->close; |
bfdb5bfe | 349 | $cmd->_set_status_closed($err); |
2e173144 | 350 | return; |
b3f6f6a6 | 351 | } |
406c51ee | 352 | |
b3f6f6a6 | 353 | substr($buf, 0, 0) = $partial; ## prepend from last sysread |
406c51ee | 354 | |
b3f6f6a6 | 355 | my @buf = split(/\015?\012/, $buf, -1); ## break into lines |
406c51ee | 356 | |
b3f6f6a6 | 357 | $partial = pop @buf; |
406c51ee | 358 | |
b3f6f6a6 | 359 | push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf); |
406c51ee JH |
360 | |
361 | } | |
b3f6f6a6 | 362 | else { |
2e173144 CBW |
363 | $cmd->_set_status_timeout; |
364 | return; | |
406c51ee JH |
365 | } |
366 | } | |
367 | ||
b3f6f6a6 | 368 | ${*$cmd}{'net_cmd_partial'} = $partial; |
406c51ee | 369 | |
b3f6f6a6 RGS |
370 | if ($tr) { |
371 | foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) { | |
372 | $ln = $cmd->toebcdic($ln); | |
686337f3 JH |
373 | } |
374 | } | |
375 | ||
b3f6f6a6 | 376 | shift @{${*$cmd}{'net_cmd_lines'}}; |
406c51ee JH |
377 | } |
378 | ||
406c51ee | 379 | |
b3f6f6a6 RGS |
380 | sub ungetline { |
381 | my ($cmd, $str) = @_; | |
382 | ||
383 | ${*$cmd}{'net_cmd_lines'} ||= []; | |
384 | unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); | |
406c51ee JH |
385 | } |
386 | ||
b3f6f6a6 RGS |
387 | |
388 | sub parse_response { | |
389 | return () | |
406c51ee | 390 | unless $_[1] =~ s/^(\d\d\d)(.?)//o; |
b3f6f6a6 | 391 | ($1, $2 eq "-"); |
406c51ee JH |
392 | } |
393 | ||
406c51ee | 394 | |
b3f6f6a6 RGS |
395 | sub response { |
396 | my $cmd = shift; | |
397 | my ($code, $more) = (undef) x 2; | |
406c51ee | 398 | |
2e173144 | 399 | $cmd->set_status($cmd->DEF_REPLY_CODE, undef); # initialize the response |
406c51ee | 400 | |
b3f6f6a6 RGS |
401 | while (1) { |
402 | my $str = $cmd->getline(); | |
406c51ee | 403 | |
b3f6f6a6 RGS |
404 | return CMD_ERROR |
405 | unless defined($str); | |
406c51ee | 406 | |
b3f6f6a6 RGS |
407 | $cmd->debug_print(0, $str) |
408 | if ($cmd->debug); | |
409 | ||
410 | ($code, $more) = $cmd->parse_response($str); | |
411 | unless (defined $code) { | |
2e173144 | 412 | carp("$cmd: response(): parse error in '$str'") if ($cmd->debug); |
b3f6f6a6 | 413 | $cmd->ungetline($str); |
8723f121 | 414 | $@ = $str; # $@ used as tunneling hack |
2e173144 | 415 | return CMD_ERROR; |
406c51ee JH |
416 | } |
417 | ||
b3f6f6a6 | 418 | ${*$cmd}{'net_cmd_code'} = $code; |
406c51ee | 419 | |
b3f6f6a6 | 420 | push(@{${*$cmd}{'net_cmd_resp'}}, $str); |
406c51ee | 421 | |
b3f6f6a6 RGS |
422 | last unless ($more); |
423 | } | |
406c51ee | 424 | |
2e173144 | 425 | return unless defined $code; |
b3f6f6a6 | 426 | substr($code, 0, 1); |
406c51ee JH |
427 | } |
428 | ||
406c51ee | 429 | |
b3f6f6a6 RGS |
430 | sub read_until_dot { |
431 | my $cmd = shift; | |
432 | my $fh = shift; | |
433 | my $arr = []; | |
406c51ee | 434 | |
b3f6f6a6 | 435 | while (1) { |
2e173144 | 436 | my $str = $cmd->getline() or return; |
406c51ee | 437 | |
b3f6f6a6 RGS |
438 | $cmd->debug_print(0, $str) |
439 | if ($cmd->debug & 4); | |
406c51ee | 440 | |
b3f6f6a6 | 441 | last if ($str =~ /^\.\r?\n/o); |
406c51ee | 442 | |
b3f6f6a6 RGS |
443 | $str =~ s/^\.\././o; |
444 | ||
445 | if (defined $fh) { | |
446 | print $fh $str; | |
406c51ee | 447 | } |
b3f6f6a6 RGS |
448 | else { |
449 | push(@$arr, $str); | |
406c51ee JH |
450 | } |
451 | } | |
452 | ||
b3f6f6a6 | 453 | $arr; |
406c51ee JH |
454 | } |
455 | ||
406c51ee | 456 | |
b3f6f6a6 RGS |
457 | sub datasend { |
458 | my $cmd = shift; | |
459 | my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; | |
460 | my $line = join("", @$arr); | |
461 | ||
db956464 CBW |
462 | # Perls < 5.10.1 (with the exception of 5.8.9) have a performance problem with |
463 | # the substitutions below when dealing with strings stored internally in | |
464 | # UTF-8, so downgrade them (if possible). | |
465 | # Data passed to datasend() should be encoded to octets upstream already so | |
466 | # shouldn't even have the UTF-8 flag on to start with, but if it so happens | |
467 | # that the octets are stored in an upgraded string (as can sometimes occur) | |
468 | # then they would still downgrade without fail anyway. | |
469 | # Only Unicode codepoints > 0xFF stored in an upgraded string will fail to | |
470 | # downgrade. We fail silently in that case, and a "Wide character in print" | |
471 | # warning will be emitted later by syswrite(). | |
472 | utf8::downgrade($line, 1) if $] < 5.010001 && $] != 5.008009; | |
b3f6f6a6 | 473 | |
2e173144 CBW |
474 | return 0 |
475 | if $cmd->_is_closed; | |
406c51ee | 476 | |
b3f6f6a6 | 477 | my $last_ch = ${*$cmd}{'net_cmd_last_ch'}; |
8723f121 SH |
478 | |
479 | # We have not send anything yet, so last_ch = "\012" means we are at the start of a line | |
b3f6f6a6 | 480 | $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch; |
f92f3fcb | 481 | |
b3f6f6a6 | 482 | return 1 unless length $line; |
406c51ee | 483 | |
b3f6f6a6 RGS |
484 | if ($cmd->debug) { |
485 | foreach my $b (split(/\n/, $line)) { | |
486 | $cmd->debug_print(1, "$b\n"); | |
487 | } | |
406c51ee JH |
488 | } |
489 | ||
b3f6f6a6 | 490 | $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; |
406c51ee | 491 | |
f92f3fcb GB |
492 | my $first_ch = ''; |
493 | ||
494 | if ($last_ch eq "\015") { | |
8723f121 SH |
495 | # Remove \012 so it does not get prefixed with another \015 below |
496 | # and escape the . if there is one following it because the fixup | |
497 | # below will not find it | |
498 | $first_ch = "\012" if $line =~ s/^\012(\.?)/$1$1/; | |
f92f3fcb GB |
499 | } |
500 | elsif ($last_ch eq "\012") { | |
8723f121 | 501 | # Fixup below will not find the . as the first character of the buffer |
f92f3fcb GB |
502 | $first_ch = "." if $line =~ /^\./; |
503 | } | |
504 | ||
b3f6f6a6 | 505 | $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; |
406c51ee | 506 | |
b3f6f6a6 | 507 | substr($line, 0, 0) = $first_ch; |
f92f3fcb | 508 | |
b3f6f6a6 | 509 | ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1); |
406c51ee | 510 | |
bfdb5bfe SH |
511 | $cmd->_syswrite_with_timeout($line) |
512 | or return; | |
406c51ee | 513 | |
b3f6f6a6 | 514 | 1; |
406c51ee JH |
515 | } |
516 | ||
406c51ee | 517 | |
b3f6f6a6 RGS |
518 | sub rawdatasend { |
519 | my $cmd = shift; | |
520 | my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; | |
521 | my $line = join("", @$arr); | |
406c51ee | 522 | |
2e173144 CBW |
523 | return 0 |
524 | if $cmd->_is_closed; | |
b3f6f6a6 RGS |
525 | |
526 | return 1 | |
dea4d7df | 527 | unless length($line); |
406c51ee | 528 | |
b3f6f6a6 RGS |
529 | if ($cmd->debug) { |
530 | my $b = "$cmd>>> "; | |
531 | print STDERR $b, join("\n$b", split(/\n/, $line)), "\n"; | |
406c51ee | 532 | } |
dea4d7df | 533 | |
bfdb5bfe SH |
534 | $cmd->_syswrite_with_timeout($line) |
535 | or return; | |
406c51ee | 536 | |
b3f6f6a6 | 537 | 1; |
dea4d7df GB |
538 | } |
539 | ||
dea4d7df | 540 | |
b3f6f6a6 RGS |
541 | sub dataend { |
542 | my $cmd = shift; | |
543 | ||
2e173144 CBW |
544 | return 0 |
545 | if $cmd->_is_closed; | |
dea4d7df | 546 | |
b3f6f6a6 RGS |
547 | my $ch = ${*$cmd}{'net_cmd_last_ch'}; |
548 | my $tosend; | |
f92f3fcb | 549 | |
b3f6f6a6 RGS |
550 | if (!defined $ch) { |
551 | return 1; | |
552 | } | |
553 | elsif ($ch ne "\012") { | |
554 | $tosend = "\015\012"; | |
555 | } | |
f92f3fcb | 556 | |
b3f6f6a6 | 557 | $tosend .= ".\015\012"; |
dea4d7df | 558 | |
b3f6f6a6 RGS |
559 | $cmd->debug_print(1, ".\n") |
560 | if ($cmd->debug); | |
406c51ee | 561 | |
bfdb5bfe SH |
562 | $cmd->_syswrite_with_timeout($tosend) |
563 | or return 0; | |
406c51ee | 564 | |
b3f6f6a6 | 565 | delete ${*$cmd}{'net_cmd_last_ch'}; |
406c51ee | 566 | |
b3f6f6a6 | 567 | $cmd->response() == CMD_OK; |
406c51ee JH |
568 | } |
569 | ||
12df23ee GB |
570 | # read and write to tied filehandle |
571 | sub tied_fh { | |
572 | my $cmd = shift; | |
573 | ${*$cmd}{'net_cmd_readbuf'} = ''; | |
574 | my $fh = gensym(); | |
b3f6f6a6 | 575 | tie *$fh, ref($cmd), $cmd; |
12df23ee GB |
576 | return $fh; |
577 | } | |
578 | ||
579 | # tie to myself | |
580 | sub TIEHANDLE { | |
581 | my $class = shift; | |
b3f6f6a6 | 582 | my $cmd = shift; |
12df23ee GB |
583 | return $cmd; |
584 | } | |
585 | ||
586 | # Tied filehandle read. Reads requested data length, returning | |
587 | # end-of-file when the dot is encountered. | |
588 | sub READ { | |
589 | my $cmd = shift; | |
b3f6f6a6 | 590 | my ($len, $offset) = @_[1, 2]; |
12df23ee GB |
591 | return unless exists ${*$cmd}{'net_cmd_readbuf'}; |
592 | my $done = 0; | |
593 | while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) { | |
b3f6f6a6 RGS |
594 | ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return; |
595 | $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m; | |
12df23ee GB |
596 | } |
597 | ||
598 | $_[0] = ''; | |
b3f6f6a6 RGS |
599 | substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len); |
600 | substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = ''; | |
12df23ee GB |
601 | delete ${*$cmd}{'net_cmd_readbuf'} if $done; |
602 | ||
603 | return length $_[0]; | |
604 | } | |
605 | ||
b3f6f6a6 | 606 | |
12df23ee GB |
607 | sub READLINE { |
608 | my $cmd = shift; | |
b3f6f6a6 | 609 | |
12df23ee GB |
610 | # in this context, we use the presence of readbuf to |
611 | # indicate that we have not yet reached the eof | |
612 | return unless exists ${*$cmd}{'net_cmd_readbuf'}; | |
613 | my $line = $cmd->getline; | |
614 | return if $line =~ /^\.\r?\n/; | |
615 | $line; | |
616 | } | |
617 | ||
b3f6f6a6 | 618 | |
12df23ee GB |
619 | sub PRINT { |
620 | my $cmd = shift; | |
b3f6f6a6 RGS |
621 | my ($buf, $len, $offset) = @_; |
622 | $len ||= length($buf); | |
12df23ee | 623 | $offset += 0; |
b3f6f6a6 RGS |
624 | return unless $cmd->datasend(substr($buf, $offset, $len)); |
625 | ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend() | |
12df23ee GB |
626 | return $len; |
627 | } | |
628 | ||
b3f6f6a6 | 629 | |
12df23ee GB |
630 | sub CLOSE { |
631 | my $cmd = shift; | |
b3f6f6a6 | 632 | my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; |
12df23ee GB |
633 | delete ${*$cmd}{'net_cmd_readbuf'}; |
634 | delete ${*$cmd}{'net_cmd_sending'}; | |
635 | $r; | |
636 | } | |
637 | ||
406c51ee JH |
638 | 1; |
639 | ||
640 | __END__ | |
641 | ||
642 | ||
643 | =head1 NAME | |
644 | ||
645 | Net::Cmd - Network Command class (as used by FTP, SMTP etc) | |
646 | ||
647 | =head1 SYNOPSIS | |
648 | ||
649 | use Net::Cmd; | |
686337f3 | 650 | |
406c51ee JH |
651 | @ISA = qw(Net::Cmd); |
652 | ||
653 | =head1 DESCRIPTION | |
654 | ||
a9282e3c SH |
655 | C<Net::Cmd> is a collection of methods that can be inherited by a sub-class |
656 | of C<IO::Socket::INET>. These methods implement the functionality required for a | |
406c51ee JH |
657 | command based protocol, for example FTP and SMTP. |
658 | ||
a9282e3c SH |
659 | If your sub-class does not also derive from C<IO::Socket::INET> or similar (e.g. |
660 | C<IO::Socket::IP>, C<IO::Socket::INET6> or C<IO::Socket::SSL>) then you must | |
661 | provide the following methods by other means yourself: C<close()> and | |
662 | C<timeout()>. | |
663 | ||
27b896ab | 664 | =head2 Public Methods |
406c51ee JH |
665 | |
666 | These methods provide a user interface to the C<Net::Cmd> object. | |
667 | ||
668 | =over 4 | |
669 | ||
27b896ab | 670 | =item C<debug($level)> |
406c51ee | 671 | |
27b896ab | 672 | Set the level of debug information for this object. If C<$level> is not given |
406c51ee | 673 | then the current state is returned. Otherwise the state is changed to |
27b896ab | 674 | C<$level> and the previous state returned. |
406c51ee | 675 | |
510179aa RB |
676 | Different packages |
677 | may implement different levels of debug but a non-zero value results in | |
406c51ee JH |
678 | copies of all commands and responses also being sent to STDERR. |
679 | ||
27b896ab | 680 | If C<$level> is C<undef> then the debug level will be set to the default |
406c51ee JH |
681 | debug level for the class. |
682 | ||
683 | This method can also be called as a I<static> method to set/get the default | |
684 | debug level for a given class. | |
685 | ||
27b896ab | 686 | =item C<message()> |
406c51ee | 687 | |
8723f121 SH |
688 | Returns the text message returned from the last command. In a scalar |
689 | context it returns a single string, in a list context it will return | |
2e173144 | 690 | each line as a separate element. (See L<PSEUDO RESPONSES> below.) |
406c51ee | 691 | |
27b896ab | 692 | =item C<code()> |
406c51ee JH |
693 | |
694 | Returns the 3-digit code from the last command. If a command is pending | |
2e173144 | 695 | then the value 0 is returned. (See L<PSEUDO RESPONSES> below.) |
406c51ee | 696 | |
27b896ab | 697 | =item C<ok()> |
406c51ee JH |
698 | |
699 | Returns non-zero if the last code value was greater than zero and | |
700 | less than 400. This holds true for most command servers. Servers | |
701 | where this does not hold may override this method. | |
702 | ||
27b896ab | 703 | =item C<status()> |
406c51ee JH |
704 | |
705 | Returns the most significant digit of the current status code. If a command | |
706 | is pending then C<CMD_PENDING> is returned. | |
707 | ||
27b896ab | 708 | =item C<datasend($data)> |
406c51ee JH |
709 | |
710 | Send data to the remote server, converting LF to CRLF. Any line starting | |
711 | with a '.' will be prefixed with another '.'. | |
27b896ab SH |
712 | C<$data> may be an array or a reference to an array. |
713 | The C<$data> passed in must be encoded by the caller to octets of whatever | |
db956464 | 714 | encoding is required, e.g. by using the Encode module's C<encode()> function. |
406c51ee | 715 | |
27b896ab | 716 | =item C<dataend()> |
406c51ee JH |
717 | |
718 | End the sending of data to the remote server. This is done by ensuring that | |
719 | the data already sent ends with CRLF then sending '.CRLF' to end the | |
720 | transmission. Once this data has been sent C<dataend> calls C<response> and | |
721 | returns true if C<response> returns CMD_OK. | |
722 | ||
723 | =back | |
724 | ||
27b896ab | 725 | =head2 Protected Methods |
406c51ee JH |
726 | |
727 | These methods are not intended to be called by the user, but used or | |
728 | over-ridden by a sub-class of C<Net::Cmd> | |
729 | ||
730 | =over 4 | |
731 | ||
27b896ab | 732 | =item C<debug_print($dir, $text)> |
406c51ee | 733 | |
27b896ab | 734 | Print debugging information. C<$dir> denotes the direction I<true> being |
406c51ee JH |
735 | data being sent to the server. Calls C<debug_text> before printing to |
736 | STDERR. | |
737 | ||
27b896ab | 738 | =item C<debug_text($dir, $text)> |
406c51ee | 739 | |
27b896ab | 740 | This method is called to print debugging information. C<$text> is |
2e173144 | 741 | the text being sent. The method should return the text to be printed. |
406c51ee JH |
742 | |
743 | This is primarily meant for the use of modules such as FTP where passwords | |
744 | are sent, but we do not want to display them in the debugging information. | |
745 | ||
27b896ab | 746 | =item C<command($cmd[, $args, ... ])> |
406c51ee | 747 | |
2e173144 | 748 | Send a command to the command server. All arguments are first joined with |
406c51ee JH |
749 | a space character and CRLF is appended, this string is then sent to the |
750 | command server. | |
751 | ||
2e173144 | 752 | Returns undef upon failure. |
406c51ee | 753 | |
27b896ab | 754 | =item C<unsupported()> |
406c51ee JH |
755 | |
756 | Sets the status code to 580 and the response text to 'Unsupported command'. | |
757 | Returns zero. | |
758 | ||
27b896ab | 759 | =item C<response()> |
406c51ee JH |
760 | |
761 | Obtain a response from the server. Upon success the most significant digit | |
2e173144 | 762 | of the status code is returned. Upon failure, timeout etc., I<CMD_ERROR> is |
406c51ee JH |
763 | returned. |
764 | ||
27b896ab | 765 | =item C<parse_response($text)> |
406c51ee JH |
766 | |
767 | This method is called by C<response> as a method with one argument. It should | |
768 | return an array of 2 values, the 3-digit status code and a flag which is true | |
2e173144 | 769 | when this is part of a multi-line response and this line is not the last. |
406c51ee | 770 | |
27b896ab | 771 | =item C<getline()> |
406c51ee JH |
772 | |
773 | Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef> | |
774 | upon failure. | |
775 | ||
776 | B<NOTE>: If you do use this method for any reason, please remember to add | |
777 | some C<debug_print> calls into your method. | |
778 | ||
27b896ab | 779 | =item C<ungetline($text)> |
406c51ee JH |
780 | |
781 | Unget a line of text from the server. | |
782 | ||
27b896ab | 783 | =item C<rawdatasend($data)> |
dea4d7df | 784 | |
27b896ab | 785 | Send data to the remote server without performing any conversions. C<$data> |
dea4d7df | 786 | is a scalar. |
27b896ab | 787 | As with C<datasend()>, the C<$data> passed in must be encoded by the caller |
db956464 CBW |
788 | to octets of whatever encoding is required, e.g. by using the Encode module's |
789 | C<encode()> function. | |
dea4d7df | 790 | |
27b896ab | 791 | =item C<read_until_dot()> |
406c51ee JH |
792 | |
793 | Read data from the remote server until a line consisting of a single '.'. | |
794 | Any lines starting with '..' will have one of the '.'s removed. | |
795 | ||
796 | Returns a reference to a list containing the lines, or I<undef> upon failure. | |
797 | ||
27b896ab | 798 | =item C<tied_fh()> |
12df23ee GB |
799 | |
800 | Returns a filehandle tied to the Net::Cmd object. After issuing a | |
801 | command, you may read from this filehandle using read() or <>. The | |
802 | filehandle will return EOF when the final dot is encountered. | |
803 | Similarly, you may write to the filehandle in order to send data to | |
3c4b39be | 804 | the server after issuing a command that expects data to be written. |
12df23ee GB |
805 | |
806 | See the Net::POP3 and Net::SMTP modules for examples of this. | |
807 | ||
406c51ee JH |
808 | =back |
809 | ||
27b896ab | 810 | =head2 Pseudo Responses |
2e173144 CBW |
811 | |
812 | Normally the values returned by C<message()> and C<code()> are | |
813 | obtained from the remote server, but in a few circumstances, as | |
814 | detailed below, C<Net::Cmd> will return values that it sets. You | |
815 | can alter this behavior by overriding DEF_REPLY_CODE() to specify | |
816 | a different default reply code, or overriding one of the specific | |
817 | error handling methods below. | |
818 | ||
819 | =over 4 | |
820 | ||
821 | =item Initial value | |
822 | ||
823 | Before any command has executed or if an unexpected error occurs | |
824 | C<code()> will return "421" (temporary connection failure) and | |
825 | C<message()> will return undef. | |
826 | ||
827 | =item Connection closed | |
828 | ||
829 | If the underlying C<IO::Handle> is closed, or if there are | |
830 | any read or write failures, the file handle will be forced closed, | |
831 | and C<code()> will return "421" (temporary connection failure) | |
832 | and C<message()> will return "[$pkg] Connection closed" | |
833 | (where $pkg is the name of the class that subclassed C<Net::Cmd>). | |
834 | The _set_status_closed() method can be overridden to set a different | |
835 | message (by calling set_status()) or otherwise trap this error. | |
836 | ||
837 | =item Timeout | |
838 | ||
839 | If there is a read or write timeout C<code()> will return "421" | |
840 | (temporary connection failure) and C<message()> will return | |
841 | "[$pkg] Timeout" (where $pkg is the name of the class | |
842 | that subclassed C<Net::Cmd>). The _set_status_timeout() method | |
843 | can be overridden to set a different message (by calling set_status()) | |
844 | or otherwise trap this error. | |
845 | ||
846 | =back | |
847 | ||
406c51ee JH |
848 | =head1 EXPORTS |
849 | ||
27b896ab SH |
850 | The following symbols are, or can be, exported by this module: |
851 | ||
852 | =over 4 | |
853 | ||
854 | =item Default Exports | |
855 | ||
856 | C<CMD_INFO>, | |
857 | C<CMD_OK>, | |
858 | C<CMD_MORE>, | |
859 | C<CMD_REJECT>, | |
860 | C<CMD_ERROR>, | |
861 | C<CMD_PENDING>. | |
862 | ||
863 | (These correspond to possible results of C<response()> and C<status()>.) | |
864 | ||
865 | =item Optional Exports | |
866 | ||
867 | I<None>. | |
868 | ||
869 | =item Export Tags | |
870 | ||
871 | I<None>. | |
872 | ||
873 | =back | |
874 | ||
875 | =head1 KNOWN BUGS | |
876 | ||
877 | See L<https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=libnet>. | |
406c51ee JH |
878 | |
879 | =head1 AUTHOR | |
880 | ||
27b896ab | 881 | Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>. |
2e173144 | 882 | |
27b896ab SH |
883 | Steve Hay E<lt>L<shay@cpan.org|mailto:shay@cpan.org>E<gt> is now maintaining |
884 | libnet as of version 1.22_02. | |
406c51ee JH |
885 | |
886 | =head1 COPYRIGHT | |
887 | ||
8f2f8ba0 SH |
888 | Copyright (C) 1995-2006 Graham Barr. All rights reserved. |
889 | ||
27b896ab | 890 | Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. |
8f2f8ba0 SH |
891 | |
892 | =head1 LICENCE | |
2e173144 | 893 | |
a4f8ff46 SH |
894 | This module is free software; you can redistribute it and/or modify it under the |
895 | same terms as Perl itself, i.e. under the terms of either the GNU General Public | |
896 | License or the Artistic License, as specified in the F<LICENCE> file. | |
406c51ee | 897 | |
27b896ab SH |
898 | =head1 VERSION |
899 | ||
6258b1f3 | 900 | Version 3.13 |
27b896ab SH |
901 | |
902 | =head1 DATE | |
903 | ||
6258b1f3 | 904 | 23 Dec 2020 |
27b896ab SH |
905 | |
906 | =head1 HISTORY | |
907 | ||
908 | See the F<Changes> file. | |
909 | ||
406c51ee | 910 | =cut |