1package Net::Telnet; 2 3## Copyright 1997, 2000, 2002 Jay Rogers. 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## See user documentation at the end of this file. Search for =head 8 9use strict; 10require 5.002; 11 12## Module export. 13use vars qw(@EXPORT_OK); 14@EXPORT_OK = qw(TELNET_IAC TELNET_DONT TELNET_DO TELNET_WONT TELNET_WILL 15 TELNET_SB TELNET_GA TELNET_EL TELNET_EC TELNET_AYT TELNET_AO 16 TELNET_IP TELNET_BREAK TELNET_DM TELNET_NOP TELNET_SE 17 TELNET_EOR TELNET_ABORT TELNET_SUSP TELNET_EOF TELNET_SYNCH 18 TELOPT_BINARY TELOPT_ECHO TELOPT_RCP TELOPT_SGA TELOPT_NAMS 19 TELOPT_STATUS TELOPT_TM TELOPT_RCTE TELOPT_NAOL TELOPT_NAOP 20 TELOPT_NAOCRD TELOPT_NAOHTS TELOPT_NAOHTD TELOPT_NAOFFD 21 TELOPT_NAOVTS TELOPT_NAOVTD TELOPT_NAOLFD TELOPT_XASCII 22 TELOPT_LOGOUT TELOPT_BM TELOPT_DET TELOPT_SUPDUP 23 TELOPT_SUPDUPOUTPUT TELOPT_SNDLOC TELOPT_TTYPE TELOPT_EOR 24 TELOPT_TUID TELOPT_OUTMRK TELOPT_TTYLOC TELOPT_3270REGIME 25 TELOPT_X3PAD TELOPT_NAWS TELOPT_TSPEED TELOPT_LFLOW 26 TELOPT_LINEMODE TELOPT_XDISPLOC TELOPT_OLD_ENVIRON 27 TELOPT_AUTHENTICATION TELOPT_ENCRYPT TELOPT_NEW_ENVIRON 28 TELOPT_EXOPL); 29 30## Module import. 31use Exporter (); 32use Socket qw(AF_INET SOCK_STREAM inet_aton sockaddr_in); 33use Symbol qw(qualify); 34 35## Base classes. 36use vars qw(@ISA); 37@ISA = qw(Exporter); 38if (&_io_socket_include) { # successfully required module IO::Socket 39 push @ISA, "IO::Socket::INET"; 40} 41else { # perl version < 5.004 42 require FileHandle; 43 push @ISA, "FileHandle"; 44} 45 46## Global variables. 47use vars qw($VERSION @Telopts); 48$VERSION = "3.03"; 49@Telopts = ("BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", "NAME", "STATUS", 50 "TIMING MARK", "RCTE", "NAOL", "NAOP", "NAOCRD", "NAOHTS", 51 "NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", "NAOLFD", "EXTEND ASCII", 52 "LOGOUT", "BYTE MACRO", "DATA ENTRY TERMINAL", "SUPDUP", 53 "SUPDUP OUTPUT", "SEND LOCATION", "TERMINAL TYPE", "END OF RECORD", 54 "TACACS UID", "OUTPUT MARKING", "TTYLOC", "3270 REGIME", "X.3 PAD", 55 "NAWS", "TSPEED", "LFLOW", "LINEMODE", "XDISPLOC", "OLD-ENVIRON", 56 "AUTHENTICATION", "ENCRYPT", "NEW-ENVIRON"); 57 58 59########################### Public Methods ########################### 60 61 62sub new { 63 my ($class) = @_; 64 my ( 65 $errmode, 66 $fh_open, 67 $host, 68 $self, 69 %args, 70 ); 71 local $_; 72 73 ## Create a new object with defaults. 74 $self = $class->SUPER::new; 75 *$self->{net_telnet} = { 76 bin_mode => 0, 77 blksize => &_optimal_blksize(), 78 buf => "", 79 cmd_prompt => '/[\$%#>] $/', 80 cmd_rm_mode => "auto", 81 dumplog => '', 82 eofile => 1, 83 errormode => "die", 84 errormsg => "", 85 fdmask => '', 86 host => "localhost", 87 inputlog => '', 88 last_line => "", 89 last_prompt => "", 90 maxbufsize => 1_048_576, 91 num_wrote => 0, 92 ofs => "", 93 opened => '', 94 opt_cback => '', 95 opt_log => '', 96 opts => {}, 97 ors => "\n", 98 outputlog => '', 99 pending_errormsg => "", 100 port => 23, 101 pushback_buf => "", 102 rs => "\n", 103 subopt_cback => '', 104 telnet_mode => 1, 105 time_out => 10, 106 timedout => '', 107 unsent_opts => "", 108 }; 109 110 ## Indicate that we'll accept an offer from remote side for it to echo 111 ## and suppress go aheads. 112 &_opt_accept($self, 113 { option => &TELOPT_ECHO, 114 is_remote => 1, 115 is_enable => 1 }, 116 { option => &TELOPT_SGA, 117 is_remote => 1, 118 is_enable => 1 }, 119 ); 120 121 ## Parse the args. 122 if (@_ == 2) { # one positional arg given 123 $host = $_[1]; 124 } 125 elsif (@_ > 2) { # named args given 126 ## Get the named args. 127 (undef, %args) = @_; 128 129 ## Parse all other named args. 130 foreach (keys %args) { 131 if (/^-?binmode$/i) { 132 $self->binmode($args{$_}); 133 } 134 elsif (/^-?cmd_remove_mode$/i) { 135 $self->cmd_remove_mode($args{$_}); 136 } 137 elsif (/^-?dump_log$/i) { 138 $self->dump_log($args{$_}); 139 } 140 elsif (/^-?errmode$/i) { 141 $errmode = $args{$_}; 142 } 143 elsif (/^-?fhopen$/i) { 144 $fh_open = $args{$_}; 145 } 146 elsif (/^-?host$/i) { 147 $host = $args{$_}; 148 } 149 elsif (/^-?input_log$/i) { 150 $self->input_log($args{$_}); 151 } 152 elsif (/^-?input_record_separator$/i or /^-?rs$/i) { 153 $self->input_record_separator($args{$_}); 154 } 155 elsif (/^-?option_log$/i) { 156 $self->option_log($args{$_}); 157 } 158 elsif (/^-?output_log$/i) { 159 $self->output_log($args{$_}); 160 } 161 elsif (/^-?output_record_separator$/i or /^-?ors$/i) { 162 $self->output_record_separator($args{$_}); 163 } 164 elsif (/^-?port$/i) { 165 $self->port($args{$_}); 166 } 167 elsif (/^-?prompt$/i) { 168 $self->prompt($args{$_}); 169 } 170 elsif (/^-?telnetmode$/i) { 171 $self->telnetmode($args{$_}); 172 } 173 elsif (/^-?timeout$/i) { 174 $self->timeout($args{$_}); 175 } 176 else { 177 &_croak($self, "bad named parameter \"$_\" given " . 178 "to " . ref($self) . "::new()"); 179 } 180 } 181 } 182 183 if (defined $errmode) { # user wants to set errmode 184 $self->errmode($errmode); 185 } 186 187 if (defined $fh_open) { # user wants us to attach to existing filehandle 188 $self->fhopen($fh_open) 189 or return; 190 } 191 elsif (defined $host) { # user wants us to open a connection to host 192 $self->host($host); 193 $self->open 194 or return; 195 } 196 197 $self; 198} # end sub new 199 200 201sub DESTROY { 202} # end sub DESTROY 203 204 205sub binmode { 206 my ($self, $mode) = @_; 207 my ( 208 $prev, 209 $s, 210 ); 211 212 $s = *$self->{net_telnet}; 213 $prev = $s->{bin_mode}; 214 215 if (@_ >= 2) { 216 unless (defined $mode) { 217 $mode = 0; 218 } 219 220 $s->{bin_mode} = $mode; 221 } 222 223 $prev; 224} # end sub binmode 225 226 227sub break { 228 my ($self) = @_; 229 my $s = *$self->{net_telnet}; 230 my $break_cmd = "\xff\xf3"; 231 232 $s->{timedout} = ''; 233 234 &_put($self, \$break_cmd, "break"); 235} # end sub break 236 237 238sub buffer { 239 my ($self) = @_; 240 my $s = *$self->{net_telnet}; 241 242 \$s->{buf}; 243} # end sub buffer 244 245 246sub buffer_empty { 247 my ($self) = @_; 248 my ( 249 $buffer, 250 ); 251 252 $buffer = $self->buffer; 253 $$buffer = ""; 254} # end sub buffer_empty 255 256 257sub close { 258 my ($self) = @_; 259 my $s = *$self->{net_telnet}; 260 261 $s->{eofile} = 1; 262 $s->{opened} = ''; 263 close $self 264 if defined fileno($self); 265 266 1; 267} # end sub close 268 269 270sub cmd { 271 my ($self, @args) = @_; 272 my ( 273 $cmd_remove_mode, 274 $errmode, 275 $firstpos, 276 $last_prompt, 277 $lastpos, 278 $lines, 279 $ors, 280 $output, 281 $output_ref, 282 $prompt, 283 $remove_echo, 284 $rs, 285 $rs_len, 286 $s, 287 $telopt_echo, 288 $timeout, 289 %args, 290 ); 291 my $cmd = ""; 292 local $_; 293 294 ## Init. 295 $self->timed_out(''); 296 $self->last_prompt(""); 297 $s = *$self->{net_telnet}; 298 $output = []; 299 $cmd_remove_mode = $self->cmd_remove_mode; 300 $errmode = $self->errmode; 301 $ors = $self->output_record_separator; 302 $prompt = $self->prompt; 303 $rs = $self->input_record_separator; 304 $timeout = $self->timeout; 305 306 ## Parse args. 307 if (@_ == 2) { # one positional arg given 308 $cmd = $_[1]; 309 } 310 elsif (@_ > 2) { # named args given 311 ## Get the named args. 312 (undef, %args) = @_; 313 314 ## Parse the named args. 315 foreach (keys %args) { 316 if (/^-?cmd_remove/i) { 317 $cmd_remove_mode = &_parse_cmd_remove_mode($self, $args{$_}); 318 } 319 elsif (/^-?errmode$/i) { 320 $errmode = &_parse_errmode($self, $args{$_}); 321 } 322 elsif (/^-?input_record_separator$/i or /^-?rs$/i) { 323 $rs = &_parse_input_record_separator($self, $args{$_}); 324 } 325 elsif (/^-?output$/i) { 326 $output_ref = $args{$_}; 327 if (defined($output_ref) and ref($output_ref) eq "ARRAY") { 328 $output = $output_ref; 329 } 330 } 331 elsif (/^-?output_record_separator$/i or /^-?ors$/i) { 332 $ors = $self->output_record_separator($args{$_}); 333 } 334 elsif (/^-?prompt$/i) { 335 $prompt = &_parse_prompt($self, $args{$_}); 336 } 337 elsif (/^-?string$/i) { 338 $cmd = $args{$_}; 339 } 340 elsif (/^-?timeout$/i) { 341 $timeout = &_parse_timeout($self, $args{$_}); 342 } 343 else { 344 &_croak($self, "bad named parameter \"$_\" given " . 345 "to " . ref($self) . "::cmd()"); 346 } 347 } 348 } 349 350 ## Override some user settings. 351 local $s->{errormode} = "return"; 352 local $s->{time_out} = &_endtime($timeout); 353 $self->errmsg(""); 354 355 ## Send command and wait for the prompt. 356 $self->put($cmd . $ors) 357 and ($lines, $last_prompt) = $self->waitfor($prompt); 358 359 ## Check for failure. 360 $s->{errormode} = $errmode; 361 return $self->error("command timed-out") if $self->timed_out; 362 return $self->error($self->errmsg) if $self->errmsg ne ""; 363 364 ## Save the most recently matched prompt. 365 $self->last_prompt($last_prompt); 366 367 ## Split lines into an array, keeping record separator at end of line. 368 $firstpos = 0; 369 $rs_len = length $rs; 370 while (($lastpos = index($lines, $rs, $firstpos)) > -1) { 371 push(@$output, 372 substr($lines, $firstpos, $lastpos - $firstpos + $rs_len)); 373 $firstpos = $lastpos + $rs_len; 374 } 375 376 if ($firstpos < length $lines) { 377 push @$output, substr($lines, $firstpos); 378 } 379 380 ## Determine if we should remove the first line of output based 381 ## on the assumption that it's an echoed back command. 382 if ($cmd_remove_mode eq "auto") { 383 ## See if remote side told us they'd echo. 384 $telopt_echo = $self->option_state(&TELOPT_ECHO); 385 $remove_echo = $telopt_echo->{remote_enabled}; 386 } 387 else { # user explicitly told us how many lines to remove. 388 $remove_echo = $cmd_remove_mode; 389 } 390 391 ## Get rid of possible echo back command. 392 while ($remove_echo--) { 393 shift @$output; 394 } 395 396 ## Ensure at least a null string when there's no command output - so 397 ## "true" is returned in a list context. 398 unless (@$output) { 399 @$output = (""); 400 } 401 402 ## Return command output via named arg, if requested. 403 if (defined $output_ref) { 404 if (ref($output_ref) eq "SCALAR") { 405 $$output_ref = join "", @$output; 406 } 407 elsif (ref($output_ref) eq "HASH") { 408 %$output_ref = @$output; 409 } 410 } 411 412 wantarray ? @$output : 1; 413} # end sub cmd 414 415 416sub cmd_remove_mode { 417 my ($self, $mode) = @_; 418 my ( 419 $prev, 420 $s, 421 ); 422 423 $s = *$self->{net_telnet}; 424 $prev = $s->{cmd_rm_mode}; 425 426 if (@_ >= 2) { 427 $s->{cmd_rm_mode} = &_parse_cmd_remove_mode($self, $mode); 428 } 429 430 $prev; 431} # end sub cmd_remove_mode 432 433 434sub dump_log { 435 my ($self, $name) = @_; 436 my ( 437 $fh, 438 $s, 439 ); 440 441 $s = *$self->{net_telnet}; 442 $fh = $s->{dumplog}; 443 444 if (@_ >= 2) { 445 unless (defined $name) { 446 $name = ""; 447 } 448 449 $fh = &_fname_to_handle($self, $name) 450 or return; 451 $s->{dumplog} = $fh; 452 } 453 454 $fh; 455} # end sub dump_log 456 457 458sub eof { 459 my ($self) = @_; 460 461 *$self->{net_telnet}{eofile}; 462} # end sub eof 463 464 465sub errmode { 466 my ($self, $mode) = @_; 467 my ( 468 $prev, 469 $s, 470 ); 471 472 $s = *$self->{net_telnet}; 473 $prev = $s->{errormode}; 474 475 if (@_ >= 2) { 476 $s->{errormode} = &_parse_errmode($self, $mode); 477 } 478 479 $prev; 480} # end sub errmode 481 482 483sub errmsg { 484 my ($self, @errmsgs) = @_; 485 my ( 486 $prev, 487 $s, 488 ); 489 490 $s = *$self->{net_telnet}; 491 $prev = $s->{errormsg}; 492 493 if (@_ >= 2) { 494 $s->{errormsg} = join "", @errmsgs; 495 } 496 497 $prev; 498} # end sub errmsg 499 500 501sub error { 502 my ($self, @errmsg) = @_; 503 my ( 504 $errmsg, 505 $func, 506 $mode, 507 $s, 508 @args, 509 ); 510 local $_; 511 512 $s = *$self->{net_telnet}; 513 514 if (@_ >= 2) { 515 ## Put error message in the object. 516 $errmsg = join "", @errmsg; 517 $s->{errormsg} = $errmsg; 518 519 ## Do the error action as described by error mode. 520 $mode = $s->{errormode}; 521 if (ref($mode) eq "CODE") { 522 &$mode($errmsg); 523 return; 524 } 525 elsif (ref($mode) eq "ARRAY") { 526 ($func, @args) = @$mode; 527 &$func(@args); 528 return; 529 } 530 elsif ($mode =~ /^return$/i) { 531 return; 532 } 533 else { # die 534 if ($errmsg =~ /\n$/) { 535 die $errmsg; 536 } 537 else { 538 ## Die and append caller's line number to message. 539 &_croak($self, $errmsg); 540 } 541 } 542 } 543 else { 544 return $s->{errormsg} ne ""; 545 } 546} # end sub error 547 548 549sub fhopen { 550 my ($self, $fh) = @_; 551 my ( 552 $globref, 553 $s, 554 ); 555 556 ## Convert given filehandle to a typeglob reference, if necessary. 557 $globref = &_qualify_fh($self, $fh); 558 559 ## Ensure filehandle is already open. 560 return $self->error("fhopen filehandle isn't already open") 561 unless defined($globref) and defined(fileno $globref); 562 563 ## Ensure we're closed. 564 $self->close; 565 566 ## Save our private data. 567 $s = *$self->{net_telnet}; 568 569 ## Switch ourself with the given filehandle. 570 *$self = *$globref; 571 572 ## Restore our private data. 573 *$self->{net_telnet} = $s; 574 575 ## Re-initialize ourself. 576 select((select($self), $|=1)[$[]); # don't buffer writes 577 $s = *$self->{net_telnet}; 578 $s->{blksize} = &_optimal_blksize((stat $self)[11]); 579 $s->{buf} = ""; 580 $s->{eofile} = ''; 581 $s->{errormsg} = ""; 582 vec($s->{fdmask}='', fileno($self), 1) = 1; 583 $s->{host} = ""; 584 $s->{last_line} = ""; 585 $s->{last_prompt} = ""; 586 $s->{num_wrote} = 0; 587 $s->{opened} = 1; 588 $s->{pending_errormsg} = ""; 589 $s->{port} = ''; 590 $s->{pushback_buf} = ""; 591 $s->{timedout} = ''; 592 $s->{unsent_opts} = ""; 593 &_reset_options($s->{opts}); 594 595 1; 596} # end sub fhopen 597 598 599sub get { 600 my ($self, %args) = @_; 601 my ( 602 $binmode, 603 $endtime, 604 $errmode, 605 $line, 606 $s, 607 $telnetmode, 608 $timeout, 609 ); 610 local $_; 611 612 ## Init. 613 $s = *$self->{net_telnet}; 614 $timeout = $s->{time_out}; 615 $s->{timedout} = ''; 616 return if $s->{eofile}; 617 618 ## Parse the named args. 619 foreach (keys %args) { 620 if (/^-?binmode$/i) { 621 $binmode = $args{$_}; 622 unless (defined $binmode) { 623 $binmode = 0; 624 } 625 } 626 elsif (/^-?errmode$/i) { 627 $errmode = &_parse_errmode($self, $args{$_}); 628 } 629 elsif (/^-?telnetmode$/i) { 630 $telnetmode = $args{$_}; 631 unless (defined $telnetmode) { 632 $telnetmode = 0; 633 } 634 } 635 elsif (/^-?timeout$/i) { 636 $timeout = &_parse_timeout($self, $args{$_}); 637 } 638 else { 639 &_croak($self, "bad named parameter \"$_\" given " . 640 "to " . ref($self) . "::get()"); 641 } 642 } 643 644 ## If any args given, override corresponding instance data. 645 local $s->{errormode} = $errmode 646 if defined $errmode; 647 local $s->{bin_mode} = $binmode 648 if defined $binmode; 649 local $s->{telnet_mode} = $telnetmode 650 if defined $telnetmode; 651 652 ## Set wall time when we time out. 653 $endtime = &_endtime($timeout); 654 655 ## Try to send any waiting option negotiation. 656 if (length $s->{unsent_opts}) { 657 &_flush_opts($self); 658 } 659 660 ## Try to read just the waiting data using return error mode. 661 { 662 local $s->{errormode} = "return"; 663 $s->{errormsg} = ""; 664 &_fillbuf($self, $s, 0); 665 } 666 667 ## We're done if we timed-out and timeout value is set to "poll". 668 return $self->error($s->{errormsg}) 669 if ($s->{timedout} and defined($timeout) and $timeout == 0 670 and !length $s->{buf}); 671 672 ## We're done if we hit an error other than timing out. 673 if ($s->{errormsg} and !$s->{timedout}) { 674 if (!length $s->{buf}) { 675 return $self->error($s->{errormsg}); 676 } 677 else { # error encountered but there's some data in buffer 678 $s->{pending_errormsg} = $s->{errormsg}; 679 } 680 } 681 682 ## Clear time-out error from first read. 683 $s->{timedout} = ''; 684 $s->{errormsg} = ""; 685 686 ## If buffer is still empty, try to read according to user's timeout. 687 if (!length $s->{buf}) { 688 &_fillbuf($self, $s, $endtime) 689 or do { 690 return if $s->{timedout}; 691 692 ## We've reached end-of-file. 693 $self->close; 694 return; 695 }; 696 } 697 698 ## Extract chars from buffer. 699 $line = $s->{buf}; 700 $s->{buf} = ""; 701 702 $line; 703} # end sub get 704 705 706sub getline { 707 my ($self, %args) = @_; 708 my ( 709 $binmode, 710 $endtime, 711 $errmode, 712 $len, 713 $line, 714 $offset, 715 $pos, 716 $rs, 717 $s, 718 $telnetmode, 719 $timeout, 720 ); 721 local $_; 722 723 ## Init. 724 $s = *$self->{net_telnet}; 725 $s->{timedout} = ''; 726 return if $s->{eofile}; 727 $rs = $s->{rs}; 728 $timeout = $s->{time_out}; 729 730 ## Parse the named args. 731 foreach (keys %args) { 732 if (/^-?binmode$/i) { 733 $binmode = $args{$_}; 734 unless (defined $binmode) { 735 $binmode = 0; 736 } 737 } 738 elsif (/^-?errmode$/i) { 739 $errmode = &_parse_errmode($self, $args{$_}); 740 } 741 elsif (/^-?input_record_separator$/i or /^-?rs$/i) { 742 $rs = &_parse_input_record_separator($self, $args{$_}); 743 } 744 elsif (/^-?telnetmode$/i) { 745 $telnetmode = $args{$_}; 746 unless (defined $telnetmode) { 747 $telnetmode = 0; 748 } 749 } 750 elsif (/^-?timeout$/i) { 751 $timeout = &_parse_timeout($self, $args{$_}); 752 } 753 else { 754 &_croak($self, "bad named parameter \"$_\" given " . 755 "to " . ref($self) . "::getline()"); 756 } 757 } 758 759 ## If any args given, override corresponding instance data. 760 local $s->{bin_mode} = $binmode 761 if defined $binmode; 762 local $s->{errormode} = $errmode 763 if defined $errmode; 764 local $s->{telnet_mode} = $telnetmode 765 if defined $telnetmode; 766 767 ## Set wall time when we time out. 768 $endtime = &_endtime($timeout); 769 770 ## Try to send any waiting option negotiation. 771 if (length $s->{unsent_opts}) { 772 &_flush_opts($self); 773 } 774 775 ## Keep reading into buffer until end-of-line is read. 776 $offset = 0; 777 while (($pos = index($s->{buf}, $rs, $offset)) == -1) { 778 $offset = length $s->{buf}; 779 &_fillbuf($self, $s, $endtime) 780 or do { 781 return if $s->{timedout}; 782 783 ## We've reached end-of-file. 784 $self->close; 785 if (length $s->{buf}) { 786 return $s->{buf}; 787 } 788 else { 789 return; 790 } 791 }; 792 } 793 794 ## Extract line from buffer. 795 $len = $pos + length $rs; 796 $line = substr($s->{buf}, 0, $len); 797 substr($s->{buf}, 0, $len) = ""; 798 799 $line; 800} # end sub getline 801 802 803sub getlines { 804 my ($self, %args) = @_; 805 my ( 806 $binmode, 807 $errmode, 808 $line, 809 $rs, 810 $s, 811 $telnetmode, 812 $timeout, 813 ); 814 my $all = 1; 815 my @lines = (); 816 local $_; 817 818 ## Init. 819 $s = *$self->{net_telnet}; 820 $s->{timedout} = ''; 821 return if $s->{eofile}; 822 $timeout = $s->{time_out}; 823 824 ## Parse the named args. 825 foreach (keys %args) { 826 if (/^-?all$/i) { 827 $all = $args{$_}; 828 unless (defined $all) { 829 $all = ''; 830 } 831 } 832 elsif (/^-?binmode$/i) { 833 $binmode = $args{$_}; 834 unless (defined $binmode) { 835 $binmode = 0; 836 } 837 } 838 elsif (/^-?errmode$/i) { 839 $errmode = &_parse_errmode($self, $args{$_}); 840 } 841 elsif (/^-?input_record_separator$/i or /^-?rs$/i) { 842 $rs = &_parse_input_record_separator($self, $args{$_}); 843 } 844 elsif (/^-?telnetmode$/i) { 845 $telnetmode = $args{$_}; 846 unless (defined $telnetmode) { 847 $telnetmode = 0; 848 } 849 } 850 elsif (/^-?timeout$/i) { 851 $timeout = &_parse_timeout($self, $args{$_}); 852 } 853 else { 854 &_croak($self, "bad named parameter \"$_\" given " . 855 "to " . ref($self) . "::getlines()"); 856 } 857 } 858 859 ## If any args given, override corresponding instance data. 860 local $s->{bin_mode} = $binmode 861 if defined $binmode; 862 local $s->{errormode} = $errmode 863 if defined $errmode; 864 local $s->{rs} = $rs 865 if defined $rs; 866 local $s->{telnet_mode} = $telnetmode 867 if defined $telnetmode; 868 local $s->{time_out} = &_endtime($timeout); 869 870 ## User requested only the currently available lines. 871 if (! $all) { 872 return &_next_getlines($self, $s); 873 } 874 875 ## Read lines until eof or error. 876 while (1) { 877 $line = $self->getline 878 or last; 879 push @lines, $line; 880 } 881 882 ## Check for error. 883 return if ! $self->eof; 884 885 @lines; 886} # end sub getlines 887 888 889sub host { 890 my ($self, $host) = @_; 891 my ( 892 $prev, 893 $s, 894 ); 895 896 $s = *$self->{net_telnet}; 897 $prev = $s->{host}; 898 899 if (@_ >= 2) { 900 unless (defined $host) { 901 $host = ""; 902 } 903 904 $s->{host} = $host; 905 } 906 907 $prev; 908} # end sub host 909 910 911sub input_log { 912 my ($self, $name) = @_; 913 my ( 914 $fh, 915 $s, 916 ); 917 918 $s = *$self->{net_telnet}; 919 $fh = $s->{inputlog}; 920 921 if (@_ >= 2) { 922 unless (defined $name) { 923 $name = ""; 924 } 925 926 $fh = &_fname_to_handle($self, $name) 927 or return; 928 $s->{inputlog} = $fh; 929 } 930 931 $fh; 932} # end sub input_log 933 934 935sub input_record_separator { 936 my ($self, $rs) = @_; 937 my ( 938 $prev, 939 $s, 940 ); 941 942 $s = *$self->{net_telnet}; 943 $prev = $s->{rs}; 944 945 if (@_ >= 2) { 946 $s->{rs} = &_parse_input_record_separator($self, $rs); 947 } 948 949 $prev; 950} # end sub input_record_separator 951 952 953sub last_prompt { 954 my ($self, $string) = @_; 955 my ( 956 $prev, 957 $s, 958 ); 959 960 $s = *$self->{net_telnet}; 961 $prev = $s->{last_prompt}; 962 963 if (@_ >= 2) { 964 unless (defined $string) { 965 $string = ""; 966 } 967 968 $s->{last_prompt} = $string; 969 } 970 971 $prev; 972} # end sub last_prompt 973 974 975sub lastline { 976 my ($self, $line) = @_; 977 my ( 978 $prev, 979 $s, 980 ); 981 982 $s = *$self->{net_telnet}; 983 $prev = $s->{last_line}; 984 985 if (@_ >= 2) { 986 unless (defined $line) { 987 $line = ""; 988 } 989 990 $s->{last_line} = $line; 991 } 992 993 $prev; 994} # end sub lastline 995 996 997sub login { 998 my ($self) = @_; 999 my ( 1000 $errmode, 1001 $error, 1002 $is_passwd_arg, 1003 $is_username_arg, 1004 $lastline, 1005 $match, 1006 $ors, 1007 $passwd, 1008 $prematch, 1009 $prompt, 1010 $s, 1011 $timeout, 1012 $username, 1013 %args, 1014 ); 1015 local $_; 1016 1017 ## Init. 1018 $self->timed_out(''); 1019 $self->last_prompt(""); 1020 $s = *$self->{net_telnet}; 1021 $timeout = $self->timeout; 1022 $ors = $self->output_record_separator; 1023 $prompt = $self->prompt; 1024 1025 ## Parse args. 1026 if (@_ == 3) { # just username and passwd given 1027 $username = $_[1]; 1028 $passwd = $_[2]; 1029 1030 $is_username_arg = 1; 1031 $is_passwd_arg = 1; 1032 } 1033 else { # named args given 1034 ## Get the named args. 1035 (undef, %args) = @_; 1036 1037 ## Parse the named args. 1038 foreach (keys %args) { 1039 if (/^-?errmode$/i) { 1040 $errmode = &_parse_errmode($self, $args{$_}); 1041 } 1042 elsif (/^-?name$/i) { 1043 $username = $args{$_}; 1044 unless (defined $username) { 1045 $username = ""; 1046 } 1047 1048 $is_username_arg = 1; 1049 } 1050 elsif (/^-?pass/i) { 1051 $passwd = $args{$_}; 1052 unless (defined $passwd) { 1053 $passwd = ""; 1054 } 1055 1056 $is_passwd_arg = 1; 1057 } 1058 elsif (/^-?prompt$/i) { 1059 $prompt = &_parse_prompt($self, $args{$_}); 1060 } 1061 elsif (/^-?timeout$/i) { 1062 $timeout = &_parse_timeout($self, $args{$_}); 1063 } 1064 else { 1065 &_croak($self, "bad named parameter \"$_\" given ", 1066 "to " . ref($self) . "::login()"); 1067 } 1068 } 1069 } 1070 1071 ## Ensure both username and password argument given. 1072 &_croak($self,"Name argument not given to " . ref($self) . "::login()") 1073 unless $is_username_arg; 1074 &_croak($self,"Password argument not given to " . ref($self) . "::login()") 1075 unless $is_passwd_arg; 1076 1077 ## Override some user settings. 1078 local $s->{errormode} = $errmode 1079 if defined $errmode; 1080 local $s->{time_out} = &_endtime($timeout); 1081 1082 ## Create a subroutine to generate an error. 1083 $error 1084 = sub { 1085 my ($errmsg) = @_; 1086 1087 if ($self->timed_out) { 1088 return $self->error($errmsg); 1089 } 1090 elsif ($self->eof) { 1091 ($lastline = $self->lastline) =~ s/\n+//; 1092 return $self->error($errmsg, ": ", $lastline); 1093 } 1094 else { 1095 return $self->error($self->errmsg); 1096 } 1097 }; 1098 1099 1100 return $self->error("login failed: filehandle isn't open") 1101 if $self->eof; 1102 1103 ## Wait for login prompt. 1104 $self->waitfor(Match => '/login[: ]*$/i', 1105 Match => '/username[: ]*$/i', 1106 Errmode => "return") 1107 or do { 1108 return &$error("eof read waiting for login prompt") 1109 if $self->eof; 1110 return &$error("timed-out waiting for login prompt"); 1111 }; 1112 1113 ## Delay sending response because of bug in Linux login program. 1114 &_sleep(0.01); 1115 1116 ## Send login name. 1117 $self->put(String => $username . $ors, 1118 Errmode => "return") 1119 or return &$error("login disconnected"); 1120 1121 ## Wait for password prompt. 1122 $self->waitfor(Match => '/password[: ]*$/i', 1123 Errmode => "return") 1124 or do { 1125 return &$error("eof read waiting for password prompt") 1126 if $self->eof; 1127 return &$error("timed-out waiting for password prompt"); 1128 }; 1129 1130 ## Delay sending response because of bug in Linux login program. 1131 &_sleep(0.01); 1132 1133 ## Send password. 1134 $self->put(String => $passwd . $ors, 1135 Errmode => "return") 1136 or return &$error("login disconnected"); 1137 1138 ## Wait for command prompt or another login prompt. 1139 ($prematch, $match) = $self->waitfor(Match => '/login[: ]*$/i', 1140 Match => '/username[: ]*$/i', 1141 Match => $prompt, 1142 Errmode => "return") 1143 or do { 1144 return &$error("eof read waiting for command prompt") 1145 if $self->eof; 1146 return &$error("timed-out waiting for command prompt"); 1147 }; 1148 1149 ## It's a bad login if we got another login prompt. 1150 return $self->error("login failed: bad name or password") 1151 if $match =~ /login[: ]*$/i or $match =~ /username[: ]*$/i; 1152 1153 ## Save the most recently matched command prompt. 1154 $self->last_prompt($match); 1155 1156 1; 1157} # end sub login 1158 1159 1160sub max_buffer_length { 1161 my ($self, $maxbufsize) = @_; 1162 my ( 1163 $prev, 1164 $s, 1165 ); 1166 my $minbufsize = 512; 1167 1168 $s = *$self->{net_telnet}; 1169 $prev = $s->{maxbufsize}; 1170 1171 if (@_ >= 2) { 1172 ## Ensure a positive integer value. 1173 unless (defined $maxbufsize 1174 and $maxbufsize =~ /^\d+$/ 1175 and $maxbufsize) 1176 { 1177 &_carp($self, "ignoring bad Max_buffer_length " . 1178 "argument \"$maxbufsize\": it's not a positive integer"); 1179 $maxbufsize = $prev; 1180 } 1181 1182 ## Adjust up values that are too small. 1183 if ($maxbufsize < $minbufsize) { 1184 $maxbufsize = $minbufsize; 1185 } 1186 1187 $s->{maxbufsize} = $maxbufsize; 1188 } 1189 1190 $prev; 1191} # end sub max_buffer_length 1192 1193 1194## Make ofs() synonymous with output_field_separator(). 1195*ofs = \&output_field_separator; 1196 1197 1198sub open { 1199 my ($self) = @_; 1200 my ( 1201 $errmode, 1202 $errno, 1203 $host, 1204 $ip_addr, 1205 $port, 1206 $s, 1207 $timeout, 1208 %args, 1209 ); 1210 local $_; 1211 1212 ## Init. 1213 $s = *$self->{net_telnet}; 1214 $timeout = $s->{time_out}; 1215 $s->{timedout} = ''; 1216 1217 if (@_ == 2) { # one positional arg given 1218 $self->host($_[1]); 1219 } 1220 elsif (@_ > 2) { # named args given 1221 ## Get the named args. 1222 (undef, %args) = @_; 1223 1224 ## Parse the named args. 1225 foreach (keys %args) { 1226 if (/^-?errmode$/i) { 1227 $errmode = &_parse_errmode($self, $args{$_}); 1228 } 1229 elsif (/^-?host$/i) { 1230 $self->host($args{$_}); 1231 } 1232 elsif (/^-?port$/i) { 1233 $self->port($args{$_}) 1234 or return; 1235 } 1236 elsif (/^-?timeout$/i) { 1237 $timeout = &_parse_timeout($self, $args{$_}); 1238 } 1239 else { 1240 &_croak($self, "bad named parameter \"$_\" given ", 1241 "to " . ref($self) . "::open()"); 1242 } 1243 } 1244 } 1245 1246 ## If any args given, override corresponding instance data. 1247 local $s->{errormode} = $errmode 1248 if defined $errmode; 1249 1250 ## Get host and port. 1251 $host = $self->host; 1252 $port = $self->port; 1253 1254 ## Ensure we're already closed. 1255 $self->close; 1256 1257 ## Connect with or without a timeout. 1258 if (defined($timeout) and &_have_alarm) { # use a timeout 1259 ## Convert possible absolute timeout to relative timeout. 1260 if ($timeout >= $^T) { # it's an absolute time 1261 $timeout = $timeout - time; 1262 } 1263 1264 ## Ensure a valid timeout value for alarm. 1265 if ($timeout < 1) { 1266 $timeout = 1; 1267 } 1268 $timeout = int($timeout + 1.5); 1269 1270 ## Connect to server, timing out if it takes too long. 1271 eval { 1272 ## Turn on timer. 1273 local $SIG{"__DIE__"} = "DEFAULT"; 1274 local $SIG{ALRM} = sub { die "timed-out\n" }; 1275 alarm $timeout; 1276 1277 ## Lookup server's IP address. 1278 $ip_addr = inet_aton $host 1279 or die "unknown remote host: $host\n"; 1280 1281 ## Create a socket and attach the filehandle to it. 1282 socket $self, AF_INET, SOCK_STREAM, 0 1283 or die "problem creating socket: $!\n"; 1284 1285 ## Open connection to server. 1286 connect $self, sockaddr_in($port, $ip_addr) 1287 or die "problem connecting to \"$host\", port $port: $!\n"; 1288 }; 1289 alarm 0; 1290 1291 ## Check for error. 1292 if ($@ =~ /^timed-out$/) { # time out failure 1293 $s->{timedout} = 1; 1294 $self->close; 1295 if (!$ip_addr) { 1296 return $self->error("unknown remote host: $host: ", 1297 "name lookup timed-out"); 1298 } 1299 else { 1300 return $self->error("problem connecting to \"$host\", ", 1301 "port $port: connect timed-out"); 1302 } 1303 } 1304 elsif ($@) { # hostname lookup or connect failure 1305 $self->close; 1306 chomp $@; 1307 return $self->error($@); 1308 } 1309 } 1310 else { # don't use a timeout 1311 $timeout = undef; 1312 1313 ## Lookup server's IP address. 1314 $ip_addr = inet_aton $host 1315 or return $self->error("unknown remote host: $host"); 1316 1317 ## Create a socket and attach the filehandle to it. 1318 socket $self, AF_INET, SOCK_STREAM, 0 1319 or return $self->error("problem creating socket: $!"); 1320 1321 ## Open connection to server. 1322 connect $self, sockaddr_in($port, $ip_addr) 1323 or do { 1324 $errno = "$!"; 1325 $self->close; 1326 return $self->error("problem connecting to \"$host\", ", 1327 "port $port: $errno"); 1328 }; 1329 } 1330 1331 select((select($self), $|=1)[$[]); # don't buffer writes 1332 $s->{blksize} = &_optimal_blksize((stat $self)[11]); 1333 $s->{buf} = ""; 1334 $s->{eofile} = ''; 1335 $s->{errormsg} = ""; 1336 vec($s->{fdmask}='', fileno($self), 1) = 1; 1337 $s->{last_line} = ""; 1338 $s->{num_wrote} = 0; 1339 $s->{opened} = 1; 1340 $s->{pending_errormsg} = ""; 1341 $s->{pushback_buf} = ""; 1342 $s->{timedout} = ''; 1343 $s->{unsent_opts} = ""; 1344 &_reset_options($s->{opts}); 1345 1346 1; 1347} # end sub open 1348 1349 1350sub option_accept { 1351 my ($self, @args) = @_; 1352 my ( 1353 $arg, 1354 $option, 1355 $s, 1356 @opt_args, 1357 ); 1358 local $_; 1359 1360 ## Init. 1361 $s = *$self->{net_telnet}; 1362 1363 ## Parse the named args. 1364 while (($_, $arg) = splice @args, 0, 2) { 1365 ## Verify and save arguments. 1366 if (/^-?do$/i) { 1367 ## Make sure a callback is defined. 1368 return $self->error("usage: an option callback must already ", 1369 "be defined when enabling with $_") 1370 unless $s->{opt_cback}; 1371 1372 $option = &_verify_telopt_arg($self, $arg, $_); 1373 return unless defined $option; 1374 push @opt_args, { option => $option, 1375 is_remote => '', 1376 is_enable => 1, 1377 }; 1378 } 1379 elsif (/^-?dont$/i) { 1380 $option = &_verify_telopt_arg($self, $arg, $_); 1381 return unless defined $option; 1382 push @opt_args, { option => $option, 1383 is_remote => '', 1384 is_enable => '', 1385 }; 1386 } 1387 elsif (/^-?will$/i) { 1388 ## Make sure a callback is defined. 1389 return $self->error("usage: an option callback must already ", 1390 "be defined when enabling with $_") 1391 unless $s->{opt_cback}; 1392 1393 $option = &_verify_telopt_arg($self, $arg, $_); 1394 return unless defined $option; 1395 push @opt_args, { option => $option, 1396 is_remote => 1, 1397 is_enable => 1, 1398 }; 1399 } 1400 elsif (/^-?wont$/i) { 1401 $option = &_verify_telopt_arg($self, $arg, $_); 1402 return unless defined $option; 1403 push @opt_args, { option => $option, 1404 is_remote => 1, 1405 is_enable => '', 1406 }; 1407 } 1408 else { 1409 return $self->error('usage: $obj->option_accept(' . 1410 '[Do => $telopt,] ', 1411 '[Dont => $telopt,] ', 1412 '[Will => $telopt,] ', 1413 '[Wont => $telopt,]'); 1414 } 1415 } 1416 1417 ## Set "receive ok" for options specified. 1418 &_opt_accept($self, @opt_args); 1419} # end sub option_accept 1420 1421 1422sub option_callback { 1423 my ($self, $callback) = @_; 1424 my ( 1425 $prev, 1426 $s, 1427 ); 1428 1429 $s = *$self->{net_telnet}; 1430 $prev = $s->{opt_cback}; 1431 1432 if (@_ >= 2) { 1433 unless (defined $callback and ref($callback) eq "CODE") { 1434 &_carp($self, "ignoring Option_callback argument because it's " . 1435 "not a code ref"); 1436 $callback = $prev; 1437 } 1438 1439 $s->{opt_cback} = $callback; 1440 } 1441 1442 $prev; 1443} # end sub option_callback 1444 1445 1446sub option_log { 1447 my ($self, $name) = @_; 1448 my ( 1449 $fh, 1450 $s, 1451 ); 1452 1453 $s = *$self->{net_telnet}; 1454 $fh = $s->{opt_log}; 1455 1456 if (@_ >= 2) { 1457 unless (defined $name) { 1458 $name = ""; 1459 } 1460 1461 $fh = &_fname_to_handle($self, $name) 1462 or return; 1463 $s->{opt_log} = $fh; 1464 } 1465 1466 $fh; 1467} # end sub option_log 1468 1469 1470sub option_state { 1471 my ($self, $option) = @_; 1472 my ( 1473 $opt_state, 1474 $s, 1475 %opt_state, 1476 ); 1477 1478 ## Ensure telnet option is non-negative integer. 1479 $option = &_verify_telopt_arg($self, $option); 1480 return unless defined $option; 1481 1482 ## Init. 1483 $s = *$self->{net_telnet}; 1484 unless (defined $s->{opts}{$option}) { 1485 &_set_default_option($s, $option); 1486 } 1487 1488 ## Return hashref to a copy of the values. 1489 $opt_state = $s->{opts}{$option}; 1490 %opt_state = %$opt_state; 1491 \%opt_state; 1492} # end sub option_state 1493 1494 1495## Make ors() synonymous with output_record_separator(). 1496*ors = \&output_record_separator; 1497 1498 1499sub output_field_separator { 1500 my ($self, $ofs) = @_; 1501 my ( 1502 $prev, 1503 $s, 1504 ); 1505 1506 $s = *$self->{net_telnet}; 1507 $prev = $s->{ofs}; 1508 1509 if (@_ >= 2) { 1510 unless (defined $ofs) { 1511 $ofs = ""; 1512 } 1513 1514 $s->{ofs} = $ofs; 1515 } 1516 1517 $prev; 1518} # end sub output_field_separator 1519 1520 1521sub output_log { 1522 my ($self, $name) = @_; 1523 my ( 1524 $fh, 1525 $s, 1526 ); 1527 1528 $s = *$self->{net_telnet}; 1529 $fh = $s->{outputlog}; 1530 1531 if (@_ >= 2) { 1532 unless (defined $name) { 1533 $name = ""; 1534 } 1535 1536 $fh = &_fname_to_handle($self, $name) 1537 or return; 1538 $s->{outputlog} = $fh; 1539 } 1540 1541 $fh; 1542} # end sub output_log 1543 1544 1545sub output_record_separator { 1546 my ($self, $ors) = @_; 1547 my ( 1548 $prev, 1549 $s, 1550 ); 1551 1552 $s = *$self->{net_telnet}; 1553 $prev = $s->{ors}; 1554 1555 if (@_ >= 2) { 1556 unless (defined $ors) { 1557 $ors = ""; 1558 } 1559 1560 $s->{ors} = $ors; 1561 } 1562 1563 $prev; 1564} # end sub output_record_separator 1565 1566 1567sub port { 1568 my ($self, $port) = @_; 1569 my ( 1570 $prev, 1571 $s, 1572 $service, 1573 ); 1574 1575 $s = *$self->{net_telnet}; 1576 $prev = $s->{port}; 1577 1578 if (@_ >= 2) { 1579 unless (defined $port) { 1580 $port = ""; 1581 } 1582 1583 if (!$port) { 1584 &_carp($self, "ignoring bad Port argument \"$port\""); 1585 $port = $prev; 1586 } 1587 elsif ($port !~ /^\d+$/) { # port isn't all digits 1588 $service = $port; 1589 $port = getservbyname($service, "tcp"); 1590 unless ($port) { 1591 &_carp($self, "ignoring bad Port argument \"$service\": " . 1592 "it's an unknown TCP service"); 1593 $port = $prev; 1594 } 1595 } 1596 1597 $s->{port} = $port; 1598 } 1599 1600 $prev; 1601} # end sub port 1602 1603 1604sub print { 1605 my ($self) = shift; 1606 my ( 1607 $buf, 1608 $fh, 1609 $s, 1610 ); 1611 1612 $s = *$self->{net_telnet}; 1613 $s->{timedout} = ''; 1614 return $self->error("write error: filehandle isn't open") 1615 unless $s->{opened}; 1616 1617 ## Add field and record separators. 1618 $buf = join($s->{ofs}, @_) . $s->{ors}; 1619 1620 ## Log the output if requested. 1621 if ($s->{outputlog}) { 1622 &_log_print($s->{outputlog}, $buf); 1623 } 1624 1625 ## Convert native newlines to CR LF. 1626 if (!$s->{bin_mode}) { 1627 $buf =~ s(\n)(\015\012)g; 1628 } 1629 1630 ## Escape TELNET IAC and also CR not followed by LF. 1631 if ($s->{telnet_mode}) { 1632 $buf =~ s(\377)(\377\377)g; 1633 &_escape_cr(\$buf); 1634 } 1635 1636 &_put($self, \$buf, "print"); 1637} # end sub print 1638 1639 1640sub print_length { 1641 my ($self) = @_; 1642 1643 *$self->{net_telnet}{num_wrote}; 1644} # end sub print_length 1645 1646 1647sub prompt { 1648 my ($self, $prompt) = @_; 1649 my ( 1650 $prev, 1651 $s, 1652 ); 1653 1654 $s = *$self->{net_telnet}; 1655 $prev = $s->{cmd_prompt}; 1656 1657 ## Parse args. 1658 if (@_ == 2) { 1659 $s->{cmd_prompt} = &_parse_prompt($self, $prompt); 1660 } 1661 1662 $prev; 1663} # end sub prompt 1664 1665 1666sub put { 1667 my ($self) = @_; 1668 my ( 1669 $binmode, 1670 $buf, 1671 $errmode, 1672 $is_timeout_arg, 1673 $s, 1674 $telnetmode, 1675 $timeout, 1676 %args, 1677 ); 1678 local $_; 1679 1680 ## Init. 1681 $s = *$self->{net_telnet}; 1682 $s->{timedout} = ''; 1683 1684 ## Parse args. 1685 if (@_ == 2) { # one positional arg given 1686 $buf = $_[1]; 1687 } 1688 elsif (@_ > 2) { # named args given 1689 ## Get the named args. 1690 (undef, %args) = @_; 1691 1692 ## Parse the named args. 1693 foreach (keys %args) { 1694 if (/^-?binmode$/i) { 1695 $binmode = $args{$_}; 1696 unless (defined $binmode) { 1697 $binmode = 0; 1698 } 1699 } 1700 elsif (/^-?errmode$/i) { 1701 $errmode = &_parse_errmode($self, $args{$_}); 1702 } 1703 elsif (/^-?string$/i) { 1704 $buf = $args{$_}; 1705 } 1706 elsif (/^-?telnetmode$/i) { 1707 $telnetmode = $args{$_}; 1708 unless (defined $telnetmode) { 1709 $telnetmode = 0; 1710 } 1711 } 1712 elsif (/^-?timeout$/i) { 1713 $timeout = &_parse_timeout($self, $args{$_}); 1714 $is_timeout_arg = 1; 1715 } 1716 else { 1717 &_croak($self, "bad named parameter \"$_\" given ", 1718 "to " . ref($self) . "::put()"); 1719 } 1720 } 1721 } 1722 1723 ## If any args given, override corresponding instance data. 1724 local $s->{bin_mode} = $binmode 1725 if defined $binmode; 1726 local $s->{errormode} = $errmode 1727 if defined $errmode; 1728 local $s->{telnet_mode} = $telnetmode 1729 if defined $telnetmode; 1730 local $s->{time_out} = $timeout 1731 if defined $is_timeout_arg; 1732 1733 ## Check for errors. 1734 return $self->error("write error: filehandle isn't open") 1735 unless $s->{opened}; 1736 1737 ## Log the output if requested. 1738 if ($s->{outputlog}) { 1739 &_log_print($s->{outputlog}, $buf); 1740 } 1741 1742 ## Convert native newlines to CR LF. 1743 if (!$s->{bin_mode}) { 1744 $buf =~ s(\n)(\015\012)g; 1745 } 1746 1747 ## Escape TELNET IAC and also CR not followed by LF. 1748 if ($s->{telnet_mode}) { 1749 $buf =~ s(\377)(\377\377)g; 1750 &_escape_cr(\$buf); 1751 } 1752 1753 &_put($self, \$buf, "print"); 1754} # end sub put 1755 1756 1757## Make rs() synonymous input_record_separator(). 1758*rs = \&input_record_separator; 1759 1760 1761sub suboption_callback { 1762 my ($self, $callback) = @_; 1763 my ( 1764 $prev, 1765 $s, 1766 ); 1767 1768 $s = *$self->{net_telnet}; 1769 $prev = $s->{subopt_cback}; 1770 1771 if (@_ >= 2) { 1772 unless (defined $callback and ref($callback) eq "CODE") { 1773 &_carp($self,"ignoring Suboption_callback argument because it's " . 1774 "not a code ref"); 1775 $callback = $prev; 1776 } 1777 1778 $s->{subopt_cback} = $callback; 1779 } 1780 1781 $prev; 1782} # end sub suboption_callback 1783 1784 1785sub telnetmode { 1786 my ($self, $mode) = @_; 1787 my ( 1788 $prev, 1789 $s, 1790 ); 1791 1792 $s = *$self->{net_telnet}; 1793 $prev = $s->{telnet_mode}; 1794 1795 if (@_ >= 2) { 1796 unless (defined $mode) { 1797 $mode = 0; 1798 } 1799 1800 $s->{telnet_mode} = $mode; 1801 } 1802 1803 $prev; 1804} # end sub telnetmode 1805 1806 1807sub timed_out { 1808 my ($self, $value) = @_; 1809 my ( 1810 $prev, 1811 $s, 1812 ); 1813 1814 $s = *$self->{net_telnet}; 1815 $prev = $s->{timedout}; 1816 1817 if (@_ >= 2) { 1818 unless (defined $value) { 1819 $value = ""; 1820 } 1821 1822 $s->{timedout} = $value; 1823 } 1824 1825 $prev; 1826} # end sub timed_out 1827 1828 1829sub timeout { 1830 my ($self, $timeout) = @_; 1831 my ( 1832 $prev, 1833 $s, 1834 ); 1835 1836 $s = *$self->{net_telnet}; 1837 $prev = $s->{time_out}; 1838 1839 if (@_ >= 2) { 1840 $s->{time_out} = &_parse_timeout($self, $timeout); 1841 } 1842 1843 $prev; 1844} # end sub timeout 1845 1846 1847sub waitfor { 1848 my ($self, @args) = @_; 1849 my ( 1850 $arg, 1851 $binmode, 1852 $endtime, 1853 $errmode, 1854 $len, 1855 $match, 1856 $match_op, 1857 $pos, 1858 $prematch, 1859 $s, 1860 $search, 1861 $search_cond, 1862 $telnetmode, 1863 $timeout, 1864 @match_cond, 1865 @match_ops, 1866 @search_cond, 1867 @string_cond, 1868 @warns, 1869 ); 1870 local $_; 1871 1872 ## Init. 1873 $s = *$self->{net_telnet}; 1874 $s->{timedout} = ''; 1875 return if $s->{eofile}; 1876 return unless @args; 1877 $timeout = $s->{time_out}; 1878 1879 ## Code template used to build string match conditional. 1880 ## Values between array elements must be supplied later. 1881 @string_cond = 1882 ('if (($pos = index $s->{buf}, ', ') > -1) { 1883 $len = ', '; 1884 $prematch = substr $s->{buf}, 0, $pos; 1885 $match = substr $s->{buf}, $pos, $len; 1886 substr($s->{buf}, 0, $pos + $len) = ""; 1887 last; 1888 }'); 1889 1890 ## Code template used to build pattern match conditional. 1891 ## Values between array elements must be supplied later. 1892 @match_cond = 1893 ('if ($s->{buf} =~ ', ') { 1894 $prematch = $`; 1895 $match = $&; 1896 substr($s->{buf}, 0, length($`) + length($&)) = ""; 1897 last; 1898 }'); 1899 1900 ## Parse args. 1901 if (@_ == 2) { # one positional arg given 1902 $arg = $_[1]; 1903 1904 ## Fill in the blanks in the code template. 1905 push @match_ops, $arg; 1906 push @search_cond, join("", $match_cond[0], $arg, $match_cond[1]); 1907 } 1908 elsif (@_ > 2) { # named args given 1909 ## Parse the named args. 1910 while (($_, $arg) = splice @args, 0, 2) { 1911 if (/^-?binmode$/i) { 1912 $binmode = $arg; 1913 unless (defined $binmode) { 1914 $binmode = 0; 1915 } 1916 } 1917 elsif (/^-?errmode$/i) { 1918 $errmode = &_parse_errmode($self, $arg); 1919 } 1920 elsif (/^-?match$/i) { 1921 ## Fill in the blanks in the code template. 1922 push @match_ops, $arg; 1923 push @search_cond, join("", 1924 $match_cond[0], $arg, $match_cond[1]); 1925 } 1926 elsif (/^-?string$/i) { 1927 ## Fill in the blanks in the code template. 1928 $arg =~ s/'/\\'/g; # quote ticks 1929 push @search_cond, join("", 1930 $string_cond[0], "'$arg'", 1931 $string_cond[1], length($arg), 1932 $string_cond[2]); 1933 } 1934 elsif (/^-?telnetmode$/i) { 1935 $telnetmode = $arg; 1936 unless (defined $telnetmode) { 1937 $telnetmode = 0; 1938 } 1939 } 1940 elsif (/^-?timeout$/i) { 1941 $timeout = &_parse_timeout($self, $arg); 1942 } 1943 else { 1944 &_croak($self, "bad named parameter \"$_\" given " . 1945 "to " . ref($self) . "::waitfor()"); 1946 } 1947 } 1948 } 1949 1950 ## If any args given, override corresponding instance data. 1951 local $s->{errormode} = $errmode 1952 if defined $errmode; 1953 local $s->{bin_mode} = $binmode 1954 if defined $binmode; 1955 local $s->{telnet_mode} = $telnetmode 1956 if defined $telnetmode; 1957 1958 ## Check for bad match operator argument. 1959 foreach $match_op (@match_ops) { 1960 return $self->error("missing opening delimiter of match operator ", 1961 "in argument \"$match_op\" given to ", 1962 ref($self) . "::waitfor()") 1963 unless $match_op =~ m(^\s*/) or $match_op =~ m(^\s*m\s*\W); 1964 } 1965 1966 ## Construct conditional to check for requested string and pattern matches. 1967 ## Turn subsequent "if"s into "elsif". 1968 $search_cond = join "\n\tels", @search_cond; 1969 1970 ## Construct loop to fill buffer until string/pattern, timeout, or eof. 1971 $search = join "", " 1972 while (1) {\n\t", 1973 $search_cond, ' 1974 &_fillbuf($self, $s, $endtime) 1975 or do { 1976 last if $s->{timedout}; 1977 $self->close; 1978 last; 1979 }; 1980 }'; 1981 1982 ## Set wall time when we timeout. 1983 $endtime = &_endtime($timeout); 1984 1985 ## Run the loop. 1986 { 1987 local $^W = 1; 1988 local $SIG{"__WARN__"} = sub { push @warns, @_ }; 1989 local $s->{errormode} = "return"; 1990 $s->{errormsg} = ""; 1991 eval $search; 1992 } 1993 1994 ## Check for failure. 1995 return $self->error("pattern match timed-out") if $s->{timedout}; 1996 return $self->error($s->{errormsg}) if $s->{errormsg} ne ""; 1997 return $self->error("pattern match read eof") if $s->{eofile}; 1998 1999 ## Check for Perl syntax errors or warnings. 2000 if ($@ or @warns) { 2001 foreach $match_op (@match_ops) { 2002 &_match_check($self, $match_op) 2003 or return; 2004 } 2005 return $self->error($@) if $@; 2006 return $self->error(@warns) if @warns; 2007 } 2008 2009 wantarray ? ($prematch, $match) : 1; 2010} # end sub waitfor 2011 2012 2013######################## Private Subroutines ######################### 2014 2015 2016sub _append_lineno { 2017 my ($obj, @msgs) = @_; 2018 my ( 2019 $file, 2020 $line, 2021 $pkg, 2022 ); 2023 2024 ## Find the caller that's not in object's class or one of its base classes. 2025 ($pkg, $file , $line) = &_user_caller($obj); 2026 join("", @msgs, " at ", $file, " line ", $line, "\n"); 2027} # end sub _append_lineno 2028 2029 2030sub _carp { 2031 warn &_append_lineno(@_); 2032} # end sub _carp 2033 2034 2035sub _croak { 2036 die &_append_lineno(@_); 2037} # end sub _croak 2038 2039 2040sub _endtime { 2041 my ($interval) = @_; 2042 2043 ## Compute wall time when timeout occurs. 2044 if (defined $interval) { 2045 if ($interval >= $^T) { # it's already an absolute time 2046 return $interval; 2047 } 2048 elsif ($interval > 0) { # it's relative to the current time 2049 return int(time + 1.5 + $interval); 2050 } 2051 else { # it's a one time poll 2052 return 0; 2053 } 2054 } 2055 else { # there's no timeout 2056 return undef; 2057 } 2058} # end sub _endtime 2059 2060 2061sub _escape_cr { 2062 my ($string) = @_; 2063 my ( 2064 $nextchar, 2065 ); 2066 my $pos = 0; 2067 2068 ## Convert all CR (not followed by LF) to CR NULL. 2069 while (($pos = index($$string, "\015", $pos)) > -1) { 2070 $nextchar = substr $$string, $pos + 1, 1; 2071 2072 substr($$string, $pos, 1) = "\015\000" 2073 unless $nextchar eq "\012"; 2074 2075 $pos++; 2076 } 2077 2078 1; 2079} # end sub _escape_cr 2080 2081 2082sub _fillbuf { 2083 my ($self, $s, $endtime) = @_; 2084 my ( 2085 $msg, 2086 $nfound, 2087 $nread, 2088 $pushback_len, 2089 $read_pos, 2090 $ready, 2091 $timed_out, 2092 $timeout, 2093 $unparsed_pos, 2094 ); 2095 2096 ## If error from last read not yet reported then do it now. 2097 if ($s->{pending_errormsg}) { 2098 $msg = $s->{pending_errormsg}; 2099 $s->{pending_errormsg} = ""; 2100 return $self->error($msg); 2101 } 2102 2103 return unless $s->{opened}; 2104 2105 while (1) { 2106 ## Maximum buffer size exceeded? 2107 return $self->error("maximum input buffer length exceeded: ", 2108 $s->{maxbufsize}, " bytes") 2109 unless length($s->{buf}) <= $s->{maxbufsize}; 2110 2111 ## Determine how long to wait for input ready. 2112 ($timed_out, $timeout) = &_timeout_interval($endtime); 2113 if ($timed_out) { 2114 $s->{timedout} = 1; 2115 return $self->error("read timed-out"); 2116 } 2117 2118 ## Wait for input ready. 2119 $nfound = select $ready=$s->{fdmask}, "", "", $timeout; 2120 2121 ## Handle any errors while waiting. 2122 if (!defined $nfound or $nfound <= 0) { # input not ready 2123 if (defined $nfound and $nfound == 0) { # timed-out 2124 $s->{timedout} = 1; 2125 return $self->error("read timed-out"); 2126 } 2127 else { # error waiting for input ready 2128 next if $! =~ /^interrupted/i; 2129 2130 $s->{opened} = ''; 2131 return $self->error("read error: $!"); 2132 } 2133 } 2134 2135 ## Append to buffer any partially processed telnet or CR sequence. 2136 $pushback_len = length $s->{pushback_buf}; 2137 if ($pushback_len) { 2138 $s->{buf} .= $s->{pushback_buf}; 2139 $s->{pushback_buf} = ""; 2140 } 2141 2142 ## Read the waiting data. 2143 $read_pos = length $s->{buf}; 2144 $unparsed_pos = $read_pos - $pushback_len; 2145 $nread = sysread $self, $s->{buf}, $s->{blksize}, $read_pos; 2146 2147 ## Handle any read errors. 2148 if (!defined $nread) { # read failed 2149 next if $! =~ /^interrupted/i; # restart interrupted syscall 2150 2151 $s->{opened} = ''; 2152 return $self->error("read error: $!"); 2153 } 2154 2155 ## Handle eof. 2156 if ($nread == 0) { # eof read 2157 $s->{opened} = ''; 2158 return; 2159 } 2160 2161 ## Display network traffic if requested. 2162 if ($s->{dumplog}) { 2163 &_log_dump('<', $s->{dumplog}, \$s->{buf}, $read_pos); 2164 } 2165 2166 ## Process any telnet commands in the data stream. 2167 if ($s->{telnet_mode} and index($s->{buf},"\377",$unparsed_pos) > -1) { 2168 &_interpret_tcmd($self, $s, $unparsed_pos); 2169 } 2170 2171 ## Process any carriage-return sequences in the data stream. 2172 &_interpret_cr($s, $unparsed_pos); 2173 2174 ## Read again if all chars read were consumed as telnet cmds. 2175 next if $unparsed_pos >= length $s->{buf}; 2176 2177 ## Log the input if requested. 2178 if ($s->{inputlog}) { 2179 &_log_print($s->{inputlog}, substr($s->{buf}, $unparsed_pos)); 2180 } 2181 2182 ## Save the last line read. 2183 &_save_lastline($s); 2184 2185 ## We've successfully read some data into the buffer. 2186 last; 2187 } # end while(1) 2188 2189 1; 2190} # end sub _fillbuf 2191 2192 2193sub _flush_opts { 2194 my ($self) = @_; 2195 my ( 2196 $option_chars, 2197 ); 2198 my $s = *$self->{net_telnet}; 2199 2200 ## Get option and clear the output buf. 2201 $option_chars = $s->{unsent_opts}; 2202 $s->{unsent_opts} = ""; 2203 2204 ## Try to send options without waiting. 2205 { 2206 local $s->{errormode} = "return"; 2207 local $s->{time_out} = 0; 2208 &_put($self, \$option_chars, "telnet option negotiation") 2209 or do { 2210 ## Save chars not printed for later. 2211 substr($option_chars, 0, $self->print_length) = ""; 2212 $s->{unsent_opts} .= $option_chars; 2213 }; 2214 } 2215 2216 1; 2217} # end sub _flush_opts 2218 2219 2220sub _fname_to_handle { 2221 my ($self, $fh) = @_; 2222 my ( 2223 $filename, 2224 ); 2225 2226 ## Ensure valid input. 2227 return "" 2228 unless defined $fh and (ref $fh or length $fh); 2229 2230 ## Open a new filehandle if input is a filename. 2231 no strict "refs"; 2232 if (!ref($fh) and !defined(fileno $fh)) { # fh is a filename 2233 $filename = $fh; 2234 $fh = &_new_handle(); 2235 CORE::open $fh, "> $filename" 2236 or return $self->error("problem creating $filename: $!"); 2237 } 2238 2239 select((select($fh), $|=1)[$[]); # don't buffer writes 2240 $fh; 2241} # end sub _fname_to_handle 2242 2243 2244sub _have_alarm { 2245 eval { 2246 local $SIG{"__DIE__"} = "DEFAULT"; 2247 local $SIG{ALRM} = sub { die }; 2248 alarm 0; 2249 }; 2250 2251 ! $@; 2252} # end sub _have_alarm 2253 2254 2255sub _interpret_cr { 2256 my ($s, $pos) = @_; 2257 my ( 2258 $nextchar, 2259 ); 2260 2261 while (($pos = index($s->{buf}, "\015", $pos)) > -1) { 2262 $nextchar = substr($s->{buf}, $pos + 1, 1); 2263 if ($nextchar eq "\0") { 2264 ## Convert CR NULL to CR when in telnet mode. 2265 if ($s->{telnet_mode}) { 2266 substr($s->{buf}, $pos + 1, 1) = ""; 2267 } 2268 } 2269 elsif ($nextchar eq "\012") { 2270 ## Convert CR LF to newline when not in binary mode. 2271 if (!$s->{bin_mode}) { 2272 substr($s->{buf}, $pos, 2) = "\n"; 2273 } 2274 } 2275 elsif (!length($nextchar) and ($s->{telnet_mode} or !$s->{bin_mode})) { 2276 ## Save CR in alt buffer for possible CR LF or CR NULL conversion. 2277 $s->{pushback_buf} .= "\015"; 2278 chop $s->{buf}; 2279 } 2280 2281 $pos++; 2282 } 2283 2284 1; 2285} # end sub _interpret_cr 2286 2287 2288sub _interpret_tcmd { 2289 my ($self, $s, $offset) = @_; 2290 my ( 2291 $callback, 2292 $endpos, 2293 $nextchar, 2294 $option, 2295 $parameters, 2296 $pos, 2297 $subcmd, 2298 ); 2299 local $_; 2300 2301 ## Parse telnet commands in the data stream. 2302 $pos = $offset; 2303 while (($pos = index $s->{buf}, "\377", $pos) > -1) { # unprocessed IAC 2304 $nextchar = substr $s->{buf}, $pos + 1, 1; 2305 2306 ## Save command if it's only partially read. 2307 if (!length $nextchar) { 2308 $s->{pushback_buf} .= "\377"; 2309 chop $s->{buf}; 2310 last; 2311 } 2312 2313 if ($nextchar eq "\377") { # IAC is escaping "\377" char 2314 ## Remove escape char from data stream. 2315 substr($s->{buf}, $pos, 1) = ""; 2316 $pos++; 2317 } 2318 elsif ($nextchar eq "\375" or $nextchar eq "\373" or 2319 $nextchar eq "\374" or $nextchar eq "\376") { # opt negotiation 2320 $option = substr $s->{buf}, $pos + 2, 1; 2321 2322 ## Save command if it's only partially read. 2323 if (!length $option) { 2324 $s->{pushback_buf} .= "\377" . $nextchar; 2325 chop $s->{buf}; 2326 chop $s->{buf}; 2327 last; 2328 } 2329 2330 ## Remove command from data stream. 2331 substr($s->{buf}, $pos, 3) = ""; 2332 2333 ## Handle option negotiation. 2334 &_negotiate_recv($self, $s, $nextchar, ord($option), $pos); 2335 } 2336 elsif ($nextchar eq "\372") { # start of subnegotiation parameters 2337 ## Save command if it's only partially read. 2338 $endpos = index $s->{buf}, "\360", $pos; 2339 if ($endpos == -1) { 2340 $s->{pushback_buf} .= substr $s->{buf}, $pos; 2341 substr($s->{buf}, $pos) = ""; 2342 last; 2343 } 2344 2345 ## Remove subnegotiation cmd from buffer. 2346 $subcmd = substr($s->{buf}, $pos, $endpos - $pos + 1); 2347 substr($s->{buf}, $pos, $endpos - $pos + 1) = ""; 2348 2349 ## Invoke subnegotiation callback. 2350 if ($s->{subopt_cback} and length($subcmd) >= 5) { 2351 $option = unpack "C", substr($subcmd, 2, 1); 2352 if (length($subcmd) >= 6) { 2353 $parameters = substr $subcmd, 3, length($subcmd) - 5; 2354 } 2355 else { 2356 $parameters = ""; 2357 } 2358 2359 $callback = $s->{subopt_cback}; 2360 &$callback($self, $option, $parameters); 2361 } 2362 } 2363 else { # various two char telnet commands 2364 ## Ignore and remove command from data stream. 2365 substr($s->{buf}, $pos, 2) = ""; 2366 } 2367 } 2368 2369 ## Try to send any waiting option negotiation. 2370 if (length $s->{unsent_opts}) { 2371 &_flush_opts($self); 2372 } 2373 2374 1; 2375} # end sub _interpret_tcmd 2376 2377 2378sub _io_socket_include { 2379 local $SIG{"__DIE__"} = "DEFAULT"; 2380 eval "require IO::Socket"; 2381} # end sub io_socket_include 2382 2383 2384sub _log_dump { 2385 my ($direction, $fh, $data, $offset, $len) = @_; 2386 my ( 2387 $addr, 2388 $hexvals, 2389 $line, 2390 ); 2391 2392 $addr = 0; 2393 $len = length($$data) - $offset 2394 if !defined $len; 2395 return 1 if $len <= 0; 2396 2397 ## Print data in dump format. 2398 while ($len > 0) { 2399 ## Convert up to the next 16 chars to hex, padding w/ spaces. 2400 if ($len >= 16) { 2401 $line = substr $$data, $offset, 16; 2402 } 2403 else { 2404 $line = substr $$data, $offset, $len; 2405 } 2406 $hexvals = unpack("H*", $line); 2407 $hexvals .= ' ' x (32 - length $hexvals); 2408 2409 ## Place in 16 columns, each containing two hex digits. 2410 $hexvals = sprintf("%s %s %s %s " x 4, 2411 unpack("a2" x 16, $hexvals)); 2412 2413 ## For the ASCII column, change unprintable chars to a period. 2414 $line =~ s/[\000-\037,\177-\237]/./g; 2415 2416 ## Print the line in dump format. 2417 &_log_print($fh, sprintf("%s 0x%5.5lx: %s%s\n", 2418 $direction, $addr, $hexvals, $line)); 2419 2420 $addr += 16; 2421 $offset += 16; 2422 $len -= 16; 2423 } 2424 2425 &_log_print($fh, "\n"); 2426 2427 1; 2428} # end sub _log_dump 2429 2430 2431sub _log_option { 2432 my ($fh, $direction, $request, $option) = @_; 2433 my ( 2434 $name, 2435 ); 2436 2437 if ($option >= 0 and $option <= $#Telopts) { 2438 $name = $Telopts[$option]; 2439 } 2440 else { 2441 $name = $option; 2442 } 2443 2444 &_log_print($fh, "$direction $request $name\n"); 2445} # end sub _log_option 2446 2447 2448sub _log_print { 2449 my ($fh, $buf) = @_; 2450 local $\ = ''; 2451 2452 if (ref($fh) and ref($fh) ne "GLOB") { # fh is blessed ref 2453 $fh->print($buf); 2454 } 2455 else { # fh isn't blessed ref 2456 print $fh $buf; 2457 } 2458} # end sub _log_print 2459 2460 2461sub _match_check { 2462 my ($self, $code) = @_; 2463 my $error; 2464 my @warns = (); 2465 2466 ## Use eval to check for syntax errors or warnings. 2467 { 2468 local $SIG{"__DIE__"} = "DEFAULT"; 2469 local $SIG{"__WARN__"} = sub { push @warns, @_ }; 2470 local $^W = 1; 2471 local $_ = ''; 2472 eval "\$_ =~ $code;"; 2473 } 2474 if ($@) { 2475 ## Remove useless lines numbers from message. 2476 ($error = $@) =~ s/ at \(eval \d+\) line \d+.?//; 2477 chomp $error; 2478 return $self->error("bad match operator: $error"); 2479 } 2480 elsif (@warns) { 2481 ## Remove useless lines numbers from message. 2482 ($error = shift @warns) =~ s/ at \(eval \d+\) line \d+.?//; 2483 $error =~ s/ while "strict subs" in use//; 2484 chomp $error; 2485 return $self->error("bad match operator: $error"); 2486 } 2487 2488 1; 2489} # end sub _match_check 2490 2491 2492sub _negotiate_callback { 2493 my ($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos) = @_; 2494 my ( 2495 $callback, 2496 $s, 2497 ); 2498 local $_; 2499 2500 ## Keep track of remote echo. 2501 if ($is_remote and $opt == &TELOPT_ECHO) { # received WILL or WONT ECHO 2502 $s = *$self->{net_telnet}; 2503 2504 if ($is_enabled and !$was_enabled) { # received WILL ECHO 2505 $s->{remote_echo} = 1; 2506 } 2507 elsif (!$is_enabled and $was_enabled) { # received WONT ECHO 2508 $s->{remote_echo} = ''; 2509 } 2510 } 2511 2512 ## Invoke callback, if there is one. 2513 $callback = $self->option_callback; 2514 if ($callback) { 2515 &$callback($self, $opt, $is_remote, 2516 $is_enabled, $was_enabled, $opt_bufpos); 2517 } 2518 2519 1; 2520} # end sub _negotiate_callback 2521 2522 2523sub _negotiate_recv { 2524 my ($self, $s, $opt_request, $opt, $opt_bufpos) = @_; 2525 2526 ## Ensure data structure exists for this option. 2527 unless (defined $s->{opts}{$opt}) { 2528 &_set_default_option($s, $opt); 2529 } 2530 2531 ## Process the option. 2532 if ($opt_request eq "\376") { # DONT 2533 &_negotiate_recv_disable($self, $s, $opt, "dont", $opt_bufpos, 2534 $s->{opts}{$opt}{local_enable_ok}, 2535 \$s->{opts}{$opt}{local_enabled}, 2536 \$s->{opts}{$opt}{local_state}); 2537 } 2538 elsif ($opt_request eq "\375") { # DO 2539 &_negotiate_recv_enable($self, $s, $opt, "do", $opt_bufpos, 2540 $s->{opts}{$opt}{local_enable_ok}, 2541 \$s->{opts}{$opt}{local_enabled}, 2542 \$s->{opts}{$opt}{local_state}); 2543 } 2544 elsif ($opt_request eq "\374") { # WONT 2545 &_negotiate_recv_disable($self, $s, $opt, "wont", $opt_bufpos, 2546 $s->{opts}{$opt}{remote_enable_ok}, 2547 \$s->{opts}{$opt}{remote_enabled}, 2548 \$s->{opts}{$opt}{remote_state}); 2549 } 2550 elsif ($opt_request eq "\373") { # WILL 2551 &_negotiate_recv_enable($self, $s, $opt, "will", $opt_bufpos, 2552 $s->{opts}{$opt}{remote_enable_ok}, 2553 \$s->{opts}{$opt}{remote_enabled}, 2554 \$s->{opts}{$opt}{remote_state}); 2555 } 2556 else { # internal error 2557 die; 2558 } 2559 2560 1; 2561} # end sub _negotiate_recv 2562 2563 2564sub _negotiate_recv_disable { 2565 my ($self, $s, $opt, $opt_request, 2566 $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; 2567 my ( 2568 $ack, 2569 $disable_cmd, 2570 $enable_cmd, 2571 $is_remote, 2572 $nak, 2573 $was_enabled, 2574 ); 2575 2576 ## What do we use to request enable/disable or respond with ack/nak. 2577 if ($opt_request eq "wont") { 2578 $enable_cmd = "\377\375" . pack("C", $opt); # do command 2579 $disable_cmd = "\377\376" . pack("C", $opt); # dont command 2580 $is_remote = 1; 2581 $ack = "DO"; 2582 $nak = "DONT"; 2583 2584 &_log_option($s->{opt_log}, "RCVD", "WONT", $opt) 2585 if $s->{opt_log}; 2586 } 2587 elsif ($opt_request eq "dont") { 2588 $enable_cmd = "\377\373" . pack("C", $opt); # will command 2589 $disable_cmd = "\377\374" . pack("C", $opt); # wont command 2590 $is_remote = ''; 2591 $ack = "WILL"; 2592 $nak = "WONT"; 2593 2594 &_log_option($s->{opt_log}, "RCVD", "DONT", $opt) 2595 if $s->{opt_log}; 2596 } 2597 else { # internal error 2598 die; 2599 } 2600 2601 ## Respond to WONT or DONT based on the current negotiation state. 2602 if ($$state eq "no") { # state is already disabled 2603 } 2604 elsif ($$state eq "yes") { # they're initiating disable 2605 $$is_enabled = ''; 2606 $$state = "no"; 2607 2608 ## Send positive acknowledgment. 2609 $s->{unsent_opts} .= $disable_cmd; 2610 &_log_option($s->{opt_log}, "SENT", $nak, $opt) 2611 if $s->{opt_log}; 2612 2613 ## Invoke callbacks. 2614 &_negotiate_callback($self, $opt, $is_remote, 2615 $$is_enabled, $was_enabled, $opt_bufpos); 2616 } 2617 elsif ($$state eq "wantno") { # they sent positive ack 2618 $$is_enabled = ''; 2619 $$state = "no"; 2620 2621 ## Invoke callback. 2622 &_negotiate_callback($self, $opt, $is_remote, 2623 $$is_enabled, $was_enabled, $opt_bufpos); 2624 } 2625 elsif ($$state eq "wantno opposite") { # pos ack but we changed our mind 2626 ## Indicate disabled but now we want to enable. 2627 $$is_enabled = ''; 2628 $$state = "wantyes"; 2629 2630 ## Send queued request. 2631 $s->{unsent_opts} .= $enable_cmd; 2632 &_log_option($s->{opt_log}, "SENT", $ack, $opt) 2633 if $s->{opt_log}; 2634 2635 ## Invoke callback. 2636 &_negotiate_callback($self, $opt, $is_remote, 2637 $$is_enabled, $was_enabled, $opt_bufpos); 2638 } 2639 elsif ($$state eq "wantyes") { # they sent negative ack 2640 $$is_enabled = ''; 2641 $$state = "no"; 2642 2643 ## Invoke callback. 2644 &_negotiate_callback($self, $opt, $is_remote, 2645 $$is_enabled, $was_enabled, $opt_bufpos); 2646 } 2647 elsif ($$state eq "wantyes opposite") { # nak but we changed our mind 2648 $$is_enabled = ''; 2649 $$state = "no"; 2650 2651 ## Invoke callback. 2652 &_negotiate_callback($self, $opt, $is_remote, 2653 $$is_enabled, $was_enabled, $opt_bufpos); 2654 } 2655} # end sub _negotiate_recv_disable 2656 2657 2658sub _negotiate_recv_enable { 2659 my ($self, $s, $opt, $opt_request, 2660 $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; 2661 my ( 2662 $ack, 2663 $disable_cmd, 2664 $enable_cmd, 2665 $is_remote, 2666 $nak, 2667 $was_enabled, 2668 ); 2669 2670 ## What we use to send enable/disable request or send ack/nak response. 2671 if ($opt_request eq "will") { 2672 $enable_cmd = "\377\375" . pack("C", $opt); # do command 2673 $disable_cmd = "\377\376" . pack("C", $opt); # dont command 2674 $is_remote = 1; 2675 $ack = "DO"; 2676 $nak = "DONT"; 2677 2678 &_log_option($s->{opt_log}, "RCVD", "WILL", $opt) 2679 if $s->{opt_log}; 2680 } 2681 elsif ($opt_request eq "do") { 2682 $enable_cmd = "\377\373" . pack("C", $opt); # will command 2683 $disable_cmd = "\377\374" . pack("C", $opt); # wont command 2684 $is_remote = ''; 2685 $ack = "WILL"; 2686 $nak = "WONT"; 2687 2688 &_log_option($s->{opt_log}, "RCVD", "DO", $opt) 2689 if $s->{opt_log}; 2690 } 2691 else { # internal error 2692 die; 2693 } 2694 2695 ## Save current enabled state. 2696 $was_enabled = $$is_enabled; 2697 2698 ## Respond to WILL or DO based on the current negotiation state. 2699 if ($$state eq "no") { # they're initiating enable 2700 if ($enable_ok) { # we agree they/us should enable 2701 $$is_enabled = 1; 2702 $$state = "yes"; 2703 2704 ## Send positive acknowledgment. 2705 $s->{unsent_opts} .= $enable_cmd; 2706 &_log_option($s->{opt_log}, "SENT", $ack, $opt) 2707 if $s->{opt_log}; 2708 2709 ## Invoke callbacks. 2710 &_negotiate_callback($self, $opt, $is_remote, 2711 $$is_enabled, $was_enabled, $opt_bufpos); 2712 } 2713 else { # we disagree they/us should enable 2714 ## Send negative acknowledgment. 2715 $s->{unsent_opts} .= $disable_cmd; 2716 &_log_option($s->{opt_log}, "SENT", $nak, $opt) 2717 if $s->{opt_log}; 2718 } 2719 } 2720 elsif ($$state eq "yes") { # state is already enabled 2721 } 2722 elsif ($$state eq "wantno") { # error: our disable req answered by enable 2723 $$is_enabled = ''; 2724 $$state = "no"; 2725 2726 ## Invoke callbacks. 2727 &_negotiate_callback($self, $opt, $is_remote, 2728 $$is_enabled, $was_enabled, $opt_bufpos); 2729 } 2730 elsif ($$state eq "wantno opposite") { # err: disable req answerd by enable 2731 $$is_enabled = 1; 2732 $$state = "yes"; 2733 2734 ## Invoke callbacks. 2735 &_negotiate_callback($self, $opt, $is_remote, 2736 $$is_enabled, $was_enabled, $opt_bufpos); 2737 } 2738 elsif ($$state eq "wantyes") { # they sent pos ack 2739 $$is_enabled = 1; 2740 $$state = "yes"; 2741 2742 ## Invoke callback. 2743 &_negotiate_callback($self, $opt, $is_remote, 2744 $$is_enabled, $was_enabled, $opt_bufpos); 2745 } 2746 elsif ($$state eq "wantyes opposite") { # pos ack but we changed our mind 2747 ## Indicate enabled but now we want to disable. 2748 $$is_enabled = 1; 2749 $$state = "wantno"; 2750 2751 ## Inform other side we changed our mind. 2752 $s->{unsent_opts} .= $disable_cmd; 2753 &_log_option($s->{opt_log}, "SENT", $nak, $opt) 2754 if $s->{opt_log}; 2755 2756 ## Invoke callback. 2757 &_negotiate_callback($self, $opt, $is_remote, 2758 $$is_enabled, $was_enabled, $opt_bufpos); 2759 } 2760 2761 1; 2762} # end sub _negotiate_recv_enable 2763 2764 2765sub _new_handle { 2766 if ($INC{"IO/Handle.pm"}) { 2767 return IO::Handle->new; 2768 } 2769 else { 2770 require FileHandle; 2771 return FileHandle->new; 2772 } 2773} # end sub _new_handle 2774 2775 2776sub _next_getlines { 2777 my ($self, $s) = @_; 2778 my ( 2779 $len, 2780 $line, 2781 $pos, 2782 @lines, 2783 ); 2784 2785 ## Fill buffer and get first line. 2786 $line = $self->getline 2787 or return; 2788 push @lines, $line; 2789 2790 ## Extract subsequent lines from buffer. 2791 while (($pos = index($s->{buf}, $s->{rs})) != -1) { 2792 $len = $pos + length $s->{rs}; 2793 push @lines, substr($s->{buf}, 0, $len); 2794 substr($s->{buf}, 0, $len) = ""; 2795 } 2796 2797 @lines; 2798} # end sub _next_getlines 2799 2800 2801sub _opt_accept { 2802 my ($self, @args) = @_; 2803 my ( 2804 $arg, 2805 $option, 2806 $s, 2807 ); 2808 2809 ## Init. 2810 $s = *$self->{net_telnet}; 2811 2812 foreach $arg (@args) { 2813 ## Ensure data structure defined for this option. 2814 $option = $arg->{option}; 2815 if (!defined $s->{opts}{$option}) { 2816 &_set_default_option($s, $option); 2817 } 2818 2819 ## Save whether we'll accept or reject this option. 2820 if ($arg->{is_remote}) { 2821 $s->{opts}{$option}{remote_enable_ok} = $arg->{is_enable}; 2822 } 2823 else { 2824 $s->{opts}{$option}{local_enable_ok} = $arg->{is_enable}; 2825 } 2826 } 2827 2828 1; 2829} # end sub _opt_accept 2830 2831 2832sub _optimal_blksize { 2833 my ($blksize) = @_; 2834 local $^W = ''; # avoid non-numeric warning for ms-windows blksize of "" 2835 2836 ## Use default when block size is invalid. 2837 return 8192 2838 unless defined $blksize and $blksize >= 1 and $blksize <= 1_048_576; 2839 2840 $blksize; 2841} # end sub _optimal_blksize 2842 2843 2844sub _parse_cmd_remove_mode { 2845 my ($self, $mode) = @_; 2846 2847 if (!defined $mode) { 2848 $mode = 0; 2849 } 2850 elsif ($mode =~ /^\s*auto\s*$/i) { 2851 $mode = "auto"; 2852 } 2853 elsif ($mode !~ /^\d+$/) { 2854 &_carp($self, "ignoring bad Cmd_remove_mode " . 2855 "argument \"$mode\": it's not \"auto\" or a " . 2856 "non-negative integer"); 2857 $mode = *$self->{net_telnet}{cmd_rm_mode}; 2858 } 2859 2860 $mode; 2861} # end sub _parse_cmd_remove_mode 2862 2863 2864sub _parse_errmode { 2865 my ($self, $errmode) = @_; 2866 2867 ## Set the error mode. 2868 if (!defined $errmode) { 2869 &_carp($self, "ignoring undefined Errmode argument"); 2870 $errmode = *$self->{net_telnet}{errormode}; 2871 } 2872 elsif ($errmode =~ /^\s*return\s*$/i) { 2873 $errmode = "return"; 2874 } 2875 elsif ($errmode =~ /^\s*die\s*$/i) { 2876 $errmode = "die"; 2877 } 2878 elsif (ref($errmode) eq "CODE") { 2879 } 2880 elsif (ref($errmode) eq "ARRAY") { 2881 unless (ref($errmode->[0]) eq "CODE") { 2882 &_carp($self, "ignoring bad Errmode argument: " . 2883 "first list item isn't a code ref"); 2884 $errmode = *$self->{net_telnet}{errormode}; 2885 } 2886 } 2887 else { 2888 &_carp($self, "ignoring bad Errmode argument \"$errmode\""); 2889 $errmode = *$self->{net_telnet}{errormode}; 2890 } 2891 2892 $errmode; 2893} # end sub _parse_errmode 2894 2895 2896sub _parse_input_record_separator { 2897 my ($self, $rs) = @_; 2898 2899 unless (defined $rs and length $rs) { 2900 &_carp($self, "ignoring null Input_record_separator argument"); 2901 $rs = *$self->{net_telnet}{rs}; 2902 } 2903 2904 $rs; 2905} # end sub _parse_input_record_separator 2906 2907 2908sub _parse_prompt { 2909 my ($self, $prompt) = @_; 2910 2911 unless (defined $prompt) { 2912 $prompt = ""; 2913 } 2914 2915 unless ($prompt =~ m(^\s*/) or $prompt =~ m(^\s*m\s*\W)) { 2916 &_carp($self, "ignoring bad Prompt argument \"$prompt\": " . 2917 "missing opening delimiter of match operator"); 2918 $prompt = *$self->{net_telnet}{cmd_prompt}; 2919 } 2920 2921 $prompt; 2922} # end sub _parse_prompt 2923 2924 2925sub _parse_timeout { 2926 my ($self, $timeout) = @_; 2927 2928 ## Ensure valid timeout. 2929 if (defined $timeout) { 2930 ## Test for non-numeric or negative values. 2931 eval { 2932 local $SIG{"__DIE__"} = "DEFAULT"; 2933 local $SIG{"__WARN__"} = sub { die "non-numeric\n" }; 2934 local $^W = 1; 2935 $timeout *= 1; 2936 }; 2937 if ($@) { # timeout arg is non-numeric 2938 &_carp($self, 2939 "ignoring non-numeric Timeout argument \"$timeout\""); 2940 $timeout = *$self->{net_telnet}{time_out}; 2941 } 2942 elsif ($timeout < 0) { # timeout arg is negative 2943 &_carp($self, "ignoring negative Timeout argument \"$timeout\""); 2944 $timeout = *$self->{net_telnet}{time_out}; 2945 } 2946 } 2947 2948 $timeout; 2949} # end sub _parse_timeout 2950 2951 2952sub _put { 2953 my ($self, $buf, $subname) = @_; 2954 my ( 2955 $endtime, 2956 $len, 2957 $nfound, 2958 $nwrote, 2959 $offset, 2960 $ready, 2961 $s, 2962 $timed_out, 2963 $timeout, 2964 $zero_wrote_count, 2965 ); 2966 2967 ## Init. 2968 $s = *$self->{net_telnet}; 2969 $s->{num_wrote} = 0; 2970 $zero_wrote_count = 0; 2971 $offset = 0; 2972 $len = length $$buf; 2973 $endtime = &_endtime($s->{time_out}); 2974 2975 return $self->error("write error: filehandle isn't open") 2976 unless $s->{opened}; 2977 2978 ## Try to send any waiting option negotiation. 2979 if (length $s->{unsent_opts}) { 2980 &_flush_opts($self); 2981 } 2982 2983 ## Write until all data blocks written. 2984 while ($len) { 2985 ## Determine how long to wait for output ready. 2986 ($timed_out, $timeout) = &_timeout_interval($endtime); 2987 if ($timed_out) { 2988 $s->{timedout} = 1; 2989 return $self->error("$subname timed-out"); 2990 } 2991 2992 ## Wait for output ready. 2993 $nfound = select "", $ready=$s->{fdmask}, "", $timeout; 2994 2995 ## Handle any errors while waiting. 2996 if (!defined $nfound or $nfound <= 0) { # output not ready 2997 if (defined $nfound and $nfound == 0) { # timed-out 2998 $s->{timedout} = 1; 2999 return $self->error("$subname timed-out"); 3000 } 3001 else { # error waiting for output ready 3002 next if $! =~ /^interrupted/i; 3003 3004 $s->{opened} = ''; 3005 return $self->error("write error: $!"); 3006 } 3007 } 3008 3009 ## Write the data. 3010 $nwrote = syswrite $self, $$buf, $len, $offset; 3011 3012 ## Handle any write errors. 3013 if (!defined $nwrote) { # write failed 3014 next if $! =~ /^interrupted/i; # restart interrupted syscall 3015 3016 $s->{opened} = ''; 3017 return $self->error("write error: $!"); 3018 } 3019 elsif ($nwrote == 0) { # zero chars written 3020 ## Try ten more times to write the data. 3021 if ($zero_wrote_count++ <= 10) { 3022 &_sleep(0.01); 3023 next; 3024 } 3025 3026 $s->{opened} = ''; 3027 return $self->error("write error: zero length write: $!"); 3028 } 3029 3030 ## Display network traffic if requested. 3031 if ($s->{dumplog}) { 3032 &_log_dump('>', $s->{dumplog}, $buf, $offset, $nwrote); 3033 } 3034 3035 ## Increment. 3036 $s->{num_wrote} += $nwrote; 3037 $offset += $nwrote; 3038 $len -= $nwrote; 3039 } 3040 3041 1; 3042} # end sub _put 3043 3044 3045sub _qualify_fh { 3046 my ($obj, $name) = @_; 3047 my ( 3048 $user_class, 3049 ); 3050 local $_; 3051 3052 ## Get user's package name. 3053 ($user_class) = &_user_caller($obj); 3054 3055 ## Ensure name is qualified with a package name. 3056 $name = qualify($name, $user_class); 3057 3058 ## If it's not already, make it a typeglob ref. 3059 if (!ref $name) { 3060 no strict; 3061 local $^W = 0; 3062 3063 $name =~ s/^\*+//; 3064 $name = eval "\\*$name"; 3065 return unless ref $name; 3066 } 3067 3068 $name; 3069} # end sub _qualify_fh 3070 3071 3072sub _reset_options { 3073 my ($opts) = @_; 3074 my ( 3075 $opt, 3076 ); 3077 3078 foreach $opt (keys %$opts) { 3079 $opts->{$opt}{remote_enabled} = ''; 3080 $opts->{$opt}{remote_state} = "no"; 3081 $opts->{$opt}{local_enabled} = ''; 3082 $opts->{$opt}{local_state} = "no"; 3083 } 3084 3085 1; 3086} # end sub _reset_options 3087 3088 3089sub _save_lastline { 3090 my ($s) = @_; 3091 my ( 3092 $firstpos, 3093 $lastpos, 3094 $len_w_sep, 3095 $len_wo_sep, 3096 $offset, 3097 ); 3098 my $rs = "\n"; 3099 3100 if (($lastpos = rindex $s->{buf}, $rs) > -1) { # eol found 3101 while (1) { 3102 ## Find beginning of line. 3103 $firstpos = rindex $s->{buf}, $rs, $lastpos - 1; 3104 if ($firstpos == -1) { 3105 $offset = 0; 3106 } 3107 else { 3108 $offset = $firstpos + length $rs; 3109 } 3110 3111 ## Determine length of line with and without separator. 3112 $len_wo_sep = $lastpos - $offset; 3113 $len_w_sep = $len_wo_sep + length $rs; 3114 3115 ## Save line if it's not blank. 3116 if (substr($s->{buf}, $offset, $len_wo_sep) 3117 !~ /^\s*$/) 3118 { 3119 $s->{last_line} = substr($s->{buf}, 3120 $offset, 3121 $len_w_sep); 3122 last; 3123 } 3124 3125 last if $firstpos == -1; 3126 3127 $lastpos = $firstpos; 3128 } 3129 } 3130 3131 1; 3132} # end sub _save_lastline 3133 3134 3135sub _set_default_option { 3136 my ($s, $option) = @_; 3137 3138 $s->{opts}{$option} = { 3139 remote_enabled => '', 3140 remote_state => "no", 3141 remote_enable_ok => '', 3142 local_enabled => '', 3143 local_state => "no", 3144 local_enable_ok => '', 3145 }; 3146} # end sub _set_default_option 3147 3148 3149sub _sleep { 3150 my ($secs) = @_; 3151 my $bitmask = ""; 3152 local *SOCK; 3153 3154 socket SOCK, AF_INET, SOCK_STREAM, 0; 3155 vec($bitmask, fileno(SOCK), 1) = 1; 3156 select $bitmask, "", "", $secs; 3157 CORE::close SOCK; 3158 3159 1; 3160} # end sub _sleep 3161 3162 3163sub _timeout_interval { 3164 my ($endtime) = @_; 3165 my ( 3166 $timeout, 3167 ); 3168 3169 ## Return timed-out boolean and timeout interval. 3170 if (defined $endtime) { 3171 ## Is it a one-time poll. 3172 return ('', 0) if $endtime == 0; 3173 3174 ## Calculate the timeout interval. 3175 $timeout = $endtime - time; 3176 3177 ## Did we already timeout. 3178 return (1, 0) unless $timeout > 0; 3179 3180 return ('', $timeout); 3181 } 3182 else { # there is no timeout 3183 return ('', undef); 3184 } 3185} # end sub _timeout_interval 3186 3187 3188sub _user_caller { 3189 my ($obj) = @_; 3190 my ( 3191 $class, 3192 $curr_pkg, 3193 $file, 3194 $i, 3195 $line, 3196 $pkg, 3197 %isa, 3198 @isa, 3199 ); 3200 local $_; 3201 3202 ## Create a boolean hash to test for isa. Make sure current 3203 ## package and the object's class are members. 3204 $class = ref $obj; 3205 @isa = eval "\@${class}::ISA"; 3206 push @isa, $class; 3207 ($curr_pkg) = caller 1; 3208 push @isa, $curr_pkg; 3209 %isa = map { $_ => 1 } @isa; 3210 3211 ## Search back in call frames for a package that's not in isa. 3212 $i = 1; 3213 while (($pkg, $file, $line) = caller ++$i) { 3214 next if $isa{$pkg}; 3215 3216 return ($pkg, $file, $line); 3217 } 3218 3219 ## If not found, choose outer most call frame. 3220 ($pkg, $file, $line) = caller --$i; 3221 return ($pkg, $file, $line); 3222} # end sub _user_caller 3223 3224 3225sub _verify_telopt_arg { 3226 my ($self, $option, $argname) = @_; 3227 3228 ## If provided, use argument name in error message. 3229 if (defined $argname) { 3230 $argname = "for arg $argname"; 3231 } 3232 else { 3233 $argname = ""; 3234 } 3235 3236 ## Ensure telnet option is a non-negative integer. 3237 eval { 3238 local $SIG{"__DIE__"} = "DEFAULT"; 3239 local $SIG{"__WARN__"} = sub { die "non-numeric\n" }; 3240 local $^W = 1; 3241 $option = abs(int $option); 3242 }; 3243 return $self->error("bad telnet option $argname: non-numeric") 3244 if $@; 3245 3246 return $self->error("bad telnet option $argname: option > 255") 3247 unless $option <= 255; 3248 3249 $option; 3250} # end sub _verify_telopt_arg 3251 3252 3253######################## Exported Constants ########################## 3254 3255 3256sub TELNET_IAC () {255}; # interpret as command: 3257sub TELNET_DONT () {254}; # you are not to use option 3258sub TELNET_DO () {253}; # please, you use option 3259sub TELNET_WONT () {252}; # I won't use option 3260sub TELNET_WILL () {251}; # I will use option 3261sub TELNET_SB () {250}; # interpret as subnegotiation 3262sub TELNET_GA () {249}; # you may reverse the line 3263sub TELNET_EL () {248}; # erase the current line 3264sub TELNET_EC () {247}; # erase the current character 3265sub TELNET_AYT () {246}; # are you there 3266sub TELNET_AO () {245}; # abort output--but let prog finish 3267sub TELNET_IP () {244}; # interrupt process--permanently 3268sub TELNET_BREAK () {243}; # break 3269sub TELNET_DM () {242}; # data mark--for connect. cleaning 3270sub TELNET_NOP () {241}; # nop 3271sub TELNET_SE () {240}; # end sub negotiation 3272sub TELNET_EOR () {239}; # end of record (transparent mode) 3273sub TELNET_ABORT () {238}; # Abort process 3274sub TELNET_SUSP () {237}; # Suspend process 3275sub TELNET_EOF () {236}; # End of file 3276sub TELNET_SYNCH () {242}; # for telfunc calls 3277 3278sub TELOPT_BINARY () {0}; # Binary Transmission 3279sub TELOPT_ECHO () {1}; # Echo 3280sub TELOPT_RCP () {2}; # Reconnection 3281sub TELOPT_SGA () {3}; # Suppress Go Ahead 3282sub TELOPT_NAMS () {4}; # Approx Message Size Negotiation 3283sub TELOPT_STATUS () {5}; # Status 3284sub TELOPT_TM () {6}; # Timing Mark 3285sub TELOPT_RCTE () {7}; # Remote Controlled Trans and Echo 3286sub TELOPT_NAOL () {8}; # Output Line Width 3287sub TELOPT_NAOP () {9}; # Output Page Size 3288sub TELOPT_NAOCRD () {10}; # Output Carriage-Return Disposition 3289sub TELOPT_NAOHTS () {11}; # Output Horizontal Tab Stops 3290sub TELOPT_NAOHTD () {12}; # Output Horizontal Tab Disposition 3291sub TELOPT_NAOFFD () {13}; # Output Formfeed Disposition 3292sub TELOPT_NAOVTS () {14}; # Output Vertical Tabstops 3293sub TELOPT_NAOVTD () {15}; # Output Vertical Tab Disposition 3294sub TELOPT_NAOLFD () {16}; # Output Linefeed Disposition 3295sub TELOPT_XASCII () {17}; # Extended ASCII 3296sub TELOPT_LOGOUT () {18}; # Logout 3297sub TELOPT_BM () {19}; # Byte Macro 3298sub TELOPT_DET () {20}; # Data Entry Terminal 3299sub TELOPT_SUPDUP () {21}; # SUPDUP 3300sub TELOPT_SUPDUPOUTPUT () {22}; # SUPDUP Output 3301sub TELOPT_SNDLOC () {23}; # Send Location 3302sub TELOPT_TTYPE () {24}; # Terminal Type 3303sub TELOPT_EOR () {25}; # End of Record 3304sub TELOPT_TUID () {26}; # TACACS User Identification 3305sub TELOPT_OUTMRK () {27}; # Output Marking 3306sub TELOPT_TTYLOC () {28}; # Terminal Location Number 3307sub TELOPT_3270REGIME () {29}; # Telnet 3270 Regime 3308sub TELOPT_X3PAD () {30}; # X.3 PAD 3309sub TELOPT_NAWS () {31}; # Negotiate About Window Size 3310sub TELOPT_TSPEED () {32}; # Terminal Speed 3311sub TELOPT_LFLOW () {33}; # Remote Flow Control 3312sub TELOPT_LINEMODE () {34}; # Linemode 3313sub TELOPT_XDISPLOC () {35}; # X Display Location 3314sub TELOPT_OLD_ENVIRON () {36}; # Environment Option 3315sub TELOPT_AUTHENTICATION () {37}; # Authentication Option 3316sub TELOPT_ENCRYPT () {38}; # Encryption Option 3317sub TELOPT_NEW_ENVIRON () {39}; # New Environment Option 3318sub TELOPT_EXOPL () {255}; # Extended-Options-List 3319 3320 33211; 3322__END__; 3323 3324 3325######################## User Documentation ########################## 3326 3327 3328## To format the following documentation into a more readable format, 3329## use one of these programs: perldoc; pod2man; pod2html; pod2text. 3330## For example, to nicely format this documentation for printing, you 3331## may use pod2man and groff to convert to postscript: 3332## pod2man Net/Telnet.pm | groff -man -Tps > Net::Telnet.ps 3333 3334=head1 NAME 3335 3336Net::Telnet - interact with TELNET port or other TCP ports 3337 3338=head1 SYNOPSIS 3339 3340C<use Net::Telnet ();> 3341 3342see METHODS section below 3343 3344=head1 DESCRIPTION 3345 3346Net::Telnet allows you to make client connections to a TCP port and do 3347network I/O, especially to a port using the TELNET protocol. Simple 3348I/O methods such as print, get, and getline are provided. More 3349sophisticated interactive features are provided because connecting to 3350a TELNET port ultimately means communicating with a program designed 3351for human interaction. These interactive features include the ability 3352to specify a time-out and to wait for patterns to appear in the input 3353stream, such as the prompt from a shell. 3354 3355Other reasons to use this module than strictly with a TELNET port are: 3356 3357=over 2 3358 3359=item * 3360 3361You're not familiar with sockets and you want a simple way to make 3362client connections to TCP services. 3363 3364=item * 3365 3366You want to be able to specify your own time-out while connecting, 3367reading, or writing. 3368 3369=item * 3370 3371You're communicating with an interactive program at the other end of 3372some socket or pipe and you want to wait for certain patterns to 3373appear. 3374 3375=back 3376 3377Here's an example that prints who's logged-on to the remote host 3378sparky. In addition to a username and password, you must also know 3379the user's shell prompt, which for this example is C<bash$> 3380 3381 use Net::Telnet (); 3382 $t = new Net::Telnet (Timeout => 10, 3383 Prompt => '/bash\$ $/'); 3384 $t->open("sparky"); 3385 $t->login($username, $passwd); 3386 @lines = $t->cmd("who"); 3387 print @lines; 3388 3389More examples are in the B<EXAMPLES> section below. 3390 3391Usage questions should be directed to the Usenet newsgroup 3392comp.lang.perl.modules. 3393 3394Contact me, Jay Rogers <jay@rgrs.com>, if you find any bugs or have 3395suggestions for improvement. 3396 3397=head2 What To Know Before Using 3398 3399=over 2 3400 3401=item * 3402 3403All output is flushed while all input is buffered. Each object 3404contains its own input buffer. 3405 3406=item * 3407 3408The output record separator for C<print()> and C<cmd()> is set to 3409C<"\n"> by default, so that you don't have to append all your commands 3410with a newline. To avoid printing a trailing C<"\n"> use C<put()> or 3411set the I<output_record_separator> to C<"">. 3412 3413=item * 3414 3415The methods C<login()> and C<cmd()> use the I<prompt> setting in the 3416object to determine when a login or remote command is complete. Those 3417methods will fail with a time-out if you don't set the prompt 3418correctly. 3419 3420=item * 3421 3422Use a combination of C<print()> and C<waitfor()> as an alternative to 3423C<login()> or C<cmd()> when they don't do what you want. 3424 3425=item * 3426 3427Errors such as timing-out are handled according to the error mode 3428action. The default action is to print an error message to standard 3429error and have the program die. See the C<errmode()> method for more 3430information. 3431 3432=item * 3433 3434When constructing the match operator argument for C<prompt()> or 3435C<waitfor()>, always use single quotes instead of double quotes to 3436avoid unexpected backslash interpretation (e.g. C<'/bash\$ $/'>). If 3437you're constructing a DOS like file path, you'll need to use four 3438backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>). 3439 3440Of course don't forget about regexp metacharacters like C<.>, C<[>, or 3441C<$>. You'll only need a single backslash to quote them. The anchor 3442metacharacters C<^> and C<$> refer to positions in the input buffer. 3443To avoid matching characters read that look like a prompt, it's a good 3444idea to end your prompt pattern with the C<$> anchor. That way the 3445prompt will only match if it's the last thing read. 3446 3447=item * 3448 3449In the input stream, each sequence of I<carriage return> and I<line 3450feed> (i.e. C<"\015\012"> or CR LF) is converted to C<"\n">. In the 3451output stream, each occurrence of C<"\n"> is converted to a sequence 3452of CR LF. See C<binmode()> to change the behavior. TCP protocols 3453typically use the ASCII sequence, carriage return and line feed to 3454designate a newline. 3455 3456=item * 3457 3458Timing-out while making a connection is disabled for machines that 3459don't support the C<alarm()> function. Most notably these include 3460MS-Windows machines. 3461 3462=item * 3463 3464You'll need to be running at least Perl version 5.002 to use this 3465module. This module does not require any libraries that don't already 3466come with a standard Perl distribution. 3467 3468If you have the IO:: libraries installed (they come standard with 3469perl5.004 and later) then IO::Socket::INET is used as a base class, 3470otherwise FileHandle is used. 3471 3472=item * 3473 3474Contact me, Jay Rogers <jay@rgrs.com>, if you find any bugs or have 3475suggestions for improvement. 3476 3477=back 3478 3479=head2 Debugging 3480 3481The typical usage bug causes a time-out error because you've made 3482incorrect assumptions about what the remote side actually sends. The 3483easiest way to reconcile what the remote side sends with your 3484expectations is to use C<input_log()> or C<dump_log()>. 3485 3486C<dump_log()> allows you to see the data being sent from the remote 3487side before any translation is done, while C<input_log()> shows you 3488the results after translation. The translation includes converting 3489end of line characters, removing and responding to TELNET protocol 3490commands in the data stream. 3491 3492=head2 Style of Named Parameters 3493 3494Two different styles of named parameters are supported. This document 3495only shows the IO:: style: 3496 3497 Net::Telnet->new(Timeout => 20); 3498 3499however the dash-option style is also allowed: 3500 3501 Net::Telnet->new(-timeout => 20); 3502 3503=head2 Connecting to a Remote MS-Windows Machine 3504 3505By default MS-Windows doesn't come with a TELNET server. However 3506third party TELNET servers are available. Unfortunately many of these 3507servers falsely claim to be a TELNET server. This is especially true 3508of the so-called "Microsoft Telnet Server" that comes installed with 3509some newer versions MS-Windows. 3510 3511When a TELNET server first accepts a connection, it must use the ASCII 3512control characters carriage-return and line-feed to start a new line 3513(see RFC854). A server like the "Microsoft Telnet Server" that 3514doesn't do this, isn't a TELNET server. These servers send ANSI 3515terminal escape sequences to position to a column on a subsequent line 3516and to even position while writing characters that are adjacent to 3517each other. Worse, when sending output these servers resend 3518previously sent command output in a misguided attempt to display an 3519entire terminal screen. 3520 3521Connecting Net::Telnet to one of these false TELNET servers makes your 3522job of parsing command output very difficult. It's better to replace 3523a false TELNET server with a real TELNET server. The better TELNET 3524servers for MS-Windows allow you to avoid the ANSI escapes by turning 3525off something some of them call I<console mode>. 3526 3527 3528=head1 METHODS 3529 3530In the calling sequences below, square brackets B<[]> represent 3531optional parameters. 3532 3533=over 4 3534 3535=item B<new> - create a new Net::Telnet object 3536 3537 $obj = new Net::Telnet ([$host]); 3538 3539 $obj = new Net::Telnet ([Binmode => $mode,] 3540 [Cmd_remove_mode => $mode,] 3541 [Dump_Log => $filename,] 3542 [Errmode => $errmode,] 3543 [Fhopen => $filehandle,] 3544 [Host => $host,] 3545 [Input_log => $file,] 3546 [Input_record_separator => $chars,] 3547 [Option_log => $file,] 3548 [Ors => $chars,] 3549 [Output_log => $file,] 3550 [Output_record_separator => $chars,] 3551 [Port => $port,] 3552 [Prompt => $matchop,] 3553 [Rs => $chars,] 3554 [Telnetmode => $mode,] 3555 [Timeout => $secs,]); 3556 3557This is the constructor for Net::Telnet objects. A new object is 3558returned on success, the error mode action is performed on failure - 3559see C<errmode()>. The optional arguments are short-cuts to methods of 3560the same name. 3561 3562If the I<$host> argument is given then the object is opened by 3563connecting to TCP I<$port> on I<$host>. Also see C<open()>. The new 3564object returned is given the following defaults in the absence of 3565corresponding named parameters: 3566 3567=over 4 3568 3569=item 3570 3571The default I<Host> is C<"localhost"> 3572 3573=item 3574 3575The default I<Port> is C<23> 3576 3577=item 3578 3579The default I<Prompt> is C<'/[\$%#E<gt>] $/'> 3580 3581=item 3582 3583The default I<Timeout> is C<10> 3584 3585=item 3586 3587The default I<Errmode> is C<"die"> 3588 3589=item 3590 3591The default I<Output_record_separator> is C<"\n">. Note that I<Ors> 3592is synonymous with I<Output_record_separator>. 3593 3594=item 3595 3596The default I<Input_record_separator> is C<"\n">. Note that I<Rs> is 3597synonymous with I<Input_record_separator>. 3598 3599=item 3600 3601The default I<Binmode> is C<0>, which means do newline translation. 3602 3603=item 3604 3605The default I<Telnetmode> is C<1>, which means respond to TELNET 3606commands in the data stream. 3607 3608=item 3609 3610The default I<Cmd_remove_mode> is C<"auto"> 3611 3612=item 3613 3614The defaults for I<Dump_log>, I<Input_log>, I<Option_log>, and 3615I<Output_log> are C<"">, which means that logging is turned-off. 3616 3617=back 3618 3619=back 3620 3621 3622=over 4 3623 3624=item B<binmode> - toggle newline translation 3625 3626 $mode = $obj->binmode; 3627 3628 $prev = $obj->binmode($mode); 3629 3630This method controls whether or not sequences of carriage returns and 3631line feeds (CR LF or more specifically C<"\015\012">) are translated. 3632By default they are translated (i.e. binmode is C<0>). 3633 3634If no argument is given, the current mode is returned. 3635 3636If I<$mode> is C<1> then binmode is I<on> and newline translation is 3637not done. 3638 3639If I<$mode> is C<0> then binmode is I<off> and newline translation is 3640done. In the input stream, each sequence of CR LF is converted to 3641C<"\n"> and in the output stream, each occurrence of C<"\n"> is 3642converted to a sequence of CR LF. 3643 3644Note that input is always buffered. Changing binmode doesn't effect 3645what's already been read into the buffer. Output is not buffered and 3646changing binmode will have an immediate effect. 3647 3648=back 3649 3650 3651=over 4 3652 3653=item B<break> - send TELNET break character 3654 3655 $ok = $obj->break; 3656 3657This method sends the TELNET break character. This character is 3658provided because it's a signal outside the ASCII character set which 3659is currently given local meaning within many systems. It's intended 3660to indicate that the Break Key or the Attention Key was hit. 3661 3662This method returns C<1> on success, or performs the error mode action 3663on failure. 3664 3665=back 3666 3667 3668=over 4 3669 3670=item B<buffer> - scalar reference to object's input buffer 3671 3672 $ref = $obj->buffer; 3673 3674This method returns a scalar reference to the input buffer for 3675I<$obj>. Data in the input buffer is data that has been read from the 3676remote side but has yet to be read by the user. Modifications to the 3677input buffer are returned by a subsequent read. 3678 3679=back 3680 3681 3682=over 4 3683 3684=item B<buffer_empty> - discard all data in object's input buffer 3685 3686 $obj->buffer_empty; 3687 3688This method removes all data in the input buffer for I<$obj>. 3689 3690=back 3691 3692 3693=over 4 3694 3695=item B<close> - close object 3696 3697 $ok = $obj->close; 3698 3699This method closes the socket, file, or pipe associated with the 3700object. It always returns a value of C<1>. 3701 3702=back 3703 3704 3705=over 4 3706 3707=item B<cmd> - issue command and retrieve output 3708 3709 $ok = $obj->cmd($string); 3710 $ok = $obj->cmd(String => $string, 3711 [Output => $ref,] 3712 [Cmd_remove_mode => $mode,] 3713 [Errmode => $mode,] 3714 [Input_record_separator => $chars,] 3715 [Ors => $chars,] 3716 [Output_record_separator => $chars,] 3717 [Prompt => $match,] 3718 [Rs => $chars,] 3719 [Timeout => $secs,]); 3720 3721 @output = $obj->cmd($string); 3722 @output = $obj->cmd(String => $string, 3723 [Output => $ref,] 3724 [Cmd_remove_mode => $mode,] 3725 [Errmode => $mode,] 3726 [Input_record_separator => $chars,] 3727 [Ors => $chars,] 3728 [Output_record_separator => $chars,] 3729 [Prompt => $match,] 3730 [Rs => $chars,] 3731 [Timeout => $secs,]); 3732 3733This method sends the command I<$string>, and reads the characters 3734sent back by the command up until and including the matching prompt. 3735It's assumed that the program to which you're sending is some kind of 3736command prompting interpreter such as a shell. 3737 3738The command I<$string> is automatically appended with the 3739output_record_separator, By default that's C<"\n">. This is similar 3740to someone typing a command and hitting the return key. Set the 3741output_record_separator to change this behavior. 3742 3743In a scalar context, the characters read from the remote side are 3744discarded and C<1> is returned on success. On time-out, eof, or other 3745failures, the error mode action is performed. See C<errmode()>. 3746 3747In a list context, just the output generated by the command is 3748returned, one line per element. In other words, all the characters in 3749between the echoed back command string and the prompt are returned. 3750If the command happens to return no output, a list containing one 3751element, the empty string is returned. This is so the list will 3752indicate true in a boolean context. On time-out, eof, or other 3753failures, the error mode action is performed. See C<errmode()>. 3754 3755The characters that matched the prompt may be retrieved using 3756C<last_prompt()>. 3757 3758Many command interpreters echo back the command sent. In most 3759situations, this method removes the first line returned from the 3760remote side (i.e. the echoed back command). See C<cmd_remove_mode()> 3761for more control over this feature. 3762 3763Use C<dump_log()> to debug when this method keeps timing-out and you 3764don't think it should. 3765 3766Consider using a combination of C<print()> and C<waitfor()> as an 3767alternative to this method when it doesn't do what you want, e.g. the 3768command you send prompts for input. 3769 3770The I<Output> named parameter provides an alternative method of 3771receiving command output. If you pass a scalar reference, all the 3772output (even if it contains multiple lines) is returned in the 3773referenced scalar. If you pass an array or hash reference, the lines 3774of output are returned in the referenced array or hash. You can use 3775C<input_record_separator()> to change the notion of what separates a 3776line. 3777 3778Optional named parameters are provided to override the current 3779settings of cmd_remove_mode, errmode, input_record_separator, ors, 3780output_record_separator, prompt, rs, and timeout. Rs is synonymous 3781with input_record_separator and ors is synonymous with 3782output_record_separator. 3783 3784=back 3785 3786 3787=over 4 3788 3789=item B<cmd_remove_mode> - toggle removal of echoed commands 3790 3791 $mode = $obj->cmd_remove_mode; 3792 3793 $prev = $obj->cmd_remove_mode($mode); 3794 3795This method controls how to deal with echoed back commands in the 3796output returned by cmd(). Typically, when you send a command to the 3797remote side, the first line of output returned is the command echoed 3798back. Use this mode to remove the first line of output normally 3799returned by cmd(). 3800 3801If no argument is given, the current mode is returned. 3802 3803If I<$mode> is C<0> then the command output returned from cmd() has no 3804lines removed. If I<$mode> is a positive integer, then the first 3805I<$mode> lines of command output are stripped. 3806 3807By default, I<$mode> is set to C<"auto">. Auto means that whether or 3808not the first line of command output is stripped, depends on whether 3809or not the remote side offered to echo. By default, Net::Telnet 3810always accepts an offer to echo by the remote side. You can change 3811the default to reject such an offer using C<option_accept()>. 3812 3813A warning is printed to STDERR when attempting to set this attribute 3814to something that's not C<"auto"> or a non-negative integer. 3815 3816=back 3817 3818 3819=over 4 3820 3821=item B<dump_log> - log all I/O in dump format 3822 3823 $fh = $obj->dump_log; 3824 3825 $fh = $obj->dump_log($fh); 3826 3827 $fh = $obj->dump_log($filename); 3828 3829This method starts or stops dump format logging of all the object's 3830input and output. The dump format shows the blocks read and written 3831in a hexadecimal and printable character format. This method is 3832useful when debugging, however you might want to first try 3833C<input_log()> as it's more readable. 3834 3835If no argument is given, the current log filehandle is returned. An 3836empty string indicates logging is off. 3837 3838To stop logging, use an empty string as an argument. 3839 3840If an open filehandle is given, it is used for logging and returned. 3841Otherwise, the argument is assumed to be the name of a file, the file 3842is opened and a filehandle to it is returned. If the file can't be 3843opened for writing, the error mode action is performed. 3844 3845=back 3846 3847 3848=over 4 3849 3850=item B<eof> - end of file indicator 3851 3852 $eof = $obj->eof; 3853 3854This method returns C<1> if end of file has been read, otherwise it 3855returns an empty string. Because the input is buffered this isn't the 3856same thing as I<$obj> has closed. In other words I<$obj> can be 3857closed but there still can be stuff in the buffer to be read. Under 3858this condition you can still read but you won't be able to write. 3859 3860=back 3861 3862 3863=over 4 3864 3865=item B<errmode> - define action to be performed on error 3866 3867 $mode = $obj->errmode; 3868 3869 $prev = $obj->errmode($mode); 3870 3871This method gets or sets the action used when errors are encountered 3872using the object. The first calling sequence returns the current 3873error mode. The second calling sequence sets it to I<$mode> and 3874returns the previous mode. Valid values for I<$mode> are C<"die"> 3875(the default), C<"return">, a I<coderef>, or an I<arrayref>. 3876 3877When mode is C<"die"> and an error is encountered using the object, 3878then an error message is printed to standard error and the program 3879dies. 3880 3881When mode is C<"return"> then the method generating the error places 3882an error message in the object and returns an undefined value in a 3883scalar context and an empty list in list context. The error message 3884may be obtained using C<errmsg()>. 3885 3886When mode is a I<coderef>, then when an error is encountered 3887I<coderef> is called with the error message as its first argument. 3888Using this mode you may have your own subroutine handle errors. If 3889I<coderef> itself returns then the method generating the error returns 3890undefined or an empty list depending on context. 3891 3892When mode is an I<arrayref>, the first element of the array must be a 3893I<coderef>. Any elements that follow are the arguments to I<coderef>. 3894When an error is encountered, the I<coderef> is called with its 3895arguments. Using this mode you may have your own subroutine handle 3896errors. If the I<coderef> itself returns then the method generating 3897the error returns undefined or an empty list depending on context. 3898 3899A warning is printed to STDERR when attempting to set this attribute 3900to something that's not C<"die">, C<"return">, a I<coderef>, or an 3901I<arrayref> whose first element isn't a I<coderef>. 3902 3903=back 3904 3905 3906=over 4 3907 3908=item B<errmsg> - most recent error message 3909 3910 $msg = $obj->errmsg; 3911 3912 $prev = $obj->errmsg(@msgs); 3913 3914The first calling sequence returns the error message associated with 3915the object. The empty string is returned if no error has been 3916encountered yet. The second calling sequence sets the error message 3917for the object to the concatenation of I<@msgs> and returns the 3918previous error message. Normally, error messages are set internally 3919by a method when an error is encountered. 3920 3921=back 3922 3923 3924=over 4 3925 3926=item B<error> - perform the error mode action 3927 3928 $obj->error(@msgs); 3929 3930This method concatenates I<@msgs> into a string and places it in the 3931object as the error message. Also see C<errmsg()>. It then performs 3932the error mode action. Also see C<errmode()>. 3933 3934If the error mode doesn't cause the program to die, then an undefined 3935value or an empty list is returned depending on the context. 3936 3937This method is primarily used by this class or a sub-class to perform 3938the user requested action when an error is encountered. 3939 3940=back 3941 3942 3943=over 4 3944 3945=item B<fhopen> - use already open filehandle for I/O 3946 3947 $ok = $obj->fhopen($fh); 3948 3949This method associates the open filehandle I<$fh> with I<$obj> for 3950further I/O. Filehandle I<$fh> must already be opened. 3951 3952Suppose you want to use the features of this module to do I/O to 3953something other than a TCP port, for example STDIN or a filehandle 3954opened to read from a process. Instead of opening the object for I/O 3955to a TCP port by using C<open()> or C<new()>, call this method 3956instead. 3957 3958The value C<1> is returned success, the error mode action is performed 3959on failure. 3960 3961=back 3962 3963 3964=over 4 3965 3966=item B<get> - read block of data 3967 3968 $data = $obj->get([Binmode => $mode,] 3969 [Errmode => $errmode,] 3970 [Telnetmode => $mode,] 3971 [Timeout => $secs,]); 3972 3973This method reads a block of data from the object and returns it along 3974with any buffered data. If no buffered data is available to return, 3975it will wait for data to read using the timeout specified in the 3976object. You can override that timeout using I<$secs>. Also see 3977C<timeout()>. If buffered data is available to return, it also checks 3978for a block of data that can be immediately read. 3979 3980On eof an undefined value is returned. On time-out or other failures, 3981the error mode action is performed. To distinguish between eof or an 3982error occurring when the error mode is not set to C<"die">, use 3983C<eof()>. 3984 3985Optional named parameters are provided to override the current 3986settings of binmode, errmode, telnetmode, and timeout. 3987 3988=back 3989 3990 3991=over 4 3992 3993=item B<getline> - read next line 3994 3995 $line = $obj->getline([Binmode => $mode,] 3996 [Errmode => $errmode,] 3997 [Input_record_separator => $chars,] 3998 [Rs => $chars,] 3999 [Telnetmode => $mode,] 4000 [Timeout => $secs,]); 4001 4002This method reads and returns the next line of data from the object. 4003You can use C<input_record_separator()> to change the notion of what 4004separates a line. The default is C<"\n">. If a line isn't 4005immediately available, this method blocks waiting for a line or a 4006time-out. 4007 4008On eof an undefined value is returned. On time-out or other failures, 4009the error mode action is performed. To distinguish between eof or an 4010error occurring when the error mode is not set to C<"die">, use 4011C<eof()>. 4012 4013Optional named parameters are provided to override the current 4014settings of binmode, errmode, input_record_separator, rs, telnetmode, 4015and timeout. Rs is synonymous with input_record_separator. 4016 4017=back 4018 4019 4020=over 4 4021 4022=item B<getlines> - read next lines 4023 4024 @lines = $obj->getlines([Binmode => $mode,] 4025 [Errmode => $errmode,] 4026 [Input_record_separator => $chars,] 4027 [Rs => $chars,] 4028 [Telnetmode => $mode,] 4029 [Timeout => $secs,] 4030 [All => $boolean,]); 4031 4032This method reads and returns all the lines of data from the object 4033until end of file is read. You can use C<input_record_separator()> to 4034change the notion of what separates a line. The default is C<"\n">. 4035A time-out error occurs if all the lines can't be read within the 4036time-out interval. See C<timeout()>. 4037 4038The behavior of this method was changed in version 3.03. Prior to 4039version 3.03 this method returned just the lines available from the 4040next read. To get that old behavior, use the optional named parameter 4041I<All> and set I<$boolean> to C<""> or C<0>. 4042 4043If only eof is read then an empty list is returned. On time-out or 4044other failures, the error mode action is performed. Use C<eof()> to 4045distinguish between reading only eof or an error occurring when the 4046error mode is not set to C<"die">. 4047 4048Optional named parameters are provided to override the current 4049settings of binmode, errmode, input_record_separator, rs, telnetmode, 4050and timeout. Rs is synonymous with input_record_separator. 4051 4052=back 4053 4054 4055=over 4 4056 4057=item B<host> - name of remote host 4058 4059 $host = $obj->host; 4060 4061 $prev = $obj->host($host); 4062 4063This method designates the remote host for C<open()>. With no 4064argument it returns the current host name set in the object. With an 4065argument it sets the current host name to I<$host> and returns the 4066previous host name. You may indicate the remote host using either a 4067hostname or an IP address. 4068 4069The default value is C<"localhost">. It may also be set by C<open()> 4070or C<new()>. 4071 4072=back 4073 4074 4075=over 4 4076 4077=item B<input_log> - log all input 4078 4079 $fh = $obj->input_log; 4080 4081 $fh = $obj->input_log($fh); 4082 4083 $fh = $obj->input_log($filename); 4084 4085This method starts or stops logging of input. This is useful when 4086debugging. Also see C<dump_log()>. Because most command interpreters 4087echo back commands received, it's likely all your output will also be 4088in this log. Note that input logging occurs after newline 4089translation. See C<binmode()> for details on newline translation. 4090 4091If no argument is given, the log filehandle is returned. An empty 4092string indicates logging is off. 4093 4094To stop logging, use an empty string as an argument. 4095 4096If an open filehandle is given, it is used for logging and returned. 4097Otherwise, the argument is assumed to be the name of a file, the file 4098is opened for logging and a filehandle to it is returned. If the file 4099can't be opened for writing, the error mode action is performed. 4100 4101=back 4102 4103 4104=over 4 4105 4106=item B<input_record_separator> - input line delimiter 4107 4108 $chars = $obj->input_record_separator; 4109 4110 $prev = $obj->input_record_separator($chars); 4111 4112This method designates the line delimiter for input. It's used with 4113C<getline()>, C<getlines()>, and C<cmd()> to determine lines in the 4114input. 4115 4116With no argument this method returns the current input record 4117separator set in the object. With an argument it sets the input 4118record separator to I<$chars> and returns the previous value. Note 4119that I<$chars> must have length. 4120 4121A warning is printed to STDERR when attempting to set this attribute 4122to a string with no length. 4123 4124=back 4125 4126 4127=over 4 4128 4129=item B<last_prompt> - last prompt read 4130 4131 $string = $obj->last_prompt; 4132 4133 $prev = $obj->last_prompt($string); 4134 4135With no argument this method returns the last prompt read by cmd() or 4136login(). See C<prompt()>. With an argument it sets the last prompt 4137read to I<$string> and returns the previous value. Normally, only 4138internal methods set the last prompt. 4139 4140=back 4141 4142 4143=over 4 4144 4145=item B<lastline> - last line read 4146 4147 $line = $obj->lastline; 4148 4149 $prev = $obj->lastline($line); 4150 4151This method retrieves the last line read from the object. This may be 4152a useful error message when the remote side abnormally closes the 4153connection. Typically the remote side will print an error message 4154before closing. 4155 4156With no argument this method returns the last line read from the 4157object. With an argument it sets the last line read to I<$line> and 4158returns the previous value. Normally, only internal methods set the 4159last line. 4160 4161=back 4162 4163 4164=over 4 4165 4166=item B<login> - perform standard login 4167 4168 $ok = $obj->login($username, $password); 4169 4170 $ok = $obj->login(Name => $username, 4171 Password => $password, 4172 [Errmode => $mode,] 4173 [Prompt => $match,] 4174 [Timeout => $secs,]); 4175 4176This method performs a standard login by waiting for a login prompt 4177and responding with I<$username>, then waiting for the password prompt 4178and responding with I<$password>, and then waiting for the command 4179interpreter prompt. If any of those prompts sent by the remote side 4180don't match what's expected, this method will time-out, unless timeout 4181is turned off. 4182 4183Login prompt must match either of these case insensitive patterns: 4184 4185 /login[: ]*$/i 4186 /username[: ]*$/i 4187 4188Password prompt must match this case insensitive pattern: 4189 4190 /password[: ]*$/i 4191 4192The command interpreter prompt must match the current setting of 4193prompt. See C<prompt()>. 4194 4195Use C<dump_log()> to debug when this method keeps timing-out and you 4196don't think it should. 4197 4198Consider using a combination of C<print()> and C<waitfor()> as an 4199alternative to this method when it doesn't do what you want, e.g. the 4200remote host doesn't prompt for a username. 4201 4202On success, C<1> is returned. On time out, eof, or other failures, 4203the error mode action is performed. See C<errmode()>. 4204 4205Optional named parameters are provided to override the current 4206settings of errmode, prompt, and timeout. 4207 4208=back 4209 4210 4211=over 4 4212 4213=item B<max_buffer_length> - maximum size of input buffer 4214 4215 $len = $obj->max_buffer_length; 4216 4217 $prev = $obj->max_buffer_length($len); 4218 4219This method designates the maximum size of the input buffer. An error 4220is generated when a read causes the buffer to exceed this limit. The 4221default value is 1,048,576 bytes (1MB). The input buffer can grow 4222much larger than the block size when you continuously read using 4223C<getline()> or C<waitfor()> and the data stream contains no newlines 4224or matching waitfor patterns. 4225 4226With no argument, this method returns the current maximum buffer 4227length set in the object. With an argument it sets the maximum buffer 4228length to I<$len> and returns the previous value. Values of I<$len> 4229smaller than 512 will be adjusted to 512. 4230 4231A warning is printed to STDERR when attempting to set this attribute 4232to something that isn't a positive integer. 4233 4234=back 4235 4236 4237=over 4 4238 4239=item B<ofs> - field separator for print 4240 4241 $chars = $obj->ofs 4242 4243 $prev = $obj->ofs($chars); 4244 4245This method is synonymous with C<output_field_separator()>. 4246 4247=back 4248 4249 4250=over 4 4251 4252=item B<open> - connect to port on remote host 4253 4254 $ok = $obj->open($host); 4255 4256 $ok = $obj->open([Host => $host,] 4257 [Port => $port,] 4258 [Errmode => $mode,] 4259 [Timeout => $secs,]); 4260 4261This method opens a TCP connection to I<$port> on I<$host>. If either 4262argument is missing then the current value of C<host()> or C<port()> 4263is used. Optional named parameters are provided to override the 4264current setting of errmode and timeout. 4265 4266On success C<1> is returned. On time-out or other connection 4267failures, the error mode action is performed. See C<errmode()>. 4268 4269Time-outs don't work for this method on machines that don't implement 4270SIGALRM - most notably MS-Windows machines. For those machines, an 4271error is returned when the system reaches its own time-out while 4272trying to connect. 4273 4274A side effect of this method is to reset the alarm interval associated 4275with SIGALRM. 4276 4277=back 4278 4279 4280=over 4 4281 4282=item B<option_accept> - indicate willingness to accept a TELNET option 4283 4284 $fh = $obj->option_accept([Do => $telopt,] 4285 [Dont => $telopt,] 4286 [Will => $telopt,] 4287 [Wont => $telopt,]); 4288 4289This method is used to indicate whether to accept or reject an offer 4290to enable a TELNET option made by the remote side. If you're using 4291I<Do> or I<Will> to indicate a willingness to enable, then a 4292notification callback must have already been defined by a prior call 4293to C<option_callback()>. See C<option_callback()> for details on 4294receiving enable/disable notification of a TELNET option. 4295 4296You can give multiple I<Do>, I<Dont>, I<Will>, or I<Wont> arguments 4297for different TELNET options in the same call to this method. 4298 4299The following example describes the meaning of the named parameters. 4300A TELNET option, such as C<TELOPT_ECHO> used below, is an integer 4301constant that you can import from Net::Telnet. See the source in file 4302Telnet.pm for the complete list. 4303 4304=over 4 4305 4306=item 4307 4308I<Do> => C<TELOPT_ECHO> 4309 4310=over 4 4311 4312=item 4313 4314we'll accept an offer to enable the echo option on the local side 4315 4316=back 4317 4318=item 4319 4320I<Dont> => C<TELOPT_ECHO> 4321 4322=over 4 4323 4324=item 4325 4326we'll reject an offer to enable the echo option on the local side 4327 4328=back 4329 4330=item 4331 4332I<Will> => C<TELOPT_ECHO> 4333 4334=over 4 4335 4336=item 4337 4338we'll accept an offer to enable the echo option on the remote side 4339 4340=back 4341 4342=item 4343 4344I<Wont> => C<TELOPT_ECHO> 4345 4346=over 4 4347 4348=item 4349 4350we'll reject an offer to enable the echo option on the remote side 4351 4352=back 4353 4354=back 4355 4356=item 4357 4358Use C<option_send()> to send a request to the remote side to enable or 4359disable a particular TELNET option. 4360 4361=back 4362 4363 4364=over 4 4365 4366=item B<option_callback> - define the option negotiation callback 4367 4368 $coderef = $obj->option_callback; 4369 4370 $prev = $obj->option_callback($coderef); 4371 4372This method defines the callback subroutine that's called when a 4373TELNET option is enabled or disabled. Once defined, the 4374I<option_callback> may not be undefined. However, calling this method 4375with a different I<$coderef> changes it. 4376 4377A warning is printed to STDERR when attempting to set this attribute 4378to something that isn't a coderef. 4379 4380Here are the circumstances that invoke I<$coderef>: 4381 4382=over 4 4383 4384=item 4385 4386An option becomes enabled because the remote side requested an enable 4387and C<option_accept()> had been used to arrange that it be accepted. 4388 4389=item 4390 4391The remote side arbitrarily decides to disable an option that is 4392currently enabled. Note that Net::Telnet always accepts a request to 4393disable from the remote side. 4394 4395=item 4396 4397C<option_send()> was used to send a request to enable or disable an 4398option and the response from the remote side has just been received. 4399Note, that if a request to enable is rejected then I<$coderef> is 4400still invoked even though the option didn't change. 4401 4402=back 4403 4404=item 4405 4406Here are the arguments passed to I<&$coderef>: 4407 4408 &$coderef($obj, $option, $is_remote, 4409 $is_enabled, $was_enabled, $buf_position); 4410 4411=over 4 4412 4413=item 4414 44151. I<$obj> is the Net::Telnet object 4416 4417=item 4418 44192. I<$option> is the TELNET option. Net::Telnet exports constants 4420for the various TELNET options which just equate to an integer. 4421 4422=item 4423 44243. I<$is_remote> is a boolean indicating for which side the option 4425applies. 4426 4427=item 4428 44294. I<$is_enabled> is a boolean indicating the option is enabled or 4430disabled 4431 4432=item 4433 44345. I<$was_enabled> is a boolean indicating the option was previously 4435enabled or disabled 4436 4437=item 4438 44396. I<$buf_position> is an integer indicating the position in the 4440object's input buffer where the option takes effect. See C<buffer()> 4441to access the object's input buffer. 4442 4443=back 4444 4445=back 4446 4447 4448=over 4 4449 4450=item B<option_log> - log all TELNET options sent or received 4451 4452 $fh = $obj->option_log; 4453 4454 $fh = $obj->option_log($fh); 4455 4456 $fh = $obj->option_log($filename); 4457 4458This method starts or stops logging of all TELNET options being sent 4459or received. This is useful for debugging when you send options via 4460C<option_send()> or you arrange to accept option requests from the 4461remote side via C<option_accept()>. Also see C<dump_log()>. 4462 4463If no argument is given, the log filehandle is returned. An empty 4464string indicates logging is off. 4465 4466To stop logging, use an empty string as an argument. 4467 4468If an open filehandle is given, it is used for logging and returned. 4469Otherwise, the argument is assumed to be the name of a file, the file 4470is opened for logging and a filehandle to it is returned. If the file 4471can't be opened for writing, the error mode action is performed. 4472 4473=back 4474 4475 4476=over 4 4477 4478=item B<option_send> - send TELNET option negotiation request 4479 4480 $ok = $obj->option_send([Do => $telopt,] 4481 [Dont => $telopt,] 4482 [Will => $telopt,] 4483 [Wont => $telopt,] 4484 [Async => $boolean,]); 4485 4486This method is not yet implemented. Look for it in a future version. 4487 4488=back 4489 4490 4491=over 4 4492 4493=item B<option_state> - get current state of a TELNET option 4494 4495 $hashref = $obj->option_state($telopt); 4496 4497This method returns a hashref containing a copy of the current state 4498of TELNET option I<$telopt>. 4499 4500Here are the values returned in the hash: 4501 4502=over 4 4503 4504=item 4505 4506I<$hashref>->{remote_enabled} 4507 4508=over 4 4509 4510=item 4511 4512boolean that indicates if the option is enabled on the remote side. 4513 4514=back 4515 4516=item 4517 4518I<$hashref>->{remote_enable_ok} 4519 4520=over 4 4521 4522=item 4523 4524boolean that indicates if it's ok to accept an offer to enable this 4525option on the remote side. 4526 4527=back 4528 4529=item 4530 4531I<$hashref>->{remote_state} 4532 4533=over 4 4534 4535=item 4536 4537string used to hold the internal state of option negotiation for this 4538option on the remote side. 4539 4540=back 4541 4542=item 4543 4544I<$hashref>->{local_enabled} 4545 4546=over 4 4547 4548=item 4549 4550boolean that indicates if the option is enabled on the local side. 4551 4552=back 4553 4554=item 4555 4556I<$hashref>->{local_enable_ok} 4557 4558=over 4 4559 4560=item 4561 4562boolean that indicates if it's ok to accept an offer to enable this 4563option on the local side. 4564 4565=back 4566 4567=item 4568 4569I<$hashref>->{local_state} 4570 4571=over 4 4572 4573=item 4574 4575string used to hold the internal state of option negotiation for this 4576option on the local side. 4577 4578=back 4579 4580=back 4581 4582=back 4583 4584 4585=over 4 4586 4587=item B<ors> - output line delimiter 4588 4589 $chars = $obj->ors; 4590 4591 $prev = $obj->ors($chars); 4592 4593This method is synonymous with C<output_record_separator()>. 4594 4595=back 4596 4597 4598=over 4 4599 4600=item B<output_field_separator> - field separator for print 4601 4602 $chars = $obj->output_field_separator; 4603 4604 $prev = $obj->output_field_separator($chars); 4605 4606This method designates the output field separator for C<print()>. 4607Ordinarily the print method simply prints out the comma separated 4608fields you specify. Set this to specify what's printed between 4609fields. 4610 4611With no argument this method returns the current output field 4612separator set in the object. With an argument it sets the output 4613field separator to I<$chars> and returns the previous value. 4614 4615By default it's set to an empty string. 4616 4617=back 4618 4619 4620=over 4 4621 4622=item B<output_log> - log all output 4623 4624 $fh = $obj->output_log; 4625 4626 $fh = $obj->output_log($fh); 4627 4628 $fh = $obj->output_log($filename); 4629 4630This method starts or stops logging of output. This is useful when 4631debugging. Also see C<dump_log()>. Because most command interpreters 4632echo back commands received, it's likely all your output would also be 4633in an input log. See C<input_log()>. Note that output logging occurs 4634before newline translation. See C<binmode()> for details on newline 4635translation. 4636 4637If no argument is given, the log filehandle is returned. An empty 4638string indicates logging is off. 4639 4640To stop logging, use an empty string as an argument. 4641 4642If an open filehandle is given, it is used for logging and returned. 4643Otherwise, the argument is assumed to be the name of a file, the file 4644is opened for logging and a filehandle to it is returned. If the file 4645can't be opened for writing, the error mode action is performed. 4646 4647=back 4648 4649 4650=over 4 4651 4652=item B<output_record_separator> - output line delimiter 4653 4654 $chars = $obj->output_record_separator; 4655 4656 $prev = $obj->output_record_separator($chars); 4657 4658This method designates the output line delimiter for C<print()> and 4659C<cmd()>. Set this to specify what's printed at the end of C<print()> 4660and C<cmd()>. 4661 4662The output record separator is set to C<"\n"> by default, so there's 4663no need to append all your commands with a newline. To avoid printing 4664the output_record_separator use C<put()> or set the 4665output_record_separator to an empty string. 4666 4667With no argument this method returns the current output record 4668separator set in the object. With an argument it sets the output 4669record separator to I<$chars> and returns the previous value. 4670 4671=back 4672 4673 4674=over 4 4675 4676=item B<port> - remote port 4677 4678 $port = $obj->port; 4679 4680 $prev = $obj->port($port); 4681 4682This method designates the remote TCP port. With no argument this 4683method returns the current port number. With an argument it sets the 4684current port number to I<$port> and returns the previous port. If 4685I<$port> is a TCP service name, then it's first converted to a port 4686number using the perl function C<getservbyname()>. 4687 4688The default value is C<23>. It may also be set by C<open()> or 4689C<new()>. 4690 4691A warning is printed to STDERR when attempting to set this attribute 4692to something that's not a positive integer or a valid TCP service 4693name. 4694 4695=back 4696 4697 4698=over 4 4699 4700=item B<print> - write to object 4701 4702 $ok = $obj->print(@list); 4703 4704This method writes I<@list> followed by the I<output_record_separator> 4705to the open object and returns C<1> if all data was successfully 4706written. On time-out or other failures, the error mode action is 4707performed. See C<errmode()>. 4708 4709By default, the C<output_record_separator()> is set to C<"\n"> so all 4710your commands automatically end with a newline. In most cases your 4711output is being read by a command interpreter which won't accept a 4712command until newline is read. This is similar to someone typing a 4713command and hitting the return key. To avoid printing a trailing 4714C<"\n"> use C<put()> instead or set the output_record_separator to an 4715empty string. 4716 4717On failure, it's possible that some data was written. If you choose 4718to try and recover from a print timing-out, use C<print_length()> to 4719determine how much was written before the error occurred. 4720 4721You may also use the output field separator to print a string between 4722the list elements. See C<output_field_separator()>. 4723 4724=back 4725 4726 4727=over 4 4728 4729=item B<print_length> - number of bytes written by print 4730 4731 $num = $obj->print_length; 4732 4733This returns the number of bytes successfully written by the most 4734recent C<print()> or C<put()>. 4735 4736=back 4737 4738 4739=over 4 4740 4741=item B<prompt> - pattern to match a prompt 4742 4743 $matchop = $obj->prompt; 4744 4745 $prev = $obj->prompt($matchop); 4746 4747This method sets the pattern used to find a prompt in the input 4748stream. It must be a string representing a valid perl pattern match 4749operator. The methods C<login()> and C<cmd()> try to read until 4750matching the prompt. They will fail with a time-out error if the 4751pattern you've chosen doesn't match what the remote side sends. 4752 4753With no argument this method returns the prompt set in the object. 4754With an argument it sets the prompt to I<$matchop> and returns the 4755previous value. 4756 4757The default prompt is C<'/[\$%#E<gt>] $/'> 4758 4759Always use single quotes, instead of double quotes, to construct 4760I<$matchop> (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like 4761file path, you'll need to use four backslashes to represent one 4762(e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>). 4763 4764Of course don't forget about regexp metacharacters like C<.>, C<[>, or 4765C<$>. You'll only need a single backslash to quote them. The anchor 4766metacharacters C<^> and C<$> refer to positions in the input buffer. 4767 4768A warning is printed to STDERR when attempting to set this attribute 4769with a match operator missing its opening delimiter. 4770 4771=back 4772 4773 4774=over 4 4775 4776=item B<put> - write to object 4777 4778 $ok = $obj->put($string); 4779 4780 $ok = $obj->put(String => $string, 4781 [Binmode => $mode,] 4782 [Errmode => $errmode,] 4783 [Telnetmode => $mode,] 4784 [Timeout => $secs,]); 4785 4786This method writes I<$string> to the opened object and returns C<1> if 4787all data was successfully written. This method is like C<print()> 4788except that it doesn't write the trailing output_record_separator 4789("\n" by default). On time-out or other failures, the error mode 4790action is performed. See C<errmode()>. 4791 4792On failure, it's possible that some data was written. If you choose 4793to try and recover from a put timing-out, use C<print_length()> to 4794determine how much was written before the error occurred. 4795 4796Optional named parameters are provided to override the current 4797settings of binmode, errmode, telnetmode, and timeout. 4798 4799=back 4800 4801 4802=over 4 4803 4804=item B<rs> - input line delimiter 4805 4806 $chars = $obj->rs; 4807 4808 $prev = $obj->rs($chars); 4809 4810This method is synonymous with C<input_record_separator()>. 4811 4812=back 4813 4814 4815=over 4 4816 4817=item B<telnetmode> - turn off/on telnet command interpretation 4818 4819 $mode = $obj->telnetmode; 4820 4821 $prev = $obj->telnetmode($mode); 4822 4823This method controls whether or not TELNET commands in the data stream 4824are recognized and handled. The TELNET protocol uses certain 4825character sequences sent in the data stream to control the session. 4826If the port you're connecting to isn't using the TELNET protocol, then 4827you should turn this mode off. The default is I<on>. 4828 4829If no argument is given, the current mode is returned. 4830 4831If I<$mode> is C<0> then telnet mode is off. If I<$mode> is C<1> then 4832telnet mode is on. 4833 4834=back 4835 4836 4837=over 4 4838 4839=item B<timed_out> - time-out indicator 4840 4841 $boolean = $obj->timed_out; 4842 4843 $prev = $obj->timed_out($boolean); 4844 4845This method indicates if a previous read, write, or open method 4846timed-out. Remember that timing-out is itself an error. To be able 4847to invoke C<timed_out()> after a time-out error, you'd have to change 4848the default error mode to something other than C<"die">. See 4849C<errmode()>. 4850 4851With no argument this method returns C<1> if the previous method 4852timed-out. With an argument it sets the indicator. Normally, only 4853internal methods set this indicator. 4854 4855=back 4856 4857 4858=over 4 4859 4860=item B<timeout> - I/O time-out interval 4861 4862 $secs = $obj->timeout; 4863 4864 $prev = $obj->timeout($secs); 4865 4866This method sets the timeout interval that's used when performing I/O 4867or connecting to a port. When a method doesn't complete within the 4868timeout interval then it's an error and the error mode action is 4869performed. 4870 4871A timeout may be expressed as a relative or absolute value. If 4872I<$secs> is greater than or equal to the time the program started, as 4873determined by $^T, then it's an absolute time value for when time-out 4874occurs. The perl function C<time()> may be used to obtain an absolute 4875time value. For a relative time-out value less than $^T, time-out 4876happens I<$secs> from when the method begins. 4877 4878If I<$secs> is C<0> then time-out occurs if the data cannot be 4879immediately read or written. Use the undefined value to turn off 4880timing-out completely. 4881 4882With no argument this method returns the timeout set in the object. 4883With an argument it sets the timeout to I<$secs> and returns the 4884previous value. The default timeout value is C<10> seconds. 4885 4886A warning is printed to STDERR when attempting to set this attribute 4887to something that's not an C<undef> or a non-negative integer. 4888 4889=back 4890 4891 4892=over 4 4893 4894=item B<waitfor> - wait for pattern in the input 4895 4896 $ok = $obj->waitfor($matchop); 4897 $ok = $obj->waitfor([Match => $matchop,] 4898 [String => $string,] 4899 [Binmode => $mode,] 4900 [Errmode => $errmode,] 4901 [Telnetmode => $mode,] 4902 [Timeout => $secs,]); 4903 4904 ($prematch, $match) = $obj->waitfor($matchop); 4905 ($prematch, $match) = $obj->waitfor([Match => $matchop,] 4906 [String => $string,] 4907 [Binmode => $mode,] 4908 [Errmode => $errmode,] 4909 [Telnetmode => $mode,] 4910 [Timeout => $secs,]); 4911 4912This method reads until a pattern match or string is found in the 4913input stream. All the characters before and including the match are 4914removed from the input stream. 4915 4916In a list context the characters before the match and the matched 4917characters are returned in I<$prematch> and I<$match>. In a scalar 4918context, the matched characters and all characters before it are 4919discarded and C<1> is returned on success. On time-out, eof, or other 4920failures, for both list and scalar context, the error mode action is 4921performed. See C<errmode()>. 4922 4923You can specify more than one pattern or string by simply providing 4924multiple I<Match> and/or I<String> named parameters. A I<$matchop> 4925must be a string representing a valid Perl pattern match operator. 4926The I<$string> is just a substring to find in the input stream. 4927 4928Use C<dump_log()> to debug when this method keeps timing-out and you 4929don't think it should. 4930 4931An optional named parameter is provided to override the current 4932setting of timeout. 4933 4934To avoid unexpected backslash interpretation, always use single quotes 4935instead of double quotes to construct a match operator argument for 4936C<prompt()> and C<waitfor()> (e.g. C<'/bash\$ $/'>). If you're 4937constructing a DOS like file path, you'll need to use four backslashes 4938to represent one (e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>). 4939 4940Of course don't forget about regexp metacharacters like C<.>, C<[>, or 4941C<$>. You'll only need a single backslash to quote them. The anchor 4942metacharacters C<^> and C<$> refer to positions in the input buffer. 4943 4944Optional named parameters are provided to override the current 4945settings of binmode, errmode, telnetmode, and timeout. 4946 4947=back 4948 4949 4950=head1 SEE ALSO 4951 4952=over 2 4953 4954=item RFC 854 4955 4956S<TELNET Protocol Specification> 4957 4958S<ftp://ftp.isi.edu/in-notes/rfc854.txt> 4959 4960=item RFC 1143 4961 4962S<Q Method of Implementing TELNET Option Negotiation> 4963 4964S<ftp://ftp.isi.edu/in-notes/rfc1143.txt> 4965 4966=item TELNET Option Assignments 4967 4968S<http://www.iana.org/assignments/telnet-options> 4969 4970=back 4971 4972 4973=head1 EXAMPLES 4974 4975This example gets the current weather forecast for Brainerd, Minnesota. 4976 4977 my ($forecast, $t); 4978 4979 use Net::Telnet (); 4980 $t = new Net::Telnet; 4981 $t->open("rainmaker.wunderground.com"); 4982 4983 ## Wait for first prompt and "hit return". 4984 $t->waitfor('/continue:.*$/'); 4985 $t->print(""); 4986 4987 ## Wait for second prompt and respond with city code. 4988 $t->waitfor('/city code.*$/'); 4989 $t->print("BRD"); 4990 4991 ## Read and print the first page of forecast. 4992 ($forecast) = $t->waitfor('/[ \t]+press return to continue/i'); 4993 print $forecast; 4994 4995 exit; 4996 4997 4998This example checks a POP server to see if you have mail. 4999 5000 my ($hostname, $line, $passwd, $pop, $username); 5001 5002 $hostname = "your_destination_host_here"; 5003 $username = "your_username_here"; 5004 $passwd = "your_password_here"; 5005 5006 use Net::Telnet (); 5007 $pop = new Net::Telnet (Telnetmode => 0); 5008 $pop->open(Host => $hostname, 5009 Port => 110); 5010 5011 5012 ## Read connection message. 5013 $line = $pop->getline; 5014 die $line unless $line =~ /^\+OK/; 5015 5016 ## Send user name. 5017 $pop->print("user $username"); 5018 $line = $pop->getline; 5019 die $line unless $line =~ /^\+OK/; 5020 5021 ## Send password. 5022 $pop->print("pass $passwd"); 5023 $line = $pop->getline; 5024 die $line unless $line =~ /^\+OK/; 5025 5026 ## Request status of messages. 5027 $pop->print("list"); 5028 $line = $pop->getline; 5029 print $line; 5030 5031 exit; 5032 5033 5034Here's an example that uses the ssh program to connect to a remote 5035host. Because the ssh program reads and writes to its controlling 5036terminal, the IO::Pty module is used to create a new pseudo terminal 5037for use by ssh. A new Net::Telnet object is then created to read and 5038write to that pseudo terminal. To use the code below, substitute 5039"changeme" with the actual host, user, password, and command prompt. 5040 5041 ## Main program. 5042 { 5043 my ($pty, $ssh, @lines); 5044 my $host = "changeme"; 5045 my $user = "changeme"; 5046 my $password = "changeme"; 5047 my $prompt = '/changeme:~> $/'; 5048 5049 ## Start ssh program. 5050 $pty = &spawn("ssh", "-l", $user, $host); # spawn() defined below 5051 5052 ## Create a Net::Telnet object to perform I/O on ssh's tty. 5053 use Net::Telnet; 5054 $ssh = new Net::Telnet (-fhopen => $pty, 5055 -prompt => $prompt, 5056 -telnetmode => 0, 5057 -cmd_remove_mode => 1, 5058 -output_record_separator => "\r"); 5059 5060 ## Login to remote host. 5061 $ssh->waitfor(-match => '/password: ?$/i', 5062 -errmode => "return") 5063 or die "problem connecting to host: ", $ssh->lastline; 5064 $ssh->print($password); 5065 $ssh->waitfor(-match => $ssh->prompt, 5066 -errmode => "return") 5067 or die "login failed: ", $ssh->lastline; 5068 5069 ## Send command, get and print its output. 5070 @lines = $ssh->cmd("who"); 5071 print @lines; 5072 5073 exit; 5074 } # end main program 5075 5076 sub spawn { 5077 my(@cmd) = @_; 5078 my($pid, $pty, $tty, $tty_fd); 5079 5080 ## Create a new pseudo terminal. 5081 use IO::Pty (); 5082 $pty = new IO::Pty 5083 or die $!; 5084 5085 ## Execute the program in another process. 5086 unless ($pid = fork) { # child process 5087 die "problem spawning program: $!\n" unless defined $pid; 5088 5089 ## Disassociate process from existing controlling terminal. 5090 use POSIX (); 5091 POSIX::setsid 5092 or die "setsid failed: $!"; 5093 5094 ## Associate process with a new controlling terminal. 5095 $tty = $pty->slave; 5096 $tty_fd = $tty->fileno; 5097 close $pty; 5098 5099 ## Make stdio use the new controlling terminal. 5100 open STDIN, "<&$tty_fd" or die $!; 5101 open STDOUT, ">&$tty_fd" or die $!; 5102 open STDERR, ">&STDOUT" or die $!; 5103 close $tty; 5104 5105 ## Execute requested program. 5106 exec @cmd 5107 or die "problem executing $cmd[0]\n"; 5108 } # end child process 5109 5110 $pty; 5111 } # end sub spawn 5112 5113 5114Here's an example that changes a user's login password. Because the 5115passwd program always prompts for passwords on its controlling 5116terminal, the IO::Pty module is used to create a new pseudo terminal 5117for use by passwd. A new Net::Telnet object is then created to read 5118and write to that pseudo terminal. To use the code below, substitute 5119"changeme" with the actual old and new passwords. 5120 5121 my ($pty, $passwd); 5122 my $oldpw = "changeme"; 5123 my $newpw = "changeme"; 5124 5125 ## Start passwd program. 5126 $pty = &spawn("passwd"); # spawn() defined above 5127 5128 ## Create a Net::Telnet object to perform I/O on passwd's tty. 5129 use Net::Telnet; 5130 $passwd = new Net::Telnet (-fhopen => $pty, 5131 -timeout => 2, 5132 -output_record_separator => "\r", 5133 -telnetmode => 0, 5134 -cmd_remove_mode => 1); 5135 $passwd->errmode("return"); 5136 5137 ## Send existing password. 5138 $passwd->waitfor('/password: ?$/i') 5139 or die "no old password prompt: ", $passwd->lastline; 5140 $passwd->print($oldpw); 5141 5142 ## Send new password. 5143 $passwd->waitfor('/new password: ?$/i') 5144 or die "bad old password: ", $passwd->lastline; 5145 $passwd->print($newpw); 5146 5147 ## Send new password verification. 5148 $passwd->waitfor('/new password: ?$/i') 5149 or die "bad new password: ", $passwd->lastline; 5150 $passwd->print($newpw); 5151 5152 ## Display success or failure. 5153 $passwd->waitfor('/changed/') 5154 or die "bad new password: ", $passwd->lastline; 5155 print $passwd->lastline; 5156 5157 $passwd->close; 5158 exit; 5159 5160 5161Here's an example you can use to down load a file of any type. The 5162file is read from the remote host's standard output using cat. To 5163prevent any output processing, the remote host's standard output is 5164put in raw mode using the Bourne shell. The Bourne shell is used 5165because some shells, notably tcsh, prevent changing tty modes. Upon 5166completion, FTP style statistics are printed to stderr. 5167 5168 my ($block, $filename, $host, $hostname, $k_per_sec, $line, 5169 $num_read, $passwd, $prevblock, $prompt, $size, $size_bsd, 5170 $size_sysv, $start_time, $total_time, $username); 5171 5172 $hostname = "your_destination_host_here"; 5173 $username = "your_username_here"; 5174 $passwd = "your_password_here"; 5175 $filename = "your_download_file_here"; 5176 5177 ## Connect and login. 5178 use Net::Telnet (); 5179 $host = new Net::Telnet (Timeout => 30, 5180 Prompt => '/[%#>] $/'); 5181 $host->open($hostname); 5182 $host->login($username, $passwd); 5183 5184 ## Make sure prompt won't match anything in send data. 5185 $prompt = "_funkyPrompt_"; 5186 $host->prompt("/$prompt\$/"); 5187 $host->cmd("set prompt = '$prompt'"); 5188 5189 ## Get size of file. 5190 ($line) = $host->cmd("/bin/ls -l $filename"); 5191 ($size_bsd, $size_sysv) = (split ' ', $line)[3,4]; 5192 if ($size_sysv =~ /^\d+$/) { 5193 $size = $size_sysv; 5194 } 5195 elsif ($size_bsd =~ /^\d+$/) { 5196 $size = $size_bsd; 5197 } 5198 else { 5199 die "$filename: no such file on $hostname"; 5200 } 5201 5202 ## Start sending the file. 5203 binmode STDOUT; 5204 $host->binmode(1); 5205 $host->print("/bin/sh -c 'stty raw; cat $filename'"); 5206 $host->getline; # discard echoed back line 5207 5208 ## Read file a block at a time. 5209 $num_read = 0; 5210 $prevblock = ""; 5211 $start_time = time; 5212 while (($block = $host->get) and ($block !~ /$prompt$/o)) { 5213 if (length $block >= length $prompt) { 5214 print $prevblock; 5215 $num_read += length $prevblock; 5216 $prevblock = $block; 5217 } 5218 else { 5219 $prevblock .= $block; 5220 } 5221 5222 } 5223 $host->close; 5224 5225 ## Print last block without trailing prompt. 5226 $prevblock .= $block; 5227 $prevblock =~ s/$prompt$//; 5228 print $prevblock; 5229 $num_read += length $prevblock; 5230 die "error: expected size $size, received size $num_read\n" 5231 unless $num_read == $size; 5232 5233 ## Print totals. 5234 $total_time = (time - $start_time) || 1; 5235 $k_per_sec = ($size / 1024) / $total_time; 5236 $k_per_sec = sprintf "%3.1f", $k_per_sec; 5237 warn("$num_read bytes received in $total_time seconds ", 5238 "($k_per_sec Kbytes/s)\n"); 5239 5240 exit; 5241 5242 5243=head1 AUTHOR 5244 5245Jay Rogers <jay@rgrs.com> 5246 5247 5248=head1 COPYRIGHT 5249 5250Copyright 1997, 2000, 2002 by Jay Rogers. All rights reserved. 5251This program is free software; you can redistribute it and/or 5252modify it under the same terms as Perl itself. 5253