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