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