[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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 7 package Net::Cmd; 8 9 require 5.001; 10 require Exporter; 11 12 use strict; 13 use vars qw(@ISA @EXPORT $VERSION); 14 use Carp; 15 use Symbol 'gensym'; 16 17 BEGIN { 18 if ($^O eq 'os390') { 19 require Convert::EBCDIC; 20 21 # Convert::EBCDIC->import; 22 } 23 } 24 25 BEGIN { 26 if (!eval { require utf8 }) { 27 *is_utf8 = sub { 0 }; 28 } 29 elsif (eval { utf8::is_utf8(undef); 1 }) { 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 } 38 } 39 40 $VERSION = "2.29"; 41 @ISA = qw(Exporter); 42 @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); 43 44 45 sub CMD_INFO {1} 46 sub CMD_OK {2} 47 sub CMD_MORE {3} 48 sub CMD_REJECT {4} 49 sub CMD_ERROR {5} 50 sub CMD_PENDING {0} 51 52 my %debug = (); 53 54 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef; 55 56 57 sub 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 72 sub toascii { 73 my $cmd = shift; 74 ${*$cmd}{'net_cmd_asciipeer'} 75 ? $tr->toascii($_[0]) 76 : $_[0]; 77 } 78 79 80 sub _print_isa { 81 no strict qw(refs); 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 sub debug { 114 @_ == 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 sub message { 148 @_ == 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 158 sub debug_text { $_[2] } 159 160 161 sub debug_print { 162 my ($cmd, $out, $text) = @_; 163 print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text); 164 } 165 166 167 sub 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 179 sub 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 188 sub 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 sub command { 204 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 } 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 233 unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len); 234 235 $cmd->debug_print(1, $str) 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 246 sub ok { 247 @_ == 1 or croak 'usage: $obj->ok()'; 248 249 my $code = $_[0]->code; 250 0 < $code && $code < 400; 251 } 252 253 254 sub 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 sub getline { 264 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; 284 my $rout; 285 286 my $select_ret = select($rout = $rin, undef, undef, $timeout); 287 if ($select_ret > 0) { 288 unless (sysread($cmd, $buf = "", 1024)) { 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 323 sub ungetline { 324 my ($cmd, $str) = @_; 325 326 ${*$cmd}{'net_cmd_lines'} ||= []; 327 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); 328 } 329 330 331 sub parse_response { 332 return () 333 unless $_[1] =~ s/^(\d\d\d)(.?)//o; 334 ($1, $2 eq "-"); 335 } 336 337 338 sub response { 339 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(); 346 347 return CMD_ERROR 348 unless defined($str); 349 350 $cmd->debug_print(0, $str) 351 if ($cmd->debug); 352 353 ($code, $more) = $cmd->parse_response($str); 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 370 sub 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 sub datasend { 398 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); 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) { 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 =~ /^\./; 428 } 429 430 $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; 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; 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); 447 if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32 448 { 449 my $w = syswrite($cmd, $line, $len, $offset); 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 467 sub 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 sub dataend { 511 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") 530 if ($cmd->debug); 531 532 syswrite($cmd, $tosend, length $tosend); 533 534 delete ${*$cmd}{'net_cmd_last_ch'}; 535 536 $cmd->response() == CMD_OK; 537 } 538 539 # read and write to tied filehandle 540 sub 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 549 sub 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. 557 sub 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 576 sub 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 588 sub 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 599 sub 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 607 1; 608 609 __END__ 610 611 612 =head1 NAME 613 614 Net::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 624 C<Net::Cmd> is a collection of methods that can be inherited by a sub class 625 of C<IO::Handle>. These methods implement the functionality required for a 626 command based protocol, for example FTP and SMTP. 627 628 =head1 USER METHODS 629 630 These methods provide a user interface to the C<Net::Cmd> object. 631 632 =over 4 633 634 =item debug ( VALUE ) 635 636 Set the level of debug information for this object. If C<VALUE> is not given 637 then the current state is returned. Otherwise the state is changed to 638 C<VALUE> and the previous state returned. 639 640 Different packages 641 may implement different levels of debug but a non-zero value results in 642 copies of all commands and responses also being sent to STDERR. 643 644 If C<VALUE> is C<undef> then the debug level will be set to the default 645 debug level for the class. 646 647 This method can also be called as a I<static> method to set/get the default 648 debug level for a given class. 649 650 =item message () 651 652 Returns the text message returned from the last command 653 654 =item code () 655 656 Returns the 3-digit code from the last command. If a command is pending 657 then the value 0 is returned 658 659 =item ok () 660 661 Returns non-zero if the last code value was greater than zero and 662 less than 400. This holds true for most command servers. Servers 663 where this does not hold may override this method. 664 665 =item status () 666 667 Returns the most significant digit of the current status code. If a command 668 is pending then C<CMD_PENDING> is returned. 669 670 =item datasend ( DATA ) 671 672 Send data to the remote server, converting LF to CRLF. Any line starting 673 with a '.' will be prefixed with another '.'. 674 C<DATA> may be an array or a reference to an array. 675 676 =item dataend () 677 678 End the sending of data to the remote server. This is done by ensuring that 679 the data already sent ends with CRLF then sending '.CRLF' to end the 680 transmission. Once this data has been sent C<dataend> calls C<response> and 681 returns true if C<response> returns CMD_OK. 682 683 =back 684 685 =head1 CLASS METHODS 686 687 These methods are not intended to be called by the user, but used or 688 over-ridden by a sub-class of C<Net::Cmd> 689 690 =over 4 691 692 =item debug_print ( DIR, TEXT ) 693 694 Print debugging information. C<DIR> denotes the direction I<true> being 695 data being sent to the server. Calls C<debug_text> before printing to 696 STDERR. 697 698 =item debug_text ( TEXT ) 699 700 This method is called to print debugging information. TEXT is 701 the text being sent. The method should return the text to be printed 702 703 This is primarily meant for the use of modules such as FTP where passwords 704 are sent, but we do not want to display them in the debugging information. 705 706 =item command ( CMD [, ARGS, ... ]) 707 708 Send a command to the command server. All arguments a first joined with 709 a space character and CRLF is appended, this string is then sent to the 710 command server. 711 712 Returns undef upon failure 713 714 =item unsupported () 715 716 Sets the status code to 580 and the response text to 'Unsupported command'. 717 Returns zero. 718 719 =item response () 720 721 Obtain a response from the server. Upon success the most significant digit 722 of the status code is returned. Upon failure, timeout etc., I<undef> is 723 returned. 724 725 =item parse_response ( TEXT ) 726 727 This method is called by C<response> as a method with one argument. It should 728 return an array of 2 values, the 3-digit status code and a flag which is true 729 when this is part of a multi-line response and this line is not the list. 730 731 =item getline () 732 733 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef> 734 upon failure. 735 736 B<NOTE>: If you do use this method for any reason, please remember to add 737 some C<debug_print> calls into your method. 738 739 =item ungetline ( TEXT ) 740 741 Unget a line of text from the server. 742 743 =item rawdatasend ( DATA ) 744 745 Send data to the remote server without performing any conversions. C<DATA> 746 is a scalar. 747 748 =item read_until_dot () 749 750 Read data from the remote server until a line consisting of a single '.'. 751 Any lines starting with '..' will have one of the '.'s removed. 752 753 Returns a reference to a list containing the lines, or I<undef> upon failure. 754 755 =item tied_fh () 756 757 Returns a filehandle tied to the Net::Cmd object. After issuing a 758 command, you may read from this filehandle using read() or <>. The 759 filehandle will return EOF when the final dot is encountered. 760 Similarly, you may write to the filehandle in order to send data to 761 the server after issuing a command that expects data to be written. 762 763 See the Net::POP3 and Net::SMTP modules for examples of this. 764 765 =back 766 767 =head1 EXPORTS 768 769 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>, 770 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results 771 of C<response> and C<status>. The sixth is C<CMD_PENDING>. 772 773 =head1 AUTHOR 774 775 Graham Barr <gbarr@pobox.com> 776 777 =head1 COPYRIGHT 778 779 Copyright (c) 1995-2006 Graham Barr. All rights reserved. 780 This program is free software; you can redistribute it and/or modify 781 it under the same terms as Perl itself. 782 783 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |