6169 lines
151 KiB
Perl
6169 lines
151 KiB
Perl
package Net::Telnet;
|
|
|
|
## Copyright 1997, 2000, 2002, 2013 Jay Rogers. All rights reserved.
|
|
## This program is free software; you can redistribute it and/or
|
|
## modify it under the same terms as Perl itself.
|
|
|
|
## See user documentation at the end of this file. Search for =head
|
|
|
|
use strict;
|
|
require 5.002;
|
|
|
|
## Module export.
|
|
use vars qw(@EXPORT_OK);
|
|
@EXPORT_OK = qw(TELNET_IAC TELNET_DONT TELNET_DO TELNET_WONT TELNET_WILL
|
|
TELNET_SB TELNET_GA TELNET_EL TELNET_EC TELNET_AYT TELNET_AO
|
|
TELNET_IP TELNET_BREAK TELNET_DM TELNET_NOP TELNET_SE
|
|
TELNET_EOR TELNET_ABORT TELNET_SUSP TELNET_EOF TELNET_SYNCH
|
|
TELOPT_BINARY TELOPT_ECHO TELOPT_RCP TELOPT_SGA TELOPT_NAMS
|
|
TELOPT_STATUS TELOPT_TM TELOPT_RCTE TELOPT_NAOL TELOPT_NAOP
|
|
TELOPT_NAOCRD TELOPT_NAOHTS TELOPT_NAOHTD TELOPT_NAOFFD
|
|
TELOPT_NAOVTS TELOPT_NAOVTD TELOPT_NAOLFD TELOPT_XASCII
|
|
TELOPT_LOGOUT TELOPT_BM TELOPT_DET TELOPT_SUPDUP
|
|
TELOPT_SUPDUPOUTPUT TELOPT_SNDLOC TELOPT_TTYPE TELOPT_EOR
|
|
TELOPT_TUID TELOPT_OUTMRK TELOPT_TTYLOC TELOPT_3270REGIME
|
|
TELOPT_X3PAD TELOPT_NAWS TELOPT_TSPEED TELOPT_LFLOW
|
|
TELOPT_LINEMODE TELOPT_XDISPLOC TELOPT_OLD_ENVIRON
|
|
TELOPT_AUTHENTICATION TELOPT_ENCRYPT TELOPT_NEW_ENVIRON
|
|
TELOPT_TN3270E TELOPT_CHARSET TELOPT_COMPORT TELOPT_KERMIT
|
|
TELOPT_EXOPL);
|
|
|
|
## Module import.
|
|
use Exporter ();
|
|
use Socket qw(AF_INET SOCK_STREAM inet_aton sockaddr_in);
|
|
use Symbol qw(qualify);
|
|
|
|
## Base classes.
|
|
use vars qw(@ISA);
|
|
@ISA = qw(Exporter);
|
|
if (&_io_socket_include) { # successfully required module IO::Socket
|
|
push @ISA, "IO::Socket::INET";
|
|
}
|
|
else { # perl version < 5.004
|
|
require FileHandle;
|
|
push @ISA, "FileHandle";
|
|
}
|
|
my $AF_INET6 = &_import_af_inet6();
|
|
my $AF_UNSPEC = &_import_af_unspec() || 0;
|
|
my $AI_ADDRCONFIG = &_import_ai_addrconfig() || 0;
|
|
my $EAI_BADFLAGS = &_import_eai_badflags() || -1;
|
|
my $EINTR = &_import_eintr();
|
|
|
|
## Global variables.
|
|
use vars qw($VERSION @Telopts);
|
|
$VERSION = "3.04";
|
|
@Telopts = ("BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", "NAMS", "STATUS",
|
|
"TIMING MARK", "RCTE", "NAOL", "NAOP", "NAOCRD", "NAOHTS",
|
|
"NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", "NAOLFD", "EXTEND ASCII",
|
|
"LOGOUT", "BYTE MACRO", "DATA ENTRY TERMINAL", "SUPDUP",
|
|
"SUPDUP OUTPUT", "SEND LOCATION", "TERMINAL TYPE", "END OF RECORD",
|
|
"TACACS UID", "OUTPUT MARKING", "TTYLOC", "3270 REGIME", "X.3 PAD",
|
|
"NAWS", "TSPEED", "LFLOW", "LINEMODE", "XDISPLOC", "OLD-ENVIRON",
|
|
"AUTHENTICATION", "ENCRYPT", "NEW-ENVIRON", "TN3270E", "XAUTH",
|
|
"CHARSET", "RSP", "COMPORT", "SUPPRESS LOCAL ECHO", "START TLS",
|
|
"KERMIT");
|
|
|
|
|
|
########################### Public Methods ###########################
|
|
|
|
|
|
sub new {
|
|
my ($class) = @_;
|
|
my (
|
|
$dump_log,
|
|
$errmode,
|
|
$family,
|
|
$fh_open,
|
|
$host,
|
|
$input_log,
|
|
$localfamily,
|
|
$option_log,
|
|
$output_log,
|
|
$port,
|
|
$prompt,
|
|
$self,
|
|
%args,
|
|
);
|
|
local $_;
|
|
|
|
## Create a new object with defaults.
|
|
$self = $class->SUPER::new;
|
|
*$self->{net_telnet} = {
|
|
bin_mode => 0,
|
|
blksize => &_optimal_blksize(),
|
|
buf => "",
|
|
cmd_prompt => '/[\$%#>] $/',
|
|
cmd_rm_mode => "auto",
|
|
dumplog => '',
|
|
eofile => 1,
|
|
errormode => "die",
|
|
errormsg => "",
|
|
fdmask => '',
|
|
host => "localhost",
|
|
inputlog => '',
|
|
last_line => "",
|
|
last_prompt => "",
|
|
local_family => "ipv4",
|
|
local_host => "",
|
|
maxbufsize => 1_048_576,
|
|
num_wrote => 0,
|
|
ofs => "",
|
|
opened => '',
|
|
opt_cback => '',
|
|
opt_log => '',
|
|
opts => {},
|
|
ors => "\n",
|
|
outputlog => '',
|
|
peer_family => "ipv4",
|
|
pending_errormsg => "",
|
|
port => 23,
|
|
pushback_buf => "",
|
|
rs => "\n",
|
|
select_supported => 1,
|
|
sock_family => 0,
|
|
subopt_cback => '',
|
|
telnet_mode => 1,
|
|
time_out => 10,
|
|
timedout => '',
|
|
unsent_opts => "",
|
|
};
|
|
|
|
## Indicate that we'll accept an offer from remote side for it to echo
|
|
## and suppress go aheads.
|
|
&_opt_accept($self,
|
|
{ option => &TELOPT_ECHO,
|
|
is_remote => 1,
|
|
is_enable => 1 },
|
|
{ option => &TELOPT_SGA,
|
|
is_remote => 1,
|
|
is_enable => 1 },
|
|
);
|
|
|
|
## Parse the args.
|
|
if (@_ == 2) { # one positional arg given
|
|
$host = $_[1];
|
|
}
|
|
elsif (@_ > 2) { # named args given
|
|
## Get the named args.
|
|
(undef, %args) = @_;
|
|
|
|
## Parse all other named args.
|
|
foreach (keys %args) {
|
|
if (/^-?binmode$/i) {
|
|
$self->binmode($args{$_});
|
|
}
|
|
elsif (/^-?cmd_remove_mode$/i) {
|
|
$self->cmd_remove_mode($args{$_});
|
|
}
|
|
elsif (/^-?dump_log$/i) {
|
|
$dump_log = $args{$_};
|
|
}
|
|
elsif (/^-?errmode$/i) {
|
|
$errmode = $args{$_};
|
|
}
|
|
elsif (/^-?family$/i) {
|
|
$family = $args{$_};
|
|
}
|
|
elsif (/^-?fhopen$/i) {
|
|
$fh_open = $args{$_};
|
|
}
|
|
elsif (/^-?host$/i) {
|
|
$host = $args{$_};
|
|
}
|
|
elsif (/^-?input_log$/i) {
|
|
$input_log = $args{$_};
|
|
}
|
|
elsif (/^-?input_record_separator$/i or /^-?rs$/i) {
|
|
$self->input_record_separator($args{$_});
|
|
}
|
|
elsif (/^-?localfamily$/i) {
|
|
$localfamily = $args{$_};
|
|
}
|
|
elsif (/^-?localhost$/i) {
|
|
$self->localhost($args{$_});
|
|
}
|
|
elsif (/^-?max_buffer_length$/i) {
|
|
$self->max_buffer_length($args{$_});
|
|
}
|
|
elsif (/^-?option_log$/i) {
|
|
$option_log = $args{$_};
|
|
}
|
|
elsif (/^-?output_field_separator$/i or /^-?ofs$/i) {
|
|
$self->output_field_separator($args{$_});
|
|
}
|
|
elsif (/^-?output_log$/i) {
|
|
$output_log = $args{$_};
|
|
}
|
|
elsif (/^-?output_record_separator$/i or /^-?ors$/i) {
|
|
$self->output_record_separator($args{$_});
|
|
}
|
|
elsif (/^-?port$/i) {
|
|
$port = $args{$_};
|
|
}
|
|
elsif (/^-?prompt$/i) {
|
|
$prompt = $args{$_};
|
|
}
|
|
elsif (/^-?telnetmode$/i) {
|
|
$self->telnetmode($args{$_});
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$self->timeout($args{$_});
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given " .
|
|
"to " . ref($self) . "::new()");
|
|
}
|
|
}
|
|
}
|
|
|
|
if (defined $errmode) { # user wants to set errmode
|
|
$self->errmode($errmode);
|
|
}
|
|
|
|
if (defined $host) { # user wants to set host
|
|
$self->host($host);
|
|
}
|
|
|
|
if (defined $port) { # user wants to set port
|
|
$self->port($port)
|
|
or return;
|
|
}
|
|
|
|
if (defined $family) { # user wants to set family
|
|
$self->family($family)
|
|
or return;
|
|
}
|
|
|
|
if (defined $localfamily) { # user wants to set localfamily
|
|
$self->localfamily($localfamily)
|
|
or return;
|
|
}
|
|
|
|
if (defined $prompt) { # user wants to set prompt
|
|
$self->prompt($prompt)
|
|
or return;
|
|
}
|
|
|
|
if (defined $dump_log) { # user wants to set dump_log
|
|
$self->dump_log($dump_log)
|
|
or return;
|
|
}
|
|
|
|
if (defined $input_log) { # user wants to set input_log
|
|
$self->input_log($input_log)
|
|
or return;
|
|
}
|
|
|
|
if (defined $option_log) { # user wants to set option_log
|
|
$self->option_log($option_log)
|
|
or return;
|
|
}
|
|
|
|
if (defined $output_log) { # user wants to set output_log
|
|
$self->output_log($output_log)
|
|
or return;
|
|
}
|
|
|
|
if (defined $fh_open) { # user wants us to attach to existing filehandle
|
|
$self->fhopen($fh_open)
|
|
or return;
|
|
}
|
|
elsif (defined $host) { # user wants us to open a connection to host
|
|
$self->open
|
|
or return;
|
|
}
|
|
|
|
$self;
|
|
} # end sub new
|
|
|
|
|
|
sub DESTROY {
|
|
} # end sub DESTROY
|
|
|
|
|
|
sub binmode {
|
|
my ($self, $mode) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{bin_mode};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $mode) {
|
|
$mode = 0;
|
|
}
|
|
|
|
$s->{bin_mode} = $mode;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub binmode
|
|
|
|
|
|
sub break {
|
|
my ($self) = @_;
|
|
my $s = *$self->{net_telnet};
|
|
my $break_cmd = "\xff\xf3";
|
|
|
|
$s->{timedout} = '';
|
|
|
|
&_put($self, \$break_cmd, "break");
|
|
} # end sub break
|
|
|
|
|
|
sub buffer {
|
|
my ($self) = @_;
|
|
my $s = *$self->{net_telnet};
|
|
|
|
\$s->{buf};
|
|
} # end sub buffer
|
|
|
|
|
|
sub buffer_empty {
|
|
my ($self) = @_;
|
|
my (
|
|
$buffer,
|
|
);
|
|
|
|
$buffer = $self->buffer;
|
|
$$buffer = "";
|
|
} # end sub buffer_empty
|
|
|
|
|
|
sub close {
|
|
my ($self) = @_;
|
|
my $s = *$self->{net_telnet};
|
|
|
|
$s->{eofile} = 1;
|
|
$s->{opened} = '';
|
|
$s->{sock_family} = 0;
|
|
close $self
|
|
if defined fileno($self);
|
|
|
|
1;
|
|
} # end sub close
|
|
|
|
|
|
sub cmd {
|
|
my ($self, @args) = @_;
|
|
my (
|
|
$arg_errmode,
|
|
$cmd_remove_mode,
|
|
$firstpos,
|
|
$last_prompt,
|
|
$lastpos,
|
|
$lines,
|
|
$ors,
|
|
$output,
|
|
$output_ref,
|
|
$prompt,
|
|
$remove_echo,
|
|
$rs,
|
|
$rs_len,
|
|
$s,
|
|
$telopt_echo,
|
|
$timeout,
|
|
%args,
|
|
);
|
|
my $cmd = "";
|
|
local $_;
|
|
|
|
## Init.
|
|
$self->timed_out('');
|
|
$self->last_prompt("");
|
|
$s = *$self->{net_telnet};
|
|
$output = [];
|
|
$cmd_remove_mode = $self->cmd_remove_mode;
|
|
$ors = $self->output_record_separator;
|
|
$prompt = $self->prompt;
|
|
$rs = $self->input_record_separator;
|
|
$timeout = $self->timeout;
|
|
|
|
## Override errmode first, if specified.
|
|
$arg_errmode = &_extract_arg_errmode($self, \@args);
|
|
local $s->{errormode} = $arg_errmode
|
|
if $arg_errmode;
|
|
|
|
## Parse args.
|
|
if (@args == 1) { # one positional arg given
|
|
$cmd = $args[0];
|
|
}
|
|
elsif (@args >= 2) { # named args given
|
|
## Get the named args.
|
|
%args = @args;
|
|
|
|
## Parse the named args.
|
|
foreach (keys %args) {
|
|
if (/^-?cmd_remove/i) {
|
|
$cmd_remove_mode = &_parse_cmd_remove_mode($self, $args{$_});
|
|
}
|
|
elsif (/^-?input_record_separator$/i or /^-?rs$/i) {
|
|
$rs = &_parse_input_record_separator($self, $args{$_});
|
|
}
|
|
elsif (/^-?output$/i) {
|
|
$output_ref = $args{$_};
|
|
if (defined($output_ref) and ref($output_ref) eq "ARRAY") {
|
|
$output = $output_ref;
|
|
}
|
|
}
|
|
elsif (/^-?output_record_separator$/i or /^-?ors$/i) {
|
|
$ors = $args{$_};
|
|
}
|
|
elsif (/^-?prompt$/i) {
|
|
$prompt = &_parse_prompt($self, $args{$_})
|
|
or return;
|
|
}
|
|
elsif (/^-?string$/i) {
|
|
$cmd = $args{$_};
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $args{$_});
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given " .
|
|
"to " . ref($self) . "::cmd()");
|
|
}
|
|
}
|
|
}
|
|
|
|
## Override some user settings.
|
|
local $s->{time_out} = &_endtime($timeout);
|
|
$self->errmsg("");
|
|
|
|
## Send command and wait for the prompt.
|
|
{
|
|
local $s->{errormode} = "return";
|
|
|
|
$self->put($cmd . $ors)
|
|
and ($lines, $last_prompt) = $self->waitfor($prompt);
|
|
}
|
|
|
|
## Check for failure.
|
|
return $self->error("command timed-out") if $self->timed_out;
|
|
return $self->error($self->errmsg) if $self->errmsg ne "";
|
|
|
|
## Save the most recently matched prompt.
|
|
$self->last_prompt($last_prompt);
|
|
|
|
## Split lines into an array, keeping record separator at end of line.
|
|
$firstpos = 0;
|
|
$rs_len = length $rs;
|
|
while (($lastpos = index($lines, $rs, $firstpos)) > -1) {
|
|
push(@$output,
|
|
substr($lines, $firstpos, $lastpos - $firstpos + $rs_len));
|
|
$firstpos = $lastpos + $rs_len;
|
|
}
|
|
|
|
if ($firstpos < length $lines) {
|
|
push @$output, substr($lines, $firstpos);
|
|
}
|
|
|
|
## Determine if we should remove the first line of output based
|
|
## on the assumption that it's an echoed back command.
|
|
if ($cmd_remove_mode eq "auto") {
|
|
## See if remote side told us they'd echo.
|
|
$telopt_echo = $self->option_state(&TELOPT_ECHO);
|
|
$remove_echo = $telopt_echo->{remote_enabled};
|
|
}
|
|
else { # user explicitly told us how many lines to remove.
|
|
$remove_echo = $cmd_remove_mode;
|
|
}
|
|
|
|
## Get rid of possible echo back command.
|
|
while ($remove_echo--) {
|
|
shift @$output;
|
|
}
|
|
|
|
## Ensure at least a null string when there's no command output - so
|
|
## "true" is returned in a list context.
|
|
unless (@$output) {
|
|
@$output = ("");
|
|
}
|
|
|
|
## Return command output via named arg, if requested.
|
|
if (defined $output_ref) {
|
|
if (ref($output_ref) eq "SCALAR") {
|
|
$$output_ref = join "", @$output;
|
|
}
|
|
elsif (ref($output_ref) eq "HASH") {
|
|
%$output_ref = @$output;
|
|
}
|
|
}
|
|
|
|
wantarray ? @$output : 1;
|
|
} # end sub cmd
|
|
|
|
|
|
sub cmd_remove_mode {
|
|
my ($self, $mode) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{cmd_rm_mode};
|
|
|
|
if (@_ >= 2) {
|
|
$s->{cmd_rm_mode} = &_parse_cmd_remove_mode($self, $mode);
|
|
}
|
|
|
|
$prev;
|
|
} # end sub cmd_remove_mode
|
|
|
|
|
|
sub dump_log {
|
|
my ($self, $name) = @_;
|
|
my (
|
|
$fh,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$fh = $s->{dumplog};
|
|
|
|
if (@_ >= 2) {
|
|
if (!defined($name) or $name eq "") { # input arg is ""
|
|
## Turn off logging.
|
|
$fh = "";
|
|
}
|
|
elsif (&_is_open_fh($name)) { # input arg is an open fh
|
|
## Use the open fh for logging.
|
|
$fh = $name;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
elsif (!ref $name) { # input arg is filename
|
|
## Open the file for logging.
|
|
$fh = &_fname_to_handle($self, $name)
|
|
or return;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
else {
|
|
return $self->error("bad Dump_log argument ",
|
|
"\"$name\": not filename or open fh");
|
|
}
|
|
|
|
$s->{dumplog} = $fh;
|
|
}
|
|
|
|
$fh;
|
|
} # end sub dump_log
|
|
|
|
|
|
sub eof {
|
|
my ($self) = @_;
|
|
|
|
*$self->{net_telnet}{eofile};
|
|
} # end sub eof
|
|
|
|
|
|
sub errmode {
|
|
my ($self, $mode) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{errormode};
|
|
|
|
if (@_ >= 2) {
|
|
$s->{errormode} = &_parse_errmode($self, $mode);
|
|
}
|
|
|
|
$prev;
|
|
} # end sub errmode
|
|
|
|
|
|
sub errmsg {
|
|
my ($self, @errmsgs) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{errormsg};
|
|
|
|
if (@_ >= 2) {
|
|
$s->{errormsg} = join "", @errmsgs;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub errmsg
|
|
|
|
|
|
sub error {
|
|
my ($self, @errmsg) = @_;
|
|
my (
|
|
$errmsg,
|
|
$func,
|
|
$mode,
|
|
$s,
|
|
@args,
|
|
);
|
|
local $_;
|
|
|
|
$s = *$self->{net_telnet};
|
|
|
|
if (@_ >= 2) {
|
|
## Put error message in the object.
|
|
$errmsg = join "", @errmsg;
|
|
$s->{errormsg} = $errmsg;
|
|
|
|
## Do the error action as described by error mode.
|
|
$mode = $s->{errormode};
|
|
if (ref($mode) eq "CODE") {
|
|
&$mode($errmsg);
|
|
return;
|
|
}
|
|
elsif (ref($mode) eq "ARRAY") {
|
|
($func, @args) = @$mode;
|
|
&$func(@args);
|
|
return;
|
|
}
|
|
elsif ($mode =~ /^return$/i) {
|
|
return;
|
|
}
|
|
else { # die
|
|
if ($errmsg =~ /\n$/) {
|
|
die $errmsg;
|
|
}
|
|
else {
|
|
## Die and append caller's line number to message.
|
|
&_croak($self, $errmsg);
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
return $s->{errormsg} ne "";
|
|
}
|
|
} # end sub error
|
|
|
|
|
|
sub family {
|
|
my ($self, $family) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{peer_family};
|
|
|
|
if (@_ >= 2) {
|
|
$family = &_parse_family($self, $family)
|
|
or return;
|
|
|
|
$s->{peer_family} = $family;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub family
|
|
|
|
|
|
sub fhopen {
|
|
my ($self, $fh) = @_;
|
|
my (
|
|
$globref,
|
|
$s,
|
|
);
|
|
|
|
## Convert given filehandle to a typeglob reference, if necessary.
|
|
$globref = &_qualify_fh($self, $fh);
|
|
|
|
## Ensure filehandle is already open.
|
|
return $self->error("fhopen filehandle isn't already open")
|
|
unless defined($globref) and defined(fileno $globref);
|
|
|
|
## Ensure we're closed.
|
|
$self->close;
|
|
|
|
## Save our private data.
|
|
$s = *$self->{net_telnet};
|
|
|
|
## Switch ourself with the given filehandle.
|
|
*$self = *$globref;
|
|
|
|
## Restore our private data.
|
|
*$self->{net_telnet} = $s;
|
|
|
|
## Re-initialize ourself.
|
|
select((select($self), $|=1)[$[]); # don't buffer writes
|
|
$s = *$self->{net_telnet};
|
|
$s->{blksize} = &_optimal_blksize((stat $self)[11]);
|
|
$s->{buf} = "";
|
|
$s->{eofile} = '';
|
|
$s->{errormsg} = "";
|
|
vec($s->{fdmask}='', fileno($self), 1) = 1;
|
|
$s->{host} = "";
|
|
$s->{last_line} = "";
|
|
$s->{last_prompt} = "";
|
|
$s->{num_wrote} = 0;
|
|
$s->{opened} = 1;
|
|
$s->{pending_errormsg} = "";
|
|
$s->{port} = '';
|
|
$s->{pushback_buf} = "";
|
|
$s->{select_supported} = $^O ne "MSWin32" || -S $self;
|
|
$s->{timedout} = '';
|
|
$s->{unsent_opts} = "";
|
|
&_reset_options($s->{opts});
|
|
|
|
1;
|
|
} # end sub fhopen
|
|
|
|
|
|
sub get {
|
|
my ($self, %args) = @_;
|
|
my (
|
|
$binmode,
|
|
$endtime,
|
|
$errmode,
|
|
$line,
|
|
$s,
|
|
$telnetmode,
|
|
$timeout,
|
|
);
|
|
local $_;
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
$timeout = $s->{time_out};
|
|
$s->{timedout} = '';
|
|
return if $s->{eofile};
|
|
|
|
## Parse the named args.
|
|
foreach (keys %args) {
|
|
if (/^-?binmode$/i) {
|
|
$binmode = $args{$_};
|
|
unless (defined $binmode) {
|
|
$binmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?errmode$/i) {
|
|
$errmode = &_parse_errmode($self, $args{$_});
|
|
}
|
|
elsif (/^-?telnetmode$/i) {
|
|
$telnetmode = $args{$_};
|
|
unless (defined $telnetmode) {
|
|
$telnetmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $args{$_});
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given " .
|
|
"to " . ref($self) . "::get()");
|
|
}
|
|
}
|
|
|
|
## If any args given, override corresponding instance data.
|
|
local $s->{errormode} = $errmode
|
|
if defined $errmode;
|
|
local $s->{bin_mode} = $binmode
|
|
if defined $binmode;
|
|
local $s->{telnet_mode} = $telnetmode
|
|
if defined $telnetmode;
|
|
|
|
## Set wall time when we time out.
|
|
$endtime = &_endtime($timeout);
|
|
|
|
## Try to send any waiting option negotiation.
|
|
if (length $s->{unsent_opts}) {
|
|
&_flush_opts($self);
|
|
}
|
|
|
|
## Try to read just the waiting data using return error mode.
|
|
{
|
|
local $s->{errormode} = "return";
|
|
$s->{errormsg} = "";
|
|
&_fillbuf($self, $s, 0);
|
|
}
|
|
|
|
## We're done if we timed-out and timeout value is set to "poll".
|
|
return $self->error($s->{errormsg})
|
|
if ($s->{timedout} and defined($timeout) and $timeout == 0
|
|
and !length $s->{buf});
|
|
|
|
## We're done if we hit an error other than timing out.
|
|
if ($s->{errormsg} and !$s->{timedout}) {
|
|
if (!length $s->{buf}) {
|
|
return $self->error($s->{errormsg});
|
|
}
|
|
else { # error encountered but there's some data in buffer
|
|
$s->{pending_errormsg} = $s->{errormsg};
|
|
}
|
|
}
|
|
|
|
## Clear time-out error from first read.
|
|
$s->{timedout} = '';
|
|
$s->{errormsg} = "";
|
|
|
|
## If buffer is still empty, try to read according to user's timeout.
|
|
if (!length $s->{buf}) {
|
|
&_fillbuf($self, $s, $endtime)
|
|
or do {
|
|
return if $s->{timedout};
|
|
|
|
## We've reached end-of-file.
|
|
$self->close;
|
|
return;
|
|
};
|
|
}
|
|
|
|
## Extract chars from buffer.
|
|
$line = $s->{buf};
|
|
$s->{buf} = "";
|
|
|
|
$line;
|
|
} # end sub get
|
|
|
|
|
|
sub getline {
|
|
my ($self, %args) = @_;
|
|
my (
|
|
$binmode,
|
|
$endtime,
|
|
$errmode,
|
|
$len,
|
|
$line,
|
|
$offset,
|
|
$pos,
|
|
$rs,
|
|
$s,
|
|
$telnetmode,
|
|
$timeout,
|
|
);
|
|
local $_;
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
$s->{timedout} = '';
|
|
return if $s->{eofile};
|
|
$rs = $s->{"rs"};
|
|
$timeout = $s->{time_out};
|
|
|
|
## Parse the named args.
|
|
foreach (keys %args) {
|
|
if (/^-?binmode$/i) {
|
|
$binmode = $args{$_};
|
|
unless (defined $binmode) {
|
|
$binmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?errmode$/i) {
|
|
$errmode = &_parse_errmode($self, $args{$_});
|
|
}
|
|
elsif (/^-?input_record_separator$/i or /^-?rs$/i) {
|
|
$rs = &_parse_input_record_separator($self, $args{$_});
|
|
}
|
|
elsif (/^-?telnetmode$/i) {
|
|
$telnetmode = $args{$_};
|
|
unless (defined $telnetmode) {
|
|
$telnetmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $args{$_});
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given " .
|
|
"to " . ref($self) . "::getline()");
|
|
}
|
|
}
|
|
|
|
## If any args given, override corresponding instance data.
|
|
local $s->{bin_mode} = $binmode
|
|
if defined $binmode;
|
|
local $s->{errormode} = $errmode
|
|
if defined $errmode;
|
|
local $s->{telnet_mode} = $telnetmode
|
|
if defined $telnetmode;
|
|
|
|
## Set wall time when we time out.
|
|
$endtime = &_endtime($timeout);
|
|
|
|
## Try to send any waiting option negotiation.
|
|
if (length $s->{unsent_opts}) {
|
|
&_flush_opts($self);
|
|
}
|
|
|
|
## Keep reading into buffer until end-of-line is read.
|
|
$offset = 0;
|
|
while (($pos = index($s->{buf}, $rs, $offset)) == -1) {
|
|
$offset = length $s->{buf};
|
|
&_fillbuf($self, $s, $endtime)
|
|
or do {
|
|
return if $s->{timedout};
|
|
|
|
## We've reached end-of-file.
|
|
$self->close;
|
|
if (length $s->{buf}) {
|
|
return $s->{buf};
|
|
}
|
|
else {
|
|
return;
|
|
}
|
|
};
|
|
}
|
|
|
|
## Extract line from buffer.
|
|
$len = $pos + length $rs;
|
|
$line = substr($s->{buf}, 0, $len);
|
|
substr($s->{buf}, 0, $len) = "";
|
|
|
|
$line;
|
|
} # end sub getline
|
|
|
|
|
|
sub getlines {
|
|
my ($self, %args) = @_;
|
|
my (
|
|
$binmode,
|
|
$errmode,
|
|
$line,
|
|
$rs,
|
|
$s,
|
|
$telnetmode,
|
|
$timeout,
|
|
);
|
|
my $all = 1;
|
|
my @lines = ();
|
|
local $_;
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
$s->{timedout} = '';
|
|
return if $s->{eofile};
|
|
$timeout = $s->{time_out};
|
|
|
|
## Parse the named args.
|
|
foreach (keys %args) {
|
|
if (/^-?all$/i) {
|
|
$all = $args{$_};
|
|
unless (defined $all) {
|
|
$all = '';
|
|
}
|
|
}
|
|
elsif (/^-?binmode$/i) {
|
|
$binmode = $args{$_};
|
|
unless (defined $binmode) {
|
|
$binmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?errmode$/i) {
|
|
$errmode = &_parse_errmode($self, $args{$_});
|
|
}
|
|
elsif (/^-?input_record_separator$/i or /^-?rs$/i) {
|
|
$rs = &_parse_input_record_separator($self, $args{$_});
|
|
}
|
|
elsif (/^-?telnetmode$/i) {
|
|
$telnetmode = $args{$_};
|
|
unless (defined $telnetmode) {
|
|
$telnetmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $args{$_});
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given " .
|
|
"to " . ref($self) . "::getlines()");
|
|
}
|
|
}
|
|
|
|
## If any args given, override corresponding instance data.
|
|
local $s->{bin_mode} = $binmode
|
|
if defined $binmode;
|
|
local $s->{errormode} = $errmode
|
|
if defined $errmode;
|
|
local $s->{"rs"} = $rs
|
|
if defined $rs;
|
|
local $s->{telnet_mode} = $telnetmode
|
|
if defined $telnetmode;
|
|
local $s->{time_out} = &_endtime($timeout);
|
|
|
|
## User requested only the currently available lines.
|
|
if (! $all) {
|
|
return &_next_getlines($self, $s);
|
|
}
|
|
|
|
## Read lines until eof or error.
|
|
while (1) {
|
|
$line = $self->getline
|
|
or last;
|
|
push @lines, $line;
|
|
}
|
|
|
|
## Check for error.
|
|
return if ! $self->eof;
|
|
|
|
@lines;
|
|
} # end sub getlines
|
|
|
|
|
|
sub host {
|
|
my ($self, $host) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{host};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $host) {
|
|
$host = "";
|
|
}
|
|
|
|
$s->{host} = $host;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub host
|
|
|
|
|
|
sub input_log {
|
|
my ($self, $name) = @_;
|
|
my (
|
|
$fh,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$fh = $s->{inputlog};
|
|
|
|
if (@_ >= 2) {
|
|
if (!defined($name) or $name eq "") { # input arg is ""
|
|
## Turn off logging.
|
|
$fh = "";
|
|
}
|
|
elsif (&_is_open_fh($name)) { # input arg is an open fh
|
|
## Use the open fh for logging.
|
|
$fh = $name;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
elsif (!ref $name) { # input arg is filename
|
|
## Open the file for logging.
|
|
$fh = &_fname_to_handle($self, $name)
|
|
or return;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
else {
|
|
return $self->error("bad Input_log argument ",
|
|
"\"$name\": not filename or open fh");
|
|
}
|
|
|
|
$s->{inputlog} = $fh;
|
|
}
|
|
|
|
$fh;
|
|
} # end sub input_log
|
|
|
|
|
|
sub input_record_separator {
|
|
my ($self, $rs) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{"rs"};
|
|
|
|
if (@_ >= 2) {
|
|
$s->{"rs"} = &_parse_input_record_separator($self, $rs);
|
|
}
|
|
|
|
$prev;
|
|
} # end sub input_record_separator
|
|
|
|
|
|
sub last_prompt {
|
|
my ($self, $string) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{last_prompt};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $string) {
|
|
$string = "";
|
|
}
|
|
|
|
$s->{last_prompt} = $string;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub last_prompt
|
|
|
|
|
|
sub lastline {
|
|
my ($self, $line) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{last_line};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $line) {
|
|
$line = "";
|
|
}
|
|
|
|
$s->{last_line} = $line;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub lastline
|
|
|
|
|
|
sub localfamily {
|
|
my ($self, $family) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{local_family};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $family) {
|
|
$family = "";
|
|
}
|
|
|
|
if ($family =~ /^\s*ipv4\s*$/i) { # family arg is "ipv4"
|
|
$s->{local_family} = "ipv4";
|
|
}
|
|
elsif ($family =~ /^\s*any\s*$/i) { # family arg is "any"
|
|
if ($Socket::VERSION >= 1.94 and defined $AF_INET6) { # has IPv6
|
|
$s->{local_family} = "any";
|
|
}
|
|
else { # IPv6 not supported on this machine
|
|
$s->{local_family} = "ipv4";
|
|
}
|
|
}
|
|
elsif ($family =~ /^\s*ipv6\s*$/i) { # family arg is "ipv6"
|
|
return $self->error("Localfamily arg ipv6 not supported when " .
|
|
"Socket.pm version < 1.94")
|
|
unless $Socket::VERSION >= 1.94;
|
|
return $self->error("Localfamily arg ipv6 not supported by " .
|
|
"this OS: AF_INET6 not in Socket.pm")
|
|
unless defined $AF_INET6;
|
|
|
|
$s->{local_family} = "ipv6";
|
|
}
|
|
else {
|
|
return $self->error("bad Localfamily argument \"$family\": " .
|
|
"must be \"ipv4\", \"ipv6\", or \"any\"");
|
|
}
|
|
}
|
|
|
|
$prev;
|
|
} # end sub localfamily
|
|
|
|
|
|
sub localhost {
|
|
my ($self, $localhost) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{local_host};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $localhost) {
|
|
$localhost = "";
|
|
}
|
|
|
|
$s->{local_host} = $localhost;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub localhost
|
|
|
|
|
|
sub login {
|
|
my ($self, @args) = @_;
|
|
my (
|
|
$arg_errmode,
|
|
$error,
|
|
$is_passwd_arg,
|
|
$is_username_arg,
|
|
$lastline,
|
|
$match,
|
|
$ors,
|
|
$passwd,
|
|
$prematch,
|
|
$prompt,
|
|
$s,
|
|
$timeout,
|
|
$username,
|
|
%args,
|
|
);
|
|
local $_;
|
|
|
|
## Init.
|
|
$self->timed_out('');
|
|
$self->last_prompt("");
|
|
$s = *$self->{net_telnet};
|
|
$timeout = $self->timeout;
|
|
$ors = $self->output_record_separator;
|
|
$prompt = $self->prompt;
|
|
|
|
## Parse positional args.
|
|
if (@args == 2) { # just username and passwd given
|
|
$username = $args[0];
|
|
$passwd = $args[1];
|
|
|
|
$is_username_arg = 1;
|
|
$is_passwd_arg = 1;
|
|
}
|
|
|
|
## Override errmode first, if specified.
|
|
$arg_errmode = &_extract_arg_errmode($self, \@args);
|
|
local $s->{errormode} = $arg_errmode
|
|
if $arg_errmode;
|
|
|
|
## Parse named args.
|
|
if (@args > 2) {
|
|
## Get the named args.
|
|
%args = @args;
|
|
|
|
## Parse the named args.
|
|
foreach (keys %args) {
|
|
if (/^-?name$/i) {
|
|
$username = $args{$_};
|
|
unless (defined $username) {
|
|
$username = "";
|
|
}
|
|
|
|
$is_username_arg = 1;
|
|
}
|
|
elsif (/^-?pass/i) {
|
|
$passwd = $args{$_};
|
|
unless (defined $passwd) {
|
|
$passwd = "";
|
|
}
|
|
|
|
$is_passwd_arg = 1;
|
|
}
|
|
elsif (/^-?prompt$/i) {
|
|
$prompt = &_parse_prompt($self, $args{$_})
|
|
or return;
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $args{$_});
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given ",
|
|
"to " . ref($self) . "::login()");
|
|
}
|
|
}
|
|
}
|
|
|
|
## Ensure both username and password argument given.
|
|
&_croak($self,"Name argument not given to " . ref($self) . "::login()")
|
|
unless $is_username_arg;
|
|
&_croak($self,"Password argument not given to " . ref($self) . "::login()")
|
|
unless $is_passwd_arg;
|
|
|
|
## Set timeout for this invocation.
|
|
local $s->{time_out} = &_endtime($timeout);
|
|
|
|
## Create a subroutine to generate an error.
|
|
$error
|
|
= sub {
|
|
my ($errmsg) = @_;
|
|
|
|
if ($self->timed_out) {
|
|
return $self->error($errmsg);
|
|
}
|
|
elsif ($self->eof) {
|
|
($lastline = $self->lastline) =~ s/\n+//;
|
|
return $self->error($errmsg, ": ", $lastline);
|
|
}
|
|
else {
|
|
return $self->error($self->errmsg);
|
|
}
|
|
};
|
|
|
|
|
|
return $self->error("login failed: filehandle isn't open")
|
|
if $self->eof;
|
|
|
|
## Wait for login prompt.
|
|
$self->waitfor(Match => '/login[: ]*$/i',
|
|
Match => '/username[: ]*$/i',
|
|
Errmode => "return")
|
|
or do {
|
|
return &$error("eof read waiting for login prompt")
|
|
if $self->eof;
|
|
return &$error("timed-out waiting for login prompt");
|
|
};
|
|
|
|
## Delay sending response because of bug in Linux login program.
|
|
&_sleep(0.01);
|
|
|
|
## Send login name.
|
|
$self->put(String => $username . $ors,
|
|
Errmode => "return")
|
|
or return &$error("login disconnected");
|
|
|
|
## Wait for password prompt.
|
|
$self->waitfor(Match => '/password[: ]*$/i',
|
|
Errmode => "return")
|
|
or do {
|
|
return &$error("eof read waiting for password prompt")
|
|
if $self->eof;
|
|
return &$error("timed-out waiting for password prompt");
|
|
};
|
|
|
|
## Delay sending response because of bug in Linux login program.
|
|
&_sleep(0.01);
|
|
|
|
## Send password.
|
|
$self->put(String => $passwd . $ors,
|
|
Errmode => "return")
|
|
or return &$error("login disconnected");
|
|
|
|
## Wait for command prompt or another login prompt.
|
|
($prematch, $match) = $self->waitfor(Match => '/login[: ]*$/i',
|
|
Match => '/username[: ]*$/i',
|
|
Match => $prompt,
|
|
Errmode => "return")
|
|
or do {
|
|
return &$error("eof read waiting for command prompt")
|
|
if $self->eof;
|
|
return &$error("timed-out waiting for command prompt");
|
|
};
|
|
|
|
## It's a bad login if we got another login prompt.
|
|
return $self->error("login failed: bad name or password")
|
|
if $match =~ /login[: ]*$/i or $match =~ /username[: ]*$/i;
|
|
|
|
## Save the most recently matched command prompt.
|
|
$self->last_prompt($match);
|
|
|
|
1;
|
|
} # end sub login
|
|
|
|
|
|
sub max_buffer_length {
|
|
my ($self, $maxbufsize) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
my $minbufsize = 512;
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{maxbufsize};
|
|
|
|
if (@_ >= 2) {
|
|
## Ensure a positive integer value.
|
|
unless (defined $maxbufsize
|
|
and $maxbufsize =~ /^\d+$/
|
|
and $maxbufsize)
|
|
{
|
|
&_carp($self, "ignoring bad Max_buffer_length " .
|
|
"argument \"$maxbufsize\": it's not a positive integer");
|
|
$maxbufsize = $prev;
|
|
}
|
|
|
|
## Adjust up values that are too small.
|
|
if ($maxbufsize < $minbufsize) {
|
|
$maxbufsize = $minbufsize;
|
|
}
|
|
|
|
$s->{maxbufsize} = $maxbufsize;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub max_buffer_length
|
|
|
|
|
|
## Make ofs() synonymous with output_field_separator().
|
|
sub ofs { &output_field_separator; }
|
|
|
|
|
|
sub open {
|
|
my ($self, @args) = @_;
|
|
my (
|
|
$af,
|
|
$arg_errmode,
|
|
$err,
|
|
$errno,
|
|
$family,
|
|
$flags_hint,
|
|
$host,
|
|
$ip_addr,
|
|
$lfamily,
|
|
$localhost,
|
|
$port,
|
|
$s,
|
|
$timeout,
|
|
%args,
|
|
@ai,
|
|
);
|
|
local $@;
|
|
local $_;
|
|
my $local_addr = '';
|
|
my $remote_addr = '';
|
|
my %af = (
|
|
ipv4 => AF_INET,
|
|
ipv6 => defined($AF_INET6) ? $AF_INET6 : undef,
|
|
any => $AF_UNSPEC,
|
|
);
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
$s->{timedout} = '';
|
|
$s->{sock_family} = 0;
|
|
$port = $self->port;
|
|
$family = $self->family;
|
|
$localhost = $self->localhost;
|
|
$lfamily = $self->localfamily;
|
|
$timeout = $self->timeout;
|
|
|
|
## Override errmode first, if specified.
|
|
$arg_errmode = &_extract_arg_errmode($self, \@args);
|
|
local $s->{errormode} = $arg_errmode
|
|
if $arg_errmode;
|
|
|
|
if (@args == 1) { # one positional arg given
|
|
$self->host($args[0]);
|
|
}
|
|
elsif (@args >= 2) { # named args given
|
|
## Get the named args.
|
|
%args = @args;
|
|
|
|
## Parse the named args.
|
|
foreach (keys %args) {
|
|
if (/^-?family$/i) {
|
|
$family = &_parse_family($self, $args{$_});
|
|
}
|
|
elsif (/^-?host$/i) {
|
|
$self->host($args{$_});
|
|
}
|
|
elsif (/^-?localfamily$/i) {
|
|
$lfamily = &_parse_localfamily($self, $args{$_});
|
|
}
|
|
elsif (/^-?localhost$/i) {
|
|
$args{$_} = "" unless defined $args{$_};
|
|
$localhost = $args{$_};
|
|
}
|
|
elsif (/^-?port$/i) {
|
|
$port = &_parse_port($self, $args{$_});
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $args{$_});
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given ",
|
|
"to " . ref($self) . "::open()");
|
|
}
|
|
}
|
|
}
|
|
|
|
## Get hostname/ip address.
|
|
$host = $self->host;
|
|
|
|
## Ensure we're already closed.
|
|
$self->close;
|
|
|
|
## Connect with or without a timeout.
|
|
if (defined($timeout) and &_have_alarm) { # use a timeout
|
|
## Convert possible absolute timeout to relative timeout.
|
|
if ($timeout >= $^T) { # it's an absolute time
|
|
$timeout = $timeout - time;
|
|
}
|
|
|
|
## Ensure a valid timeout value for alarm.
|
|
if ($timeout < 1) {
|
|
$timeout = 1;
|
|
}
|
|
$timeout = int($timeout + 0.5);
|
|
|
|
## Connect to server, timing out if it takes too long.
|
|
eval {
|
|
## Turn on timer.
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
local $SIG{ALRM} = sub { die "timed-out\n" };
|
|
alarm $timeout;
|
|
|
|
if ($family eq "ipv4") {
|
|
## Lookup server's IP address.
|
|
$ip_addr = inet_aton $host
|
|
or die "unknown remote host: $host\n";
|
|
$af = AF_INET;
|
|
$remote_addr = sockaddr_in($port, $ip_addr);
|
|
}
|
|
else { # family is "ipv6" or "any"
|
|
## Lookup server's IP address.
|
|
$flags_hint = $family eq "any" ? $AI_ADDRCONFIG : 0;
|
|
($err, @ai) = Socket::getaddrinfo($host, $port,
|
|
{ socktype => SOCK_STREAM,
|
|
"family" => $af{$family},
|
|
"flags" => $flags_hint });
|
|
if ($err == $EAI_BADFLAGS) {
|
|
## Try again with no flags.
|
|
($err, @ai) = Socket::getaddrinfo($host, $port,
|
|
{socktype => SOCK_STREAM,
|
|
"family"=> $af{$family},
|
|
"flags" => 0 });
|
|
}
|
|
die "unknown remote host: $host: $err\n"
|
|
if $err or !@ai;
|
|
$af = $ai[0]{"family"};
|
|
$remote_addr = $ai[0]{addr};
|
|
}
|
|
|
|
## Create a socket and attach the filehandle to it.
|
|
socket $self, $af, SOCK_STREAM, 0
|
|
or die "problem creating socket: $!\n";
|
|
|
|
## Bind to a local network interface.
|
|
if (length $localhost) {
|
|
if ($lfamily eq "ipv4") {
|
|
## Lookup server's IP address.
|
|
$ip_addr = inet_aton $localhost
|
|
or die "unknown local host: $localhost\n";
|
|
$local_addr = sockaddr_in(0, $ip_addr);
|
|
}
|
|
else { # local family is "ipv6" or "any"
|
|
## Lookup local IP address.
|
|
($err, @ai) = Socket::getaddrinfo($localhost, 0,
|
|
{socktype => SOCK_STREAM,
|
|
"family"=>$af{$lfamily},
|
|
"flags" => 0 });
|
|
die "unknown local host: $localhost: $err\n"
|
|
if $err or !@ai;
|
|
$local_addr = $ai[0]{addr};
|
|
}
|
|
|
|
bind $self, $local_addr
|
|
or die "problem binding to \"$localhost\": $!\n";
|
|
}
|
|
|
|
## Open connection to server.
|
|
connect $self, $remote_addr
|
|
or die "problem connecting to \"$host\", port $port: $!\n";
|
|
};
|
|
alarm 0;
|
|
|
|
## Check for error.
|
|
if ($@ =~ /^timed-out$/) { # time out failure
|
|
$s->{timedout} = 1;
|
|
$self->close;
|
|
if (!$remote_addr) {
|
|
return $self->error("unknown remote host: $host: ",
|
|
"name lookup timed-out");
|
|
}
|
|
elsif (length($localhost) and !$local_addr) {
|
|
return $self->error("unknown local host: $localhost: ",
|
|
"name lookup timed-out");
|
|
}
|
|
else {
|
|
return $self->error("problem connecting to \"$host\", ",
|
|
"port $port: connect timed-out");
|
|
}
|
|
}
|
|
elsif ($@) { # hostname lookup or connect failure
|
|
$self->close;
|
|
chomp $@;
|
|
return $self->error($@);
|
|
}
|
|
}
|
|
else { # don't use a timeout
|
|
$timeout = undef;
|
|
|
|
if ($family eq "ipv4") {
|
|
## Lookup server's IP address.
|
|
$ip_addr = inet_aton $host
|
|
or return $self->error("unknown remote host: $host");
|
|
$af = AF_INET;
|
|
$remote_addr = sockaddr_in($port, $ip_addr);
|
|
}
|
|
else { # family is "ipv6" or "any"
|
|
## Lookup server's IP address.
|
|
$flags_hint = $family eq "any" ? $AI_ADDRCONFIG : 0;
|
|
($err, @ai) = Socket::getaddrinfo($host, $port,
|
|
{ socktype => SOCK_STREAM,
|
|
"family" => $af{$family},
|
|
"flags" => $flags_hint });
|
|
if ($err == $EAI_BADFLAGS) {
|
|
## Try again with no flags.
|
|
($err, @ai) = Socket::getaddrinfo($host, $port,
|
|
{ socktype => SOCK_STREAM,
|
|
"family"=> $af{$family},
|
|
"flags" => 0 });
|
|
}
|
|
return $self->error("unknown remote host: $host")
|
|
if $err or !@ai;
|
|
$af = $ai[0]{"family"};
|
|
$remote_addr = $ai[0]{addr};
|
|
}
|
|
|
|
## Create a socket and attach the filehandle to it.
|
|
socket $self, $af, SOCK_STREAM, 0
|
|
or return $self->error("problem creating socket: $!");
|
|
|
|
## Bind to a local network interface.
|
|
if (length $localhost) {
|
|
if ($lfamily eq "ipv4") {
|
|
## Lookup server's IP address.
|
|
$ip_addr = inet_aton $localhost
|
|
or return $self->error("unknown local host: $localhost");
|
|
$local_addr = sockaddr_in(0, $ip_addr);
|
|
}
|
|
else { # local family is "ipv6" or "any"
|
|
## Lookup local IP address.
|
|
($err, @ai) = Socket::getaddrinfo($localhost, 0,
|
|
{ socktype => SOCK_STREAM,
|
|
"family"=>$af{$lfamily},
|
|
"flags" => 0 });
|
|
return $self->error("unknown local host: $localhost: $err")
|
|
if $err or !@ai;
|
|
$local_addr = $ai[0]{addr};
|
|
}
|
|
|
|
bind $self, $local_addr
|
|
or return $self->error("problem binding ",
|
|
"to \"$localhost\": $!");
|
|
}
|
|
|
|
## Open connection to server.
|
|
connect $self, $remote_addr
|
|
or do {
|
|
$errno = "$!";
|
|
$self->close;
|
|
return $self->error("problem connecting to \"$host\", ",
|
|
"port $port: $errno");
|
|
};
|
|
}
|
|
|
|
select((select($self), $|=1)[$[]); # don't buffer writes
|
|
$s->{blksize} = &_optimal_blksize((stat $self)[11]);
|
|
$s->{buf} = "";
|
|
$s->{eofile} = '';
|
|
$s->{errormsg} = "";
|
|
vec($s->{fdmask}='', fileno($self), 1) = 1;
|
|
$s->{last_line} = "";
|
|
$s->{sock_family} = $af;
|
|
$s->{num_wrote} = 0;
|
|
$s->{opened} = 1;
|
|
$s->{pending_errormsg} = "";
|
|
$s->{pushback_buf} = "";
|
|
$s->{select_supported} = 1;
|
|
$s->{timedout} = '';
|
|
$s->{unsent_opts} = "";
|
|
&_reset_options($s->{opts});
|
|
|
|
1;
|
|
} # end sub open
|
|
|
|
|
|
sub option_accept {
|
|
my ($self, @args) = @_;
|
|
my (
|
|
$arg,
|
|
$option,
|
|
$s,
|
|
@opt_args,
|
|
);
|
|
local $_;
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
|
|
## Parse the named args.
|
|
while (($_, $arg) = splice @args, 0, 2) {
|
|
## Verify and save arguments.
|
|
if (/^-?do$/i) {
|
|
## Make sure a callback is defined.
|
|
return $self->error("usage: an option callback must already ",
|
|
"be defined when enabling with $_")
|
|
unless $s->{opt_cback};
|
|
|
|
$option = &_verify_telopt_arg($self, $arg, $_);
|
|
return unless defined $option;
|
|
push @opt_args, { option => $option,
|
|
is_remote => '',
|
|
is_enable => 1,
|
|
};
|
|
}
|
|
elsif (/^-?dont$/i) {
|
|
$option = &_verify_telopt_arg($self, $arg, $_);
|
|
return unless defined $option;
|
|
push @opt_args, { option => $option,
|
|
is_remote => '',
|
|
is_enable => '',
|
|
};
|
|
}
|
|
elsif (/^-?will$/i) {
|
|
## Make sure a callback is defined.
|
|
return $self->error("usage: an option callback must already ",
|
|
"be defined when enabling with $_")
|
|
unless $s->{opt_cback};
|
|
|
|
$option = &_verify_telopt_arg($self, $arg, $_);
|
|
return unless defined $option;
|
|
push @opt_args, { option => $option,
|
|
is_remote => 1,
|
|
is_enable => 1,
|
|
};
|
|
}
|
|
elsif (/^-?wont$/i) {
|
|
$option = &_verify_telopt_arg($self, $arg, $_);
|
|
return unless defined $option;
|
|
push @opt_args, { option => $option,
|
|
is_remote => 1,
|
|
is_enable => '',
|
|
};
|
|
}
|
|
else {
|
|
return $self->error('usage: $obj->option_accept(' .
|
|
'[Do => $telopt,] ',
|
|
'[Dont => $telopt,] ',
|
|
'[Will => $telopt,] ',
|
|
'[Wont => $telopt,]');
|
|
}
|
|
}
|
|
|
|
## Set "receive ok" for options specified.
|
|
&_opt_accept($self, @opt_args);
|
|
} # end sub option_accept
|
|
|
|
|
|
sub option_callback {
|
|
my ($self, $callback) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{opt_cback};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $callback and ref($callback) eq "CODE") {
|
|
&_carp($self, "ignoring Option_callback argument because it's " .
|
|
"not a code ref");
|
|
$callback = $prev;
|
|
}
|
|
|
|
$s->{opt_cback} = $callback;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub option_callback
|
|
|
|
|
|
sub option_log {
|
|
my ($self, $name) = @_;
|
|
my (
|
|
$fh,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$fh = $s->{opt_log};
|
|
|
|
if (@_ >= 2) {
|
|
if (!defined($name) or $name eq "") { # input arg is ""
|
|
## Turn off logging.
|
|
$fh = "";
|
|
}
|
|
elsif (&_is_open_fh($name)) { # input arg is an open fh
|
|
## Use the open fh for logging.
|
|
$fh = $name;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
elsif (!ref $name) { # input arg is filename
|
|
## Open the file for logging.
|
|
$fh = &_fname_to_handle($self, $name)
|
|
or return;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
else {
|
|
return $self->error("bad Option_log argument ",
|
|
"\"$name\": not filename or open fh");
|
|
}
|
|
|
|
$s->{opt_log} = $fh;
|
|
}
|
|
|
|
$fh;
|
|
} # end sub option_log
|
|
|
|
|
|
sub option_state {
|
|
my ($self, $option) = @_;
|
|
my (
|
|
$opt_state,
|
|
$s,
|
|
%opt_state,
|
|
);
|
|
|
|
## Ensure telnet option is non-negative integer.
|
|
$option = &_verify_telopt_arg($self, $option);
|
|
return unless defined $option;
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
unless (defined $s->{opts}{$option}) {
|
|
&_set_default_option($s, $option);
|
|
}
|
|
|
|
## Return hashref to a copy of the values.
|
|
$opt_state = $s->{opts}{$option};
|
|
%opt_state = %$opt_state;
|
|
\%opt_state;
|
|
} # end sub option_state
|
|
|
|
|
|
## Make ors() synonymous with output_record_separator().
|
|
sub ors { &output_record_separator; }
|
|
|
|
|
|
sub output_field_separator {
|
|
my ($self, $ofs) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{"ofs"};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $ofs) {
|
|
$ofs = "";
|
|
}
|
|
|
|
$s->{"ofs"} = $ofs;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub output_field_separator
|
|
|
|
|
|
sub output_log {
|
|
my ($self, $name) = @_;
|
|
my (
|
|
$fh,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$fh = $s->{outputlog};
|
|
|
|
if (@_ >= 2) {
|
|
if (!defined($name) or $name eq "") { # input arg is ""
|
|
## Turn off logging.
|
|
$fh = "";
|
|
}
|
|
elsif (&_is_open_fh($name)) { # input arg is an open fh
|
|
## Use the open fh for logging.
|
|
$fh = $name;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
elsif (!ref $name) { # input arg is filename
|
|
## Open the file for logging.
|
|
$fh = &_fname_to_handle($self, $name)
|
|
or return;
|
|
select((select($fh), $|=1)[$[]); # don't buffer writes
|
|
}
|
|
else {
|
|
return $self->error("bad Output_log argument ",
|
|
"\"$name\": not filename or open fh");
|
|
}
|
|
|
|
$s->{outputlog} = $fh;
|
|
}
|
|
|
|
$fh;
|
|
} # end sub output_log
|
|
|
|
|
|
sub output_record_separator {
|
|
my ($self, $ors) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{"ors"};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $ors) {
|
|
$ors = "";
|
|
}
|
|
|
|
$s->{"ors"} = $ors;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub output_record_separator
|
|
|
|
|
|
sub peerhost {
|
|
my ($self) = @_;
|
|
my (
|
|
$host,
|
|
$sockaddr,
|
|
);
|
|
local $^W = ''; # avoid closed socket warning from getpeername()
|
|
|
|
## Get packed sockaddr struct of remote side and then unpack it.
|
|
$sockaddr = getpeername $self
|
|
or return "";
|
|
(undef, $host) = $self->_unpack_sockaddr($sockaddr);
|
|
|
|
$host;
|
|
} # end sub peerhost
|
|
|
|
|
|
sub peerport {
|
|
my ($self) = @_;
|
|
my (
|
|
$port,
|
|
$sockaddr,
|
|
);
|
|
local $^W = ''; # avoid closed socket warning from getpeername()
|
|
|
|
## Get packed sockaddr struct of remote side and then unpack it.
|
|
$sockaddr = getpeername $self
|
|
or return "";
|
|
($port) = $self->_unpack_sockaddr($sockaddr);
|
|
|
|
$port;
|
|
} # end sub peerport
|
|
|
|
|
|
sub port {
|
|
my ($self, $port) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
$service,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{port};
|
|
|
|
if (@_ >= 2) {
|
|
$port = &_parse_port($self, $port)
|
|
or return;
|
|
|
|
$s->{port} = $port;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub port
|
|
|
|
|
|
sub print {
|
|
my ($self) = shift;
|
|
my (
|
|
$buf,
|
|
$fh,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$s->{timedout} = '';
|
|
return $self->error("write error: filehandle isn't open")
|
|
unless $s->{opened};
|
|
|
|
## Add field and record separators.
|
|
$buf = join($s->{"ofs"}, @_) . $s->{"ors"};
|
|
|
|
## Log the output if requested.
|
|
if ($s->{outputlog}) {
|
|
&_log_print($s->{outputlog}, $buf);
|
|
}
|
|
|
|
## Convert native newlines to CR LF.
|
|
if (!$s->{bin_mode}) {
|
|
$buf =~ s(\n)(\015\012)g;
|
|
}
|
|
|
|
## Escape TELNET IAC and also CR not followed by LF.
|
|
if ($s->{telnet_mode}) {
|
|
$buf =~ s(\377)(\377\377)g;
|
|
&_escape_cr(\$buf);
|
|
}
|
|
|
|
&_put($self, \$buf, "print");
|
|
} # end sub print
|
|
|
|
|
|
sub print_length {
|
|
my ($self) = @_;
|
|
|
|
*$self->{net_telnet}{num_wrote};
|
|
} # end sub print_length
|
|
|
|
|
|
sub prompt {
|
|
my ($self, $prompt) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{cmd_prompt};
|
|
|
|
## Parse args.
|
|
if (@_ == 2) {
|
|
$prompt = &_parse_prompt($self, $prompt)
|
|
or return;
|
|
|
|
$s->{cmd_prompt} = $prompt;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub prompt
|
|
|
|
|
|
sub put {
|
|
my ($self) = @_;
|
|
my (
|
|
$binmode,
|
|
$buf,
|
|
$errmode,
|
|
$is_timeout_arg,
|
|
$s,
|
|
$telnetmode,
|
|
$timeout,
|
|
%args,
|
|
);
|
|
local $_;
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
$s->{timedout} = '';
|
|
|
|
## Parse args.
|
|
if (@_ == 2) { # one positional arg given
|
|
$buf = $_[1];
|
|
}
|
|
elsif (@_ > 2) { # named args given
|
|
## Get the named args.
|
|
(undef, %args) = @_;
|
|
|
|
## Parse the named args.
|
|
foreach (keys %args) {
|
|
if (/^-?binmode$/i) {
|
|
$binmode = $args{$_};
|
|
unless (defined $binmode) {
|
|
$binmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?errmode$/i) {
|
|
$errmode = &_parse_errmode($self, $args{$_});
|
|
}
|
|
elsif (/^-?string$/i) {
|
|
$buf = $args{$_};
|
|
}
|
|
elsif (/^-?telnetmode$/i) {
|
|
$telnetmode = $args{$_};
|
|
unless (defined $telnetmode) {
|
|
$telnetmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $args{$_});
|
|
$is_timeout_arg = 1;
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given ",
|
|
"to " . ref($self) . "::put()");
|
|
}
|
|
}
|
|
}
|
|
|
|
## If any args given, override corresponding instance data.
|
|
local $s->{bin_mode} = $binmode
|
|
if defined $binmode;
|
|
local $s->{errormode} = $errmode
|
|
if defined $errmode;
|
|
local $s->{telnet_mode} = $telnetmode
|
|
if defined $telnetmode;
|
|
local $s->{time_out} = $timeout
|
|
if defined $is_timeout_arg;
|
|
|
|
## Check for errors.
|
|
return $self->error("write error: filehandle isn't open")
|
|
unless $s->{opened};
|
|
|
|
## Log the output if requested.
|
|
if ($s->{outputlog}) {
|
|
&_log_print($s->{outputlog}, $buf);
|
|
}
|
|
|
|
## Convert native newlines to CR LF.
|
|
if (!$s->{bin_mode}) {
|
|
$buf =~ s(\n)(\015\012)g;
|
|
}
|
|
|
|
## Escape TELNET IAC and also CR not followed by LF.
|
|
if ($s->{telnet_mode}) {
|
|
$buf =~ s(\377)(\377\377)g;
|
|
&_escape_cr(\$buf);
|
|
}
|
|
|
|
&_put($self, \$buf, "put");
|
|
} # end sub put
|
|
|
|
|
|
## Make rs() synonymous input_record_separator().
|
|
sub rs { &input_record_separator; }
|
|
|
|
|
|
sub sockfamily {
|
|
my ($self) = @_;
|
|
my $s = *$self->{net_telnet};
|
|
my $sockfamily = "";
|
|
|
|
if ($s->{sock_family} == AF_INET) {
|
|
$sockfamily = "ipv4";
|
|
}
|
|
elsif (defined($AF_INET6) and $s->{sock_family} == $AF_INET6) {
|
|
$sockfamily = "ipv6";
|
|
}
|
|
|
|
$sockfamily;
|
|
} # end sub sockfamily
|
|
|
|
|
|
sub sockhost {
|
|
my ($self) = @_;
|
|
my (
|
|
$host,
|
|
$sockaddr,
|
|
);
|
|
local $^W = ''; # avoid closed socket warning from getsockname()
|
|
|
|
## Get packed sockaddr struct of local side and then unpack it.
|
|
$sockaddr = getsockname $self
|
|
or return "";
|
|
(undef, $host) = $self->_unpack_sockaddr($sockaddr);
|
|
|
|
$host;
|
|
} # end sub sockhost
|
|
|
|
|
|
sub sockport {
|
|
my ($self) = @_;
|
|
my (
|
|
$port,
|
|
$sockaddr,
|
|
);
|
|
local $^W = ''; # avoid closed socket warning from getsockname()
|
|
|
|
## Get packed sockaddr struct of local side and then unpack it.
|
|
$sockaddr = getsockname $self
|
|
or return "";
|
|
($port) = $self->_unpack_sockaddr($sockaddr);
|
|
|
|
$port;
|
|
} # end sub sockport
|
|
|
|
|
|
sub suboption_callback {
|
|
my ($self, $callback) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{subopt_cback};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $callback and ref($callback) eq "CODE") {
|
|
&_carp($self,"ignoring Suboption_callback argument because it's " .
|
|
"not a code ref");
|
|
$callback = $prev;
|
|
}
|
|
|
|
$s->{subopt_cback} = $callback;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub suboption_callback
|
|
|
|
|
|
sub telnetmode {
|
|
my ($self, $mode) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{telnet_mode};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $mode) {
|
|
$mode = 0;
|
|
}
|
|
|
|
$s->{telnet_mode} = $mode;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub telnetmode
|
|
|
|
|
|
sub timed_out {
|
|
my ($self, $value) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{timedout};
|
|
|
|
if (@_ >= 2) {
|
|
unless (defined $value) {
|
|
$value = "";
|
|
}
|
|
|
|
$s->{timedout} = $value;
|
|
}
|
|
|
|
$prev;
|
|
} # end sub timed_out
|
|
|
|
|
|
sub timeout {
|
|
my ($self, $timeout) = @_;
|
|
my (
|
|
$prev,
|
|
$s,
|
|
);
|
|
|
|
$s = *$self->{net_telnet};
|
|
$prev = $s->{time_out};
|
|
|
|
if (@_ >= 2) {
|
|
$s->{time_out} = &_parse_timeout($self, $timeout);
|
|
}
|
|
|
|
$prev;
|
|
} # end sub timeout
|
|
|
|
|
|
sub waitfor {
|
|
my ($self, @args) = @_;
|
|
my (
|
|
$arg,
|
|
$binmode,
|
|
$endtime,
|
|
$errmode,
|
|
$len,
|
|
$match,
|
|
$match_op,
|
|
$pos,
|
|
$prematch,
|
|
$s,
|
|
$search,
|
|
$search_cond,
|
|
$telnetmode,
|
|
$timeout,
|
|
@match_cond,
|
|
@match_ops,
|
|
@search_cond,
|
|
@string_cond,
|
|
@warns,
|
|
);
|
|
local $@;
|
|
local $_;
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
$s->{timedout} = '';
|
|
return if $s->{eofile};
|
|
return unless @args;
|
|
$timeout = $s->{time_out};
|
|
|
|
## Code template used to build string match conditional.
|
|
## Values between array elements must be supplied later.
|
|
@string_cond =
|
|
('if (($pos = index $s->{buf}, ', ') > -1) {
|
|
$len = ', ';
|
|
$prematch = substr $s->{buf}, 0, $pos;
|
|
$match = substr $s->{buf}, $pos, $len;
|
|
substr($s->{buf}, 0, $pos + $len) = "";
|
|
last;
|
|
}');
|
|
|
|
## Code template used to build pattern match conditional.
|
|
## Values between array elements must be supplied later.
|
|
@match_cond =
|
|
('if ($s->{buf} =~ ', ') {
|
|
$prematch = $`;
|
|
$match = $&;
|
|
substr($s->{buf}, 0, length($`) + length($&)) = "";
|
|
last;
|
|
}');
|
|
|
|
## Parse args.
|
|
if (@_ == 2) { # one positional arg given
|
|
$arg = $_[1];
|
|
|
|
## Fill in the blanks in the code template.
|
|
push @match_ops, $arg;
|
|
push @search_cond, join("", $match_cond[0], $arg, $match_cond[1]);
|
|
}
|
|
elsif (@_ > 2) { # named args given
|
|
## Parse the named args.
|
|
while (($_, $arg) = splice @args, 0, 2) {
|
|
if (/^-?binmode$/i) {
|
|
$binmode = $arg;
|
|
unless (defined $binmode) {
|
|
$binmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?errmode$/i) {
|
|
$errmode = &_parse_errmode($self, $arg);
|
|
}
|
|
elsif (/^-?match$/i) {
|
|
## Fill in the blanks in the code template.
|
|
push @match_ops, $arg;
|
|
push @search_cond, join("",
|
|
$match_cond[0], $arg, $match_cond[1]);
|
|
}
|
|
elsif (/^-?string$/i) {
|
|
## Fill in the blanks in the code template.
|
|
$arg =~ s/'/\\'/g; # quote ticks
|
|
push @search_cond, join("",
|
|
$string_cond[0], "'$arg'",
|
|
$string_cond[1], length($arg),
|
|
$string_cond[2]);
|
|
}
|
|
elsif (/^-?telnetmode$/i) {
|
|
$telnetmode = $arg;
|
|
unless (defined $telnetmode) {
|
|
$telnetmode = 0;
|
|
}
|
|
}
|
|
elsif (/^-?timeout$/i) {
|
|
$timeout = &_parse_timeout($self, $arg);
|
|
}
|
|
else {
|
|
&_croak($self, "bad named parameter \"$_\" given " .
|
|
"to " . ref($self) . "::waitfor()");
|
|
}
|
|
}
|
|
}
|
|
|
|
## If any args given, override corresponding instance data.
|
|
local $s->{errormode} = $errmode
|
|
if defined $errmode;
|
|
local $s->{bin_mode} = $binmode
|
|
if defined $binmode;
|
|
local $s->{telnet_mode} = $telnetmode
|
|
if defined $telnetmode;
|
|
|
|
## Check for bad match operator argument.
|
|
foreach $match_op (@match_ops) {
|
|
return $self->error("missing opening delimiter of match operator ",
|
|
"in argument \"$match_op\" given to ",
|
|
ref($self) . "::waitfor()")
|
|
unless $match_op =~ m(^\s*/) or $match_op =~ m(^\s*m\s*\W);
|
|
}
|
|
|
|
## Construct conditional to check for requested string and pattern matches.
|
|
## Turn subsequent "if"s into "elsif".
|
|
$search_cond = join "\n\tels", @search_cond;
|
|
|
|
## Construct loop to fill buffer until string/pattern, timeout, or eof.
|
|
$search = join "", "
|
|
while (1) {\n\t",
|
|
$search_cond, '
|
|
&_fillbuf($self, $s, $endtime)
|
|
or do {
|
|
last if $s->{timedout};
|
|
$self->close;
|
|
last;
|
|
};
|
|
}';
|
|
|
|
## Set wall time when we timeout.
|
|
$endtime = &_endtime($timeout);
|
|
|
|
## Run the loop.
|
|
{
|
|
local $^W = 1;
|
|
local $SIG{"__WARN__"} = sub { push @warns, @_ };
|
|
local $s->{errormode} = "return";
|
|
$s->{errormsg} = "";
|
|
eval $search;
|
|
}
|
|
|
|
## Check for failure.
|
|
return $self->error("pattern match timed-out") if $s->{timedout};
|
|
return $self->error($s->{errormsg}) if $s->{errormsg} ne "";
|
|
return $self->error("pattern match read eof") if $s->{eofile};
|
|
|
|
## Check for Perl syntax errors or warnings.
|
|
if ($@ or @warns) {
|
|
foreach $match_op (@match_ops) {
|
|
&_match_check($self, $match_op)
|
|
or return;
|
|
}
|
|
return $self->error($@) if $@;
|
|
return $self->error(@warns) if @warns;
|
|
}
|
|
|
|
wantarray ? ($prematch, $match) : 1;
|
|
} # end sub waitfor
|
|
|
|
|
|
######################## Private Subroutines #########################
|
|
|
|
|
|
sub _append_lineno {
|
|
my ($obj, @msgs) = @_;
|
|
my (
|
|
$file,
|
|
$line,
|
|
$pkg,
|
|
);
|
|
|
|
## Find the caller that's not in object's class or one of its base classes.
|
|
($pkg, $file , $line) = &_user_caller($obj);
|
|
join("", @msgs, " at ", $file, " line ", $line, "\n");
|
|
} # end sub _append_lineno
|
|
|
|
|
|
sub _carp {
|
|
my ($self) = @_;
|
|
my $s = *$self->{net_telnet};
|
|
|
|
$s->{errormsg} = &_append_lineno(@_);
|
|
warn $s->{errormsg}, "\n";
|
|
} # end sub _carp
|
|
|
|
|
|
sub _croak {
|
|
my ($self) = @_;
|
|
my $s = *$self->{net_telnet};
|
|
|
|
$s->{errormsg} = &_append_lineno(@_);
|
|
die $s->{errormsg}, "\n";
|
|
} # end sub _croak
|
|
|
|
|
|
sub _endtime {
|
|
my ($interval) = @_;
|
|
|
|
## Compute wall time when timeout occurs.
|
|
if (defined $interval) {
|
|
if ($interval >= $^T) { # it's already an absolute time
|
|
return $interval;
|
|
}
|
|
elsif ($interval > 0) { # it's relative to the current time
|
|
return int($interval + time + 0.5);
|
|
}
|
|
else { # it's a one time poll
|
|
return 0;
|
|
}
|
|
}
|
|
else { # there's no timeout
|
|
return undef;
|
|
}
|
|
} # end sub _endtime
|
|
|
|
|
|
sub _errno_include {
|
|
local $@;
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
|
|
eval "require Errno";
|
|
} # end sub errno_include
|
|
|
|
|
|
sub _escape_cr {
|
|
my ($string) = @_;
|
|
my (
|
|
$nextchar,
|
|
);
|
|
my $pos = 0;
|
|
|
|
## Convert all CR (not followed by LF) to CR NULL.
|
|
while (($pos = index($$string, "\015", $pos)) > -1) {
|
|
$nextchar = substr $$string, $pos + 1, 1;
|
|
|
|
substr($$string, $pos, 1) = "\015\000"
|
|
unless $nextchar eq "\012";
|
|
|
|
$pos++;
|
|
}
|
|
|
|
1;
|
|
} # end sub _escape_cr
|
|
|
|
|
|
sub _extract_arg_errmode {
|
|
my ($self, $args) = @_;
|
|
my (
|
|
%args,
|
|
);
|
|
local $_;
|
|
my $errmode = '';
|
|
|
|
## Check for named parameters.
|
|
return '' unless @$args >= 2;
|
|
|
|
## Rebuild args without errmode parameter.
|
|
%args = @$args;
|
|
@$args = ();
|
|
|
|
## Extract errmode arg.
|
|
foreach (keys %args) {
|
|
if (/^-?errmode$/i) {
|
|
$errmode = &_parse_errmode($self, $args{$_});
|
|
}
|
|
else {
|
|
push @$args, $_, $args{$_};
|
|
}
|
|
}
|
|
|
|
$errmode;
|
|
} # end sub _extract_arg_errmode
|
|
|
|
|
|
sub _fillbuf {
|
|
my ($self, $s, $endtime) = @_;
|
|
my (
|
|
$msg,
|
|
$nfound,
|
|
$nread,
|
|
$pushback_len,
|
|
$read_pos,
|
|
$ready,
|
|
$timed_out,
|
|
$timeout,
|
|
$unparsed_pos,
|
|
);
|
|
|
|
## If error from last read not yet reported then do it now.
|
|
if ($s->{pending_errormsg}) {
|
|
$msg = $s->{pending_errormsg};
|
|
$s->{pending_errormsg} = "";
|
|
return $self->error($msg);
|
|
}
|
|
|
|
return unless $s->{opened};
|
|
|
|
while (1) {
|
|
## Maximum buffer size exceeded?
|
|
return $self->error("maximum input buffer length exceeded: ",
|
|
$s->{maxbufsize}, " bytes")
|
|
unless length($s->{buf}) <= $s->{maxbufsize};
|
|
|
|
## Determine how long to wait for input ready.
|
|
($timed_out, $timeout) = &_timeout_interval($endtime);
|
|
if ($timed_out) {
|
|
$s->{timedout} = 1;
|
|
return $self->error("read timed-out");
|
|
}
|
|
|
|
## Wait for input ready.
|
|
$nfound = select $ready=$s->{fdmask}, "", "", $timeout;
|
|
|
|
## Handle any errors while waiting.
|
|
if ((!defined $nfound or $nfound <= 0) and $s->{select_supported}) {
|
|
if (defined $nfound and $nfound == 0) { # timed-out
|
|
$s->{timedout} = 1;
|
|
return $self->error("read timed-out");
|
|
}
|
|
else { # error waiting for input ready
|
|
if (defined $EINTR) {
|
|
next if $! == $EINTR; # restart select()
|
|
}
|
|
else {
|
|
next if $! =~ /^interrupted/i; # restart select()
|
|
}
|
|
|
|
$s->{opened} = '';
|
|
return $self->error("read error: $!");
|
|
}
|
|
}
|
|
|
|
## Append to buffer any partially processed telnet or CR sequence.
|
|
$pushback_len = length $s->{pushback_buf};
|
|
if ($pushback_len) {
|
|
$s->{buf} .= $s->{pushback_buf};
|
|
$s->{pushback_buf} = "";
|
|
}
|
|
|
|
## Read the waiting data.
|
|
$read_pos = length $s->{buf};
|
|
$unparsed_pos = $read_pos - $pushback_len;
|
|
$nread = sysread $self, $s->{buf}, $s->{blksize}, $read_pos;
|
|
|
|
## Handle any read errors.
|
|
if (!defined $nread) { # read failed
|
|
if (defined $EINTR) {
|
|
next if $! == $EINTR; # restart sysread()
|
|
}
|
|
else {
|
|
next if $! =~ /^interrupted/i; # restart sysread()
|
|
}
|
|
|
|
$s->{opened} = '';
|
|
return $self->error("read error: $!");
|
|
}
|
|
|
|
## Handle eof.
|
|
if ($nread == 0) { # eof read
|
|
$s->{opened} = '';
|
|
return;
|
|
}
|
|
|
|
## Display network traffic if requested.
|
|
if ($s->{dumplog}) {
|
|
&_log_dump('<', $s->{dumplog}, \$s->{buf}, $read_pos);
|
|
}
|
|
|
|
## Process any telnet commands in the data stream.
|
|
if ($s->{telnet_mode} and index($s->{buf},"\377",$unparsed_pos) > -1) {
|
|
&_interpret_tcmd($self, $s, $unparsed_pos);
|
|
}
|
|
|
|
## Process any carriage-return sequences in the data stream.
|
|
&_interpret_cr($s, $unparsed_pos);
|
|
|
|
## Read again if all chars read were consumed as telnet cmds.
|
|
next if $unparsed_pos >= length $s->{buf};
|
|
|
|
## Log the input if requested.
|
|
if ($s->{inputlog}) {
|
|
&_log_print($s->{inputlog}, substr($s->{buf}, $unparsed_pos));
|
|
}
|
|
|
|
## Save the last line read.
|
|
&_save_lastline($s);
|
|
|
|
## We've successfully read some data into the buffer.
|
|
last;
|
|
} # end while(1)
|
|
|
|
1;
|
|
} # end sub _fillbuf
|
|
|
|
|
|
sub _flush_opts {
|
|
my ($self) = @_;
|
|
my (
|
|
$option_chars,
|
|
);
|
|
my $s = *$self->{net_telnet};
|
|
|
|
## Get option and clear the output buf.
|
|
$option_chars = $s->{unsent_opts};
|
|
$s->{unsent_opts} = "";
|
|
|
|
## Try to send options without waiting.
|
|
{
|
|
local $s->{errormode} = "return";
|
|
local $s->{time_out} = 0;
|
|
&_put($self, \$option_chars, "telnet option negotiation")
|
|
or do {
|
|
## Save chars not printed for later.
|
|
substr($option_chars, 0, $self->print_length) = "";
|
|
$s->{unsent_opts} .= $option_chars;
|
|
};
|
|
}
|
|
|
|
1;
|
|
} # end sub _flush_opts
|
|
|
|
|
|
sub _fname_to_handle {
|
|
my ($self, $filename) = @_;
|
|
my (
|
|
$fh,
|
|
);
|
|
no strict "refs";
|
|
|
|
$fh = &_new_handle();
|
|
CORE::open $fh, "> $filename"
|
|
or return $self->error("problem creating $filename: $!");
|
|
|
|
$fh;
|
|
} # end sub _fname_to_handle
|
|
|
|
|
|
sub _have_alarm {
|
|
local $@;
|
|
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
local $SIG{ALRM} = sub { die };
|
|
alarm 0;
|
|
};
|
|
|
|
! $@;
|
|
} # end sub _have_alarm
|
|
|
|
|
|
sub _import_af_inet6 {
|
|
local $@;
|
|
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
|
|
Socket::AF_INET6();
|
|
};
|
|
} # end sub _import_af_inet6
|
|
|
|
|
|
sub _import_af_unspec {
|
|
local $@;
|
|
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
|
|
Socket::AF_UNSPEC();
|
|
};
|
|
} # end sub _import_af_unspec
|
|
|
|
|
|
sub _import_ai_addrconfig {
|
|
local $@;
|
|
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
|
|
Socket::AI_ADDRCONFIG();
|
|
};
|
|
} # end sub _import_ai_addrconfig
|
|
|
|
|
|
sub _import_eai_badflags {
|
|
local $@;
|
|
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
|
|
Socket::EAI_BADFLAGS();
|
|
};
|
|
} # end sub _import_eai_badflags
|
|
|
|
|
|
sub _import_eintr {
|
|
local $@;
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
|
|
eval "require Errno; Errno::EINTR();";
|
|
} # end sub _import_eintr
|
|
|
|
|
|
sub _interpret_cr {
|
|
my ($s, $pos) = @_;
|
|
my (
|
|
$nextchar,
|
|
);
|
|
|
|
while (($pos = index($s->{buf}, "\015", $pos)) > -1) {
|
|
$nextchar = substr($s->{buf}, $pos + 1, 1);
|
|
if ($nextchar eq "\0") {
|
|
## Convert CR NULL to CR when in telnet mode.
|
|
if ($s->{telnet_mode}) {
|
|
substr($s->{buf}, $pos + 1, 1) = "";
|
|
}
|
|
}
|
|
elsif ($nextchar eq "\012") {
|
|
## Convert CR LF to newline when not in binary mode.
|
|
if (!$s->{bin_mode}) {
|
|
substr($s->{buf}, $pos, 2) = "\n";
|
|
}
|
|
}
|
|
elsif (!length($nextchar) and ($s->{telnet_mode} or !$s->{bin_mode})) {
|
|
## Save CR in alt buffer for possible CR LF or CR NULL conversion.
|
|
$s->{pushback_buf} .= "\015";
|
|
chop $s->{buf};
|
|
}
|
|
|
|
$pos++;
|
|
}
|
|
|
|
1;
|
|
} # end sub _interpret_cr
|
|
|
|
|
|
sub _interpret_tcmd {
|
|
my ($self, $s, $offset) = @_;
|
|
my (
|
|
$callback,
|
|
$endpos,
|
|
$nextchar,
|
|
$option,
|
|
$parameters,
|
|
$pos,
|
|
$subcmd,
|
|
);
|
|
local $_;
|
|
|
|
## Parse telnet commands in the data stream.
|
|
$pos = $offset;
|
|
while (($pos = index $s->{buf}, "\377", $pos) > -1) { # unprocessed IAC
|
|
$nextchar = substr $s->{buf}, $pos + 1, 1;
|
|
|
|
## Save command if it's only partially read.
|
|
if (!length $nextchar) {
|
|
$s->{pushback_buf} .= "\377";
|
|
chop $s->{buf};
|
|
last;
|
|
}
|
|
|
|
if ($nextchar eq "\377") { # IAC is escaping "\377" char
|
|
## Remove escape char from data stream.
|
|
substr($s->{buf}, $pos, 1) = "";
|
|
$pos++;
|
|
}
|
|
elsif ($nextchar eq "\375" or $nextchar eq "\373" or
|
|
$nextchar eq "\374" or $nextchar eq "\376") { # opt negotiation
|
|
$option = substr $s->{buf}, $pos + 2, 1;
|
|
|
|
## Save command if it's only partially read.
|
|
if (!length $option) {
|
|
$s->{pushback_buf} .= "\377" . $nextchar;
|
|
chop $s->{buf};
|
|
chop $s->{buf};
|
|
last;
|
|
}
|
|
|
|
## Remove command from data stream.
|
|
substr($s->{buf}, $pos, 3) = "";
|
|
|
|
## Handle option negotiation.
|
|
&_negotiate_recv($self, $s, $nextchar, ord($option), $pos);
|
|
}
|
|
elsif ($nextchar eq "\372") { # start of subnegotiation parameters
|
|
## Save command if it's only partially read.
|
|
$endpos = index $s->{buf}, "\360", $pos;
|
|
if ($endpos == -1) {
|
|
$s->{pushback_buf} .= substr $s->{buf}, $pos;
|
|
substr($s->{buf}, $pos) = "";
|
|
last;
|
|
}
|
|
|
|
## Remove subnegotiation cmd from buffer.
|
|
$subcmd = substr($s->{buf}, $pos, $endpos - $pos + 1);
|
|
substr($s->{buf}, $pos, $endpos - $pos + 1) = "";
|
|
|
|
## Invoke subnegotiation callback.
|
|
if ($s->{subopt_cback} and length($subcmd) >= 5) {
|
|
$option = unpack "C", substr($subcmd, 2, 1);
|
|
if (length($subcmd) >= 6) {
|
|
$parameters = substr $subcmd, 3, length($subcmd) - 5;
|
|
}
|
|
else {
|
|
$parameters = "";
|
|
}
|
|
|
|
$callback = $s->{subopt_cback};
|
|
&$callback($self, $option, $parameters);
|
|
}
|
|
}
|
|
else { # various two char telnet commands
|
|
## Ignore and remove command from data stream.
|
|
substr($s->{buf}, $pos, 2) = "";
|
|
}
|
|
}
|
|
|
|
## Try to send any waiting option negotiation.
|
|
if (length $s->{unsent_opts}) {
|
|
&_flush_opts($self);
|
|
}
|
|
|
|
1;
|
|
} # end sub _interpret_tcmd
|
|
|
|
|
|
sub _io_socket_include {
|
|
local $@;
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
|
|
eval "require IO::Socket";
|
|
} # end sub io_socket_include
|
|
|
|
|
|
sub _is_open_fh {
|
|
my ($fh) = @_;
|
|
my $is_open = '';
|
|
local $@;
|
|
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
$is_open = defined(fileno $fh);
|
|
};
|
|
|
|
$is_open;
|
|
} # end sub _is_open_fh
|
|
|
|
|
|
sub _log_dump {
|
|
my ($direction, $fh, $data, $offset, $len) = @_;
|
|
my (
|
|
$addr,
|
|
$hexvals,
|
|
$line,
|
|
);
|
|
|
|
$addr = 0;
|
|
$len = length($$data) - $offset
|
|
if !defined $len;
|
|
return 1 if $len <= 0;
|
|
|
|
## Print data in dump format.
|
|
while ($len > 0) {
|
|
## Convert up to the next 16 chars to hex, padding w/ spaces.
|
|
if ($len >= 16) {
|
|
$line = substr $$data, $offset, 16;
|
|
}
|
|
else {
|
|
$line = substr $$data, $offset, $len;
|
|
}
|
|
$hexvals = unpack("H*", $line);
|
|
$hexvals .= ' ' x (32 - length $hexvals);
|
|
|
|
## Place in 16 columns, each containing two hex digits.
|
|
$hexvals = sprintf("%s %s %s %s " x 4,
|
|
unpack("a2" x 16, $hexvals));
|
|
|
|
## For the ASCII column, change unprintable chars to a period.
|
|
$line =~ s/[\000-\037,\177-\237]/./g;
|
|
|
|
## Print the line in dump format.
|
|
&_log_print($fh, sprintf("%s 0x%5.5lx: %s%s\n",
|
|
$direction, $addr, $hexvals, $line));
|
|
|
|
$addr += 16;
|
|
$offset += 16;
|
|
$len -= 16;
|
|
}
|
|
|
|
&_log_print($fh, "\n");
|
|
|
|
1;
|
|
} # end sub _log_dump
|
|
|
|
|
|
sub _log_option {
|
|
my ($fh, $direction, $request, $option) = @_;
|
|
my (
|
|
$name,
|
|
);
|
|
|
|
if ($option >= 0 and $option <= $#Telopts) {
|
|
$name = $Telopts[$option];
|
|
}
|
|
else {
|
|
$name = $option;
|
|
}
|
|
|
|
&_log_print($fh, "$direction $request $name\n");
|
|
} # end sub _log_option
|
|
|
|
|
|
sub _log_print {
|
|
my ($fh, $buf) = @_;
|
|
local $\ = '';
|
|
|
|
if (ref($fh) eq "GLOB") { # fh is GLOB ref
|
|
print $fh $buf;
|
|
}
|
|
else { # fh isn't GLOB ref
|
|
$fh->print($buf);
|
|
}
|
|
} # end sub _log_print
|
|
|
|
|
|
sub _match_check {
|
|
my ($self, $code) = @_;
|
|
my $error;
|
|
my @warns = ();
|
|
local $@;
|
|
|
|
## Use eval to check for syntax errors or warnings.
|
|
{
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
local $SIG{"__WARN__"} = sub { push @warns, @_ };
|
|
local $^W = 1;
|
|
local $_ = '';
|
|
eval "\$_ =~ $code;";
|
|
}
|
|
if ($@) {
|
|
## Remove useless lines numbers from message.
|
|
($error = $@) =~ s/ at \(eval \d+\) line \d+.?//;
|
|
chomp $error;
|
|
return $self->error("bad match operator: $error");
|
|
}
|
|
elsif (@warns) {
|
|
## Remove useless lines numbers from message.
|
|
($error = shift @warns) =~ s/ at \(eval \d+\) line \d+.?//;
|
|
$error =~ s/ while "strict subs" in use//;
|
|
chomp $error;
|
|
return $self->error("bad match operator: $error");
|
|
}
|
|
|
|
1;
|
|
} # end sub _match_check
|
|
|
|
|
|
sub _negotiate_callback {
|
|
my ($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos) = @_;
|
|
my (
|
|
$callback,
|
|
$s,
|
|
);
|
|
local $_;
|
|
|
|
## Keep track of remote echo.
|
|
if ($is_remote and $opt == &TELOPT_ECHO) { # received WILL or WONT ECHO
|
|
$s = *$self->{net_telnet};
|
|
|
|
if ($is_enabled and !$was_enabled) { # received WILL ECHO
|
|
$s->{remote_echo} = 1;
|
|
}
|
|
elsif (!$is_enabled and $was_enabled) { # received WONT ECHO
|
|
$s->{remote_echo} = '';
|
|
}
|
|
}
|
|
|
|
## Invoke callback, if there is one.
|
|
$callback = $self->option_callback;
|
|
if ($callback) {
|
|
&$callback($self, $opt, $is_remote,
|
|
$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
|
|
1;
|
|
} # end sub _negotiate_callback
|
|
|
|
|
|
sub _negotiate_recv {
|
|
my ($self, $s, $opt_request, $opt, $opt_bufpos) = @_;
|
|
|
|
## Ensure data structure exists for this option.
|
|
unless (defined $s->{opts}{$opt}) {
|
|
&_set_default_option($s, $opt);
|
|
}
|
|
|
|
## Process the option.
|
|
if ($opt_request eq "\376") { # DONT
|
|
&_negotiate_recv_disable($self, $s, $opt, "dont", $opt_bufpos,
|
|
$s->{opts}{$opt}{local_enable_ok},
|
|
\$s->{opts}{$opt}{local_enabled},
|
|
\$s->{opts}{$opt}{local_state});
|
|
}
|
|
elsif ($opt_request eq "\375") { # DO
|
|
&_negotiate_recv_enable($self, $s, $opt, "do", $opt_bufpos,
|
|
$s->{opts}{$opt}{local_enable_ok},
|
|
\$s->{opts}{$opt}{local_enabled},
|
|
\$s->{opts}{$opt}{local_state});
|
|
}
|
|
elsif ($opt_request eq "\374") { # WONT
|
|
&_negotiate_recv_disable($self, $s, $opt, "wont", $opt_bufpos,
|
|
$s->{opts}{$opt}{remote_enable_ok},
|
|
\$s->{opts}{$opt}{remote_enabled},
|
|
\$s->{opts}{$opt}{remote_state});
|
|
}
|
|
elsif ($opt_request eq "\373") { # WILL
|
|
&_negotiate_recv_enable($self, $s, $opt, "will", $opt_bufpos,
|
|
$s->{opts}{$opt}{remote_enable_ok},
|
|
\$s->{opts}{$opt}{remote_enabled},
|
|
\$s->{opts}{$opt}{remote_state});
|
|
}
|
|
else { # internal error
|
|
die;
|
|
}
|
|
|
|
1;
|
|
} # end sub _negotiate_recv
|
|
|
|
|
|
sub _negotiate_recv_disable {
|
|
my ($self, $s, $opt, $opt_request,
|
|
$opt_bufpos, $enable_ok, $is_enabled, $state) = @_;
|
|
my (
|
|
$ack,
|
|
$disable_cmd,
|
|
$enable_cmd,
|
|
$is_remote,
|
|
$nak,
|
|
$was_enabled,
|
|
);
|
|
|
|
## What do we use to request enable/disable or respond with ack/nak.
|
|
if ($opt_request eq "wont") {
|
|
$enable_cmd = "\377\375" . pack("C", $opt); # do command
|
|
$disable_cmd = "\377\376" . pack("C", $opt); # dont command
|
|
$is_remote = 1;
|
|
$ack = "DO";
|
|
$nak = "DONT";
|
|
|
|
&_log_option($s->{opt_log}, "RCVD", "WONT", $opt)
|
|
if $s->{opt_log};
|
|
}
|
|
elsif ($opt_request eq "dont") {
|
|
$enable_cmd = "\377\373" . pack("C", $opt); # will command
|
|
$disable_cmd = "\377\374" . pack("C", $opt); # wont command
|
|
$is_remote = '';
|
|
$ack = "WILL";
|
|
$nak = "WONT";
|
|
|
|
&_log_option($s->{opt_log}, "RCVD", "DONT", $opt)
|
|
if $s->{opt_log};
|
|
}
|
|
else { # internal error
|
|
die;
|
|
}
|
|
|
|
## Respond to WONT or DONT based on the current negotiation state.
|
|
if ($$state eq "no") { # state is already disabled
|
|
}
|
|
elsif ($$state eq "yes") { # they're initiating disable
|
|
$$is_enabled = '';
|
|
$$state = "no";
|
|
|
|
## Send positive acknowledgment.
|
|
$s->{unsent_opts} .= $disable_cmd;
|
|
&_log_option($s->{opt_log}, "SENT", $nak, $opt)
|
|
if $s->{opt_log};
|
|
|
|
## Invoke callbacks.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
elsif ($$state eq "wantno") { # they sent positive ack
|
|
$$is_enabled = '';
|
|
$$state = "no";
|
|
|
|
## Invoke callback.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
elsif ($$state eq "wantno opposite") { # pos ack but we changed our mind
|
|
## Indicate disabled but now we want to enable.
|
|
$$is_enabled = '';
|
|
$$state = "wantyes";
|
|
|
|
## Send queued request.
|
|
$s->{unsent_opts} .= $enable_cmd;
|
|
&_log_option($s->{opt_log}, "SENT", $ack, $opt)
|
|
if $s->{opt_log};
|
|
|
|
## Invoke callback.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
elsif ($$state eq "wantyes") { # they sent negative ack
|
|
$$is_enabled = '';
|
|
$$state = "no";
|
|
|
|
## Invoke callback.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
elsif ($$state eq "wantyes opposite") { # nak but we changed our mind
|
|
$$is_enabled = '';
|
|
$$state = "no";
|
|
|
|
## Invoke callback.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
} # end sub _negotiate_recv_disable
|
|
|
|
|
|
sub _negotiate_recv_enable {
|
|
my ($self, $s, $opt, $opt_request,
|
|
$opt_bufpos, $enable_ok, $is_enabled, $state) = @_;
|
|
my (
|
|
$ack,
|
|
$disable_cmd,
|
|
$enable_cmd,
|
|
$is_remote,
|
|
$nak,
|
|
$was_enabled,
|
|
);
|
|
|
|
## What we use to send enable/disable request or send ack/nak response.
|
|
if ($opt_request eq "will") {
|
|
$enable_cmd = "\377\375" . pack("C", $opt); # do command
|
|
$disable_cmd = "\377\376" . pack("C", $opt); # dont command
|
|
$is_remote = 1;
|
|
$ack = "DO";
|
|
$nak = "DONT";
|
|
|
|
&_log_option($s->{opt_log}, "RCVD", "WILL", $opt)
|
|
if $s->{opt_log};
|
|
}
|
|
elsif ($opt_request eq "do") {
|
|
$enable_cmd = "\377\373" . pack("C", $opt); # will command
|
|
$disable_cmd = "\377\374" . pack("C", $opt); # wont command
|
|
$is_remote = '';
|
|
$ack = "WILL";
|
|
$nak = "WONT";
|
|
|
|
&_log_option($s->{opt_log}, "RCVD", "DO", $opt)
|
|
if $s->{opt_log};
|
|
}
|
|
else { # internal error
|
|
die;
|
|
}
|
|
|
|
## Save current enabled state.
|
|
$was_enabled = $$is_enabled;
|
|
|
|
## Respond to WILL or DO based on the current negotiation state.
|
|
if ($$state eq "no") { # they're initiating enable
|
|
if ($enable_ok) { # we agree they/us should enable
|
|
$$is_enabled = 1;
|
|
$$state = "yes";
|
|
|
|
## Send positive acknowledgment.
|
|
$s->{unsent_opts} .= $enable_cmd;
|
|
&_log_option($s->{opt_log}, "SENT", $ack, $opt)
|
|
if $s->{opt_log};
|
|
|
|
## Invoke callbacks.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
else { # we disagree they/us should enable
|
|
## Send negative acknowledgment.
|
|
$s->{unsent_opts} .= $disable_cmd;
|
|
&_log_option($s->{opt_log}, "SENT", $nak, $opt)
|
|
if $s->{opt_log};
|
|
}
|
|
}
|
|
elsif ($$state eq "yes") { # state is already enabled
|
|
}
|
|
elsif ($$state eq "wantno") { # error: our disable req answered by enable
|
|
$$is_enabled = '';
|
|
$$state = "no";
|
|
|
|
## Invoke callbacks.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
elsif ($$state eq "wantno opposite") { # err: disable req answerd by enable
|
|
$$is_enabled = 1;
|
|
$$state = "yes";
|
|
|
|
## Invoke callbacks.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
elsif ($$state eq "wantyes") { # they sent pos ack
|
|
$$is_enabled = 1;
|
|
$$state = "yes";
|
|
|
|
## Invoke callback.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
elsif ($$state eq "wantyes opposite") { # pos ack but we changed our mind
|
|
## Indicate enabled but now we want to disable.
|
|
$$is_enabled = 1;
|
|
$$state = "wantno";
|
|
|
|
## Inform other side we changed our mind.
|
|
$s->{unsent_opts} .= $disable_cmd;
|
|
&_log_option($s->{opt_log}, "SENT", $nak, $opt)
|
|
if $s->{opt_log};
|
|
|
|
## Invoke callback.
|
|
&_negotiate_callback($self, $opt, $is_remote,
|
|
$$is_enabled, $was_enabled, $opt_bufpos);
|
|
}
|
|
|
|
1;
|
|
} # end sub _negotiate_recv_enable
|
|
|
|
|
|
sub _new_handle {
|
|
if ($INC{"IO/Handle.pm"}) {
|
|
return IO::Handle->new;
|
|
}
|
|
else {
|
|
require FileHandle;
|
|
return FileHandle->new;
|
|
}
|
|
} # end sub _new_handle
|
|
|
|
|
|
sub _next_getlines {
|
|
my ($self, $s) = @_;
|
|
my (
|
|
$len,
|
|
$line,
|
|
$pos,
|
|
@lines,
|
|
);
|
|
|
|
## Fill buffer and get first line.
|
|
$line = $self->getline
|
|
or return;
|
|
push @lines, $line;
|
|
|
|
## Extract subsequent lines from buffer.
|
|
while (($pos = index($s->{buf}, $s->{"rs"})) != -1) {
|
|
$len = $pos + length $s->{"rs"};
|
|
push @lines, substr($s->{buf}, 0, $len);
|
|
substr($s->{buf}, 0, $len) = "";
|
|
}
|
|
|
|
@lines;
|
|
} # end sub _next_getlines
|
|
|
|
|
|
sub _opt_accept {
|
|
my ($self, @args) = @_;
|
|
my (
|
|
$arg,
|
|
$option,
|
|
$s,
|
|
);
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
|
|
foreach $arg (@args) {
|
|
## Ensure data structure defined for this option.
|
|
$option = $arg->{option};
|
|
if (!defined $s->{opts}{$option}) {
|
|
&_set_default_option($s, $option);
|
|
}
|
|
|
|
## Save whether we'll accept or reject this option.
|
|
if ($arg->{is_remote}) {
|
|
$s->{opts}{$option}{remote_enable_ok} = $arg->{is_enable};
|
|
}
|
|
else {
|
|
$s->{opts}{$option}{local_enable_ok} = $arg->{is_enable};
|
|
}
|
|
}
|
|
|
|
1;
|
|
} # end sub _opt_accept
|
|
|
|
|
|
sub _optimal_blksize {
|
|
my ($blksize) = @_;
|
|
local $^W = ''; # avoid non-numeric warning for ms-windows blksize of ""
|
|
|
|
## Use default when block size is invalid.
|
|
if (!defined $blksize or $blksize < 512 or $blksize > 1_048_576) {
|
|
$blksize = 4096;
|
|
}
|
|
|
|
$blksize;
|
|
} # end sub _optimal_blksize
|
|
|
|
|
|
sub _parse_cmd_remove_mode {
|
|
my ($self, $mode) = @_;
|
|
|
|
if (!defined $mode) {
|
|
$mode = 0;
|
|
}
|
|
elsif ($mode =~ /^\s*auto\s*$/i) {
|
|
$mode = "auto";
|
|
}
|
|
elsif ($mode !~ /^\d+$/) {
|
|
&_carp($self, "ignoring bad Cmd_remove_mode " .
|
|
"argument \"$mode\": it's not \"auto\" or a " .
|
|
"non-negative integer");
|
|
$mode = *$self->{net_telnet}{cmd_rm_mode};
|
|
}
|
|
|
|
$mode;
|
|
} # end sub _parse_cmd_remove_mode
|
|
|
|
|
|
sub _parse_errmode {
|
|
my ($self, $errmode) = @_;
|
|
|
|
## Set the error mode.
|
|
if (!defined $errmode) {
|
|
&_carp($self, "ignoring undefined Errmode argument");
|
|
$errmode = *$self->{net_telnet}{errormode};
|
|
}
|
|
elsif ($errmode =~ /^\s*return\s*$/i) {
|
|
$errmode = "return";
|
|
}
|
|
elsif ($errmode =~ /^\s*die\s*$/i) {
|
|
$errmode = "die";
|
|
}
|
|
elsif (ref($errmode) eq "CODE") {
|
|
}
|
|
elsif (ref($errmode) eq "ARRAY") {
|
|
unless (ref($errmode->[0]) eq "CODE") {
|
|
&_carp($self, "ignoring bad Errmode argument: " .
|
|
"first list item isn't a code ref");
|
|
$errmode = *$self->{net_telnet}{errormode};
|
|
}
|
|
}
|
|
else {
|
|
&_carp($self, "ignoring bad Errmode argument \"$errmode\"");
|
|
$errmode = *$self->{net_telnet}{errormode};
|
|
}
|
|
|
|
$errmode;
|
|
} # end sub _parse_errmode
|
|
|
|
|
|
sub _parse_family {
|
|
my ($self, $family) = @_;
|
|
my (
|
|
$parsed_family,
|
|
);
|
|
|
|
unless (defined $family) {
|
|
$family = "";
|
|
}
|
|
|
|
if ($family =~ /^\s*ipv4\s*$/i) { # family arg is "ipv4"
|
|
$parsed_family = "ipv4";
|
|
}
|
|
elsif ($family =~ /^\s*any\s*$/i) { # family arg is "any"
|
|
if ($Socket::VERSION >= 1.94 and defined $AF_INET6) { # has IPv6
|
|
$parsed_family = "any";
|
|
}
|
|
else { # IPv6 not supported on this machine
|
|
$parsed_family = "ipv4";
|
|
}
|
|
}
|
|
elsif ($family =~ /^\s*ipv6\s*$/i) { # family arg is "ipv6"
|
|
return $self->error("Family arg ipv6 not supported when " .
|
|
"Socket.pm version < 1.94")
|
|
unless $Socket::VERSION >= 1.94;
|
|
return $self->error("Family arg ipv6 not supported by " .
|
|
"this OS: AF_INET6 not in Socket.pm")
|
|
unless defined $AF_INET6;
|
|
|
|
$parsed_family = "ipv6";
|
|
}
|
|
else {
|
|
return $self->error("bad Family argument \"$family\": " .
|
|
"must be \"ipv4\", \"ipv6\", or \"any\"");
|
|
}
|
|
|
|
$parsed_family;
|
|
} # end sub _parse_family
|
|
|
|
|
|
sub _parse_input_record_separator {
|
|
my ($self, $rs) = @_;
|
|
|
|
unless (defined $rs and length $rs) {
|
|
&_carp($self, "ignoring null Input_record_separator argument");
|
|
$rs = *$self->{net_telnet}{"rs"};
|
|
}
|
|
|
|
$rs;
|
|
} # end sub _parse_input_record_separator
|
|
|
|
|
|
sub _parse_localfamily {
|
|
my ($self, $family) = @_;
|
|
|
|
unless (defined $family) {
|
|
$family = "";
|
|
}
|
|
|
|
if ($family =~ /^\s*ipv4\s*$/i) { # family arg is "ipv4"
|
|
$family = "ipv4";
|
|
}
|
|
elsif ($family =~ /^\s*any\s*$/i) { # family arg is "any"
|
|
if ($Socket::VERSION >= 1.94 and defined $AF_INET6) { # has IPv6
|
|
$family = "any";
|
|
}
|
|
else { # IPv6 not supported on this machine
|
|
$family = "ipv4";
|
|
}
|
|
}
|
|
elsif ($family =~ /^\s*ipv6\s*$/i) { # family arg is "ipv6"
|
|
return $self->error("Localfamily arg ipv6 not supported when " .
|
|
"Socket.pm version < 1.94")
|
|
unless $Socket::VERSION >= 1.94;
|
|
return $self->error("Localfamily arg ipv6 not supported by " .
|
|
"this OS: AF_INET6 not in Socket.pm")
|
|
unless defined $AF_INET6;
|
|
|
|
$family = "ipv6";
|
|
}
|
|
else {
|
|
return $self->error("bad Localfamily argument \"$family\": " .
|
|
"must be \"ipv4\", \"ipv6\", or \"any\"");
|
|
}
|
|
|
|
$family;
|
|
} # end sub _parse_localfamily
|
|
|
|
|
|
sub _parse_port {
|
|
my ($self, $port) = @_;
|
|
my (
|
|
$service,
|
|
);
|
|
|
|
unless (defined $port) {
|
|
$port = "";
|
|
}
|
|
|
|
return $self->error("bad Port argument \"$port\"")
|
|
unless $port;
|
|
|
|
if ($port !~ /^\d+$/) { # port isn't all digits
|
|
$service = $port;
|
|
$port = getservbyname($service, "tcp");
|
|
|
|
return $self->error("bad Port argument \"$service\": " .
|
|
"it's an unknown TCP service")
|
|
unless $port;
|
|
}
|
|
|
|
$port;
|
|
} # end sub _parse_port
|
|
|
|
|
|
sub _parse_prompt {
|
|
my ($self, $prompt) = @_;
|
|
|
|
unless (defined $prompt) {
|
|
$prompt = "";
|
|
}
|
|
|
|
return $self->error("bad Prompt argument \"$prompt\": " .
|
|
"missing opening delimiter of match operator")
|
|
unless $prompt =~ m(^\s*/) or $prompt =~ m(^\s*m\s*\W);
|
|
|
|
$prompt;
|
|
} # end sub _parse_prompt
|
|
|
|
|
|
sub _parse_timeout {
|
|
my ($self, $timeout) = @_;
|
|
local $@;
|
|
|
|
## Ensure valid timeout.
|
|
if (defined $timeout) {
|
|
## Test for non-numeric or negative values.
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
local $SIG{"__WARN__"} = sub { die "non-numeric\n" };
|
|
local $^W = 1;
|
|
$timeout *= 1;
|
|
};
|
|
if ($@) { # timeout arg is non-numeric
|
|
&_carp($self,
|
|
"ignoring non-numeric Timeout argument \"$timeout\"");
|
|
$timeout = *$self->{net_telnet}{time_out};
|
|
}
|
|
elsif ($timeout < 0) { # timeout arg is negative
|
|
&_carp($self, "ignoring negative Timeout argument \"$timeout\"");
|
|
$timeout = *$self->{net_telnet}{time_out};
|
|
}
|
|
}
|
|
|
|
$timeout;
|
|
} # end sub _parse_timeout
|
|
|
|
|
|
sub _put {
|
|
my ($self, $buf, $subname) = @_;
|
|
my (
|
|
$endtime,
|
|
$len,
|
|
$nfound,
|
|
$nwrote,
|
|
$offset,
|
|
$ready,
|
|
$s,
|
|
$timed_out,
|
|
$timeout,
|
|
$zero_wrote_count,
|
|
);
|
|
|
|
## Init.
|
|
$s = *$self->{net_telnet};
|
|
$s->{num_wrote} = 0;
|
|
$zero_wrote_count = 0;
|
|
$offset = 0;
|
|
$len = length $$buf;
|
|
$endtime = &_endtime($s->{time_out});
|
|
|
|
return $self->error("write error: filehandle isn't open")
|
|
unless $s->{opened};
|
|
|
|
## Try to send any waiting option negotiation.
|
|
if (length $s->{unsent_opts}) {
|
|
&_flush_opts($self);
|
|
}
|
|
|
|
## Write until all data blocks written.
|
|
while ($len) {
|
|
## Determine how long to wait for output ready.
|
|
($timed_out, $timeout) = &_timeout_interval($endtime);
|
|
if ($timed_out) {
|
|
$s->{timedout} = 1;
|
|
return $self->error("$subname timed-out");
|
|
}
|
|
|
|
## Wait for output ready.
|
|
$nfound = select "", $ready=$s->{fdmask}, "", $timeout;
|
|
|
|
## Handle any errors while waiting.
|
|
if ((!defined $nfound or $nfound <= 0) and $s->{select_supported}) {
|
|
if (defined $nfound and $nfound == 0) { # timed-out
|
|
$s->{timedout} = 1;
|
|
return $self->error("$subname timed-out");
|
|
}
|
|
else { # error waiting for output ready
|
|
if (defined $EINTR) {
|
|
next if $! == $EINTR; # restart select()
|
|
}
|
|
else {
|
|
next if $! =~ /^interrupted/i; # restart select()
|
|
}
|
|
|
|
$s->{opened} = '';
|
|
return $self->error("write error: $!");
|
|
}
|
|
}
|
|
|
|
## Write the data.
|
|
$nwrote = syswrite $self, $$buf, $s->{blksize}, $offset;
|
|
|
|
## Handle any write errors.
|
|
if (!defined $nwrote) { # write failed
|
|
if (defined $EINTR) {
|
|
next if $! == $EINTR; # restart syswrite()
|
|
}
|
|
else {
|
|
next if $! =~ /^interrupted/i; # restart syswrite()
|
|
}
|
|
|
|
$s->{opened} = '';
|
|
return $self->error("write error: $!");
|
|
}
|
|
elsif ($nwrote == 0) { # zero chars written
|
|
## Try ten more times to write the data.
|
|
if ($zero_wrote_count++ <= 10) {
|
|
&_sleep(0.01);
|
|
next;
|
|
}
|
|
|
|
$s->{opened} = '';
|
|
return $self->error("write error: zero length write: $!");
|
|
}
|
|
|
|
## Display network traffic if requested.
|
|
if ($s->{dumplog}) {
|
|
&_log_dump('>', $s->{dumplog}, $buf, $offset, $nwrote);
|
|
}
|
|
|
|
## Increment.
|
|
$s->{num_wrote} += $nwrote;
|
|
$offset += $nwrote;
|
|
$len -= $nwrote;
|
|
}
|
|
|
|
1;
|
|
} # end sub _put
|
|
|
|
|
|
sub _qualify_fh {
|
|
my ($obj, $name) = @_;
|
|
my (
|
|
$user_class,
|
|
);
|
|
local $@;
|
|
local $_;
|
|
|
|
## Get user's package name.
|
|
($user_class) = &_user_caller($obj);
|
|
|
|
## Ensure name is qualified with a package name.
|
|
$name = qualify($name, $user_class);
|
|
|
|
## If it's not already, make it a typeglob ref.
|
|
if (!ref $name) {
|
|
no strict;
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
local $^W = '';
|
|
|
|
$name =~ s/^\*+//;
|
|
$name = eval "\\*$name";
|
|
return unless ref $name;
|
|
}
|
|
|
|
$name;
|
|
} # end sub _qualify_fh
|
|
|
|
|
|
sub _reset_options {
|
|
my ($opts) = @_;
|
|
my (
|
|
$opt,
|
|
);
|
|
|
|
foreach $opt (keys %$opts) {
|
|
$opts->{$opt}{remote_enabled} = '';
|
|
$opts->{$opt}{remote_state} = "no";
|
|
$opts->{$opt}{local_enabled} = '';
|
|
$opts->{$opt}{local_state} = "no";
|
|
}
|
|
|
|
1;
|
|
} # end sub _reset_options
|
|
|
|
|
|
sub _save_lastline {
|
|
my ($s) = @_;
|
|
my (
|
|
$firstpos,
|
|
$lastpos,
|
|
$len_w_sep,
|
|
$len_wo_sep,
|
|
$offset,
|
|
);
|
|
my $rs = "\n";
|
|
|
|
if (($lastpos = rindex $s->{buf}, $rs) > -1) { # eol found
|
|
while (1) {
|
|
## Find beginning of line.
|
|
$firstpos = rindex $s->{buf}, $rs, $lastpos - 1;
|
|
if ($firstpos == -1) {
|
|
$offset = 0;
|
|
}
|
|
else {
|
|
$offset = $firstpos + length $rs;
|
|
}
|
|
|
|
## Determine length of line with and without separator.
|
|
$len_wo_sep = $lastpos - $offset;
|
|
$len_w_sep = $len_wo_sep + length $rs;
|
|
|
|
## Save line if it's not blank.
|
|
if (substr($s->{buf}, $offset, $len_wo_sep)
|
|
!~ /^\s*$/)
|
|
{
|
|
$s->{last_line} = substr($s->{buf},
|
|
$offset,
|
|
$len_w_sep);
|
|
last;
|
|
}
|
|
|
|
last if $firstpos == -1;
|
|
|
|
$lastpos = $firstpos;
|
|
}
|
|
}
|
|
|
|
1;
|
|
} # end sub _save_lastline
|
|
|
|
|
|
sub _set_default_option {
|
|
my ($s, $option) = @_;
|
|
|
|
$s->{opts}{$option} = {
|
|
remote_enabled => '',
|
|
remote_state => "no",
|
|
remote_enable_ok => '',
|
|
local_enabled => '',
|
|
local_state => "no",
|
|
local_enable_ok => '',
|
|
};
|
|
} # end sub _set_default_option
|
|
|
|
|
|
sub _sleep {
|
|
my ($secs) = @_;
|
|
my $bitmask = "";
|
|
local *SOCK;
|
|
|
|
socket SOCK, AF_INET, SOCK_STREAM, 0;
|
|
vec($bitmask, fileno(SOCK), 1) = 1;
|
|
select $bitmask, "", "", $secs;
|
|
CORE::close SOCK;
|
|
|
|
1;
|
|
} # end sub _sleep
|
|
|
|
|
|
sub _timeout_interval {
|
|
my ($endtime) = @_;
|
|
my (
|
|
$timeout,
|
|
);
|
|
|
|
## Return timed-out boolean and timeout interval.
|
|
if (defined $endtime) {
|
|
## Is it a one-time poll.
|
|
return ('', 0) if $endtime == 0;
|
|
|
|
## Calculate the timeout interval.
|
|
$timeout = $endtime - time;
|
|
|
|
## Did we already timeout.
|
|
return (1, 0) unless $timeout > 0;
|
|
|
|
return ('', $timeout);
|
|
}
|
|
else { # there is no timeout
|
|
return ('', undef);
|
|
}
|
|
} # end sub _timeout_interval
|
|
|
|
|
|
sub _unpack_sockaddr {
|
|
my ($self, $sockaddr) = @_;
|
|
my (
|
|
$packed_addr,
|
|
$sockfamily,
|
|
);
|
|
my $addr = "";
|
|
my $port = "";
|
|
|
|
$sockfamily = $self->sockfamily;
|
|
|
|
## Parse sockaddr struct.
|
|
if ($sockfamily eq "ipv4") {
|
|
($port, $packed_addr) = sockaddr_in($sockaddr);
|
|
$addr = Socket::inet_ntoa($packed_addr);
|
|
}
|
|
elsif ($sockfamily eq "ipv6") {
|
|
($port, $packed_addr) = Socket::sockaddr_in6($sockaddr);
|
|
$addr = Socket::inet_ntop($AF_INET6, $packed_addr);
|
|
}
|
|
|
|
($port, $addr);
|
|
} # end sub _unpack_sockaddr
|
|
|
|
|
|
sub _user_caller {
|
|
my ($obj) = @_;
|
|
my (
|
|
$class,
|
|
$curr_pkg,
|
|
$file,
|
|
$i,
|
|
$line,
|
|
$pkg,
|
|
%isa,
|
|
@isa,
|
|
);
|
|
local $@;
|
|
local $_;
|
|
|
|
## Create a boolean hash to test for isa. Make sure current
|
|
## package and the object's class are members.
|
|
$class = ref $obj;
|
|
@isa = eval "\@${class}::ISA";
|
|
push @isa, $class;
|
|
($curr_pkg) = caller 1;
|
|
push @isa, $curr_pkg;
|
|
%isa = map { $_ => 1 } @isa;
|
|
|
|
## Search back in call frames for a package that's not in isa.
|
|
$i = 1;
|
|
while (($pkg, $file, $line) = caller ++$i) {
|
|
next if $isa{$pkg};
|
|
|
|
return ($pkg, $file, $line);
|
|
}
|
|
|
|
## If not found, choose outer most call frame.
|
|
($pkg, $file, $line) = caller --$i;
|
|
return ($pkg, $file, $line);
|
|
} # end sub _user_caller
|
|
|
|
|
|
sub _verify_telopt_arg {
|
|
my ($self, $option, $argname) = @_;
|
|
local $@;
|
|
|
|
## If provided, use argument name in error message.
|
|
if (defined $argname) {
|
|
$argname = "for arg $argname";
|
|
}
|
|
else {
|
|
$argname = "";
|
|
}
|
|
|
|
## Ensure telnet option is a non-negative integer.
|
|
eval {
|
|
local $SIG{"__DIE__"} = "DEFAULT";
|
|
local $SIG{"__WARN__"} = sub { die "non-numeric\n" };
|
|
local $^W = 1;
|
|
$option = abs(int $option);
|
|
};
|
|
return $self->error("bad telnet option $argname: non-numeric")
|
|
if $@;
|
|
|
|
return $self->error("bad telnet option $argname: option > 255")
|
|
unless $option <= 255;
|
|
|
|
$option;
|
|
} # end sub _verify_telopt_arg
|
|
|
|
|
|
######################## Exported Constants ##########################
|
|
|
|
|
|
sub TELNET_IAC () {255}; # interpret as command:
|
|
sub TELNET_DONT () {254}; # you are not to use option
|
|
sub TELNET_DO () {253}; # please, you use option
|
|
sub TELNET_WONT () {252}; # I won't use option
|
|
sub TELNET_WILL () {251}; # I will use option
|
|
sub TELNET_SB () {250}; # interpret as subnegotiation
|
|
sub TELNET_GA () {249}; # you may reverse the line
|
|
sub TELNET_EL () {248}; # erase the current line
|
|
sub TELNET_EC () {247}; # erase the current character
|
|
sub TELNET_AYT () {246}; # are you there
|
|
sub TELNET_AO () {245}; # abort output--but let prog finish
|
|
sub TELNET_IP () {244}; # interrupt process--permanently
|
|
sub TELNET_BREAK () {243}; # break
|
|
sub TELNET_DM () {242}; # data mark--for connect. cleaning
|
|
sub TELNET_NOP () {241}; # nop
|
|
sub TELNET_SE () {240}; # end sub negotiation
|
|
sub TELNET_EOR () {239}; # end of record (transparent mode)
|
|
sub TELNET_ABORT () {238}; # Abort process
|
|
sub TELNET_SUSP () {237}; # Suspend process
|
|
sub TELNET_EOF () {236}; # End of file
|
|
sub TELNET_SYNCH () {242}; # for telfunc calls
|
|
|
|
sub TELOPT_BINARY () {0}; # Binary Transmission
|
|
sub TELOPT_ECHO () {1}; # Echo
|
|
sub TELOPT_RCP () {2}; # Reconnection
|
|
sub TELOPT_SGA () {3}; # Suppress Go Ahead
|
|
sub TELOPT_NAMS () {4}; # Approx Message Size Negotiation
|
|
sub TELOPT_STATUS () {5}; # Status
|
|
sub TELOPT_TM () {6}; # Timing Mark
|
|
sub TELOPT_RCTE () {7}; # Remote Controlled Trans and Echo
|
|
sub TELOPT_NAOL () {8}; # Output Line Width
|
|
sub TELOPT_NAOP () {9}; # Output Page Size
|
|
sub TELOPT_NAOCRD () {10}; # Output Carriage-Return Disposition
|
|
sub TELOPT_NAOHTS () {11}; # Output Horizontal Tab Stops
|
|
sub TELOPT_NAOHTD () {12}; # Output Horizontal Tab Disposition
|
|
sub TELOPT_NAOFFD () {13}; # Output Formfeed Disposition
|
|
sub TELOPT_NAOVTS () {14}; # Output Vertical Tabstops
|
|
sub TELOPT_NAOVTD () {15}; # Output Vertical Tab Disposition
|
|
sub TELOPT_NAOLFD () {16}; # Output Linefeed Disposition
|
|
sub TELOPT_XASCII () {17}; # Extended ASCII
|
|
sub TELOPT_LOGOUT () {18}; # Logout
|
|
sub TELOPT_BM () {19}; # Byte Macro
|
|
sub TELOPT_DET () {20}; # Data Entry Terminal
|
|
sub TELOPT_SUPDUP () {21}; # SUPDUP
|
|
sub TELOPT_SUPDUPOUTPUT () {22}; # SUPDUP Output
|
|
sub TELOPT_SNDLOC () {23}; # Send Location
|
|
sub TELOPT_TTYPE () {24}; # Terminal Type
|
|
sub TELOPT_EOR () {25}; # End of Record
|
|
sub TELOPT_TUID () {26}; # TACACS User Identification
|
|
sub TELOPT_OUTMRK () {27}; # Output Marking
|
|
sub TELOPT_TTYLOC () {28}; # Terminal Location Number
|
|
sub TELOPT_3270REGIME () {29}; # Telnet 3270 Regime
|
|
sub TELOPT_X3PAD () {30}; # X.3 PAD
|
|
sub TELOPT_NAWS () {31}; # Negotiate About Window Size
|
|
sub TELOPT_TSPEED () {32}; # Terminal Speed
|
|
sub TELOPT_LFLOW () {33}; # Remote Flow Control
|
|
sub TELOPT_LINEMODE () {34}; # Linemode
|
|
sub TELOPT_XDISPLOC () {35}; # X Display Location
|
|
sub TELOPT_OLD_ENVIRON () {36}; # Environment Option
|
|
sub TELOPT_AUTHENTICATION () {37}; # Authentication Option
|
|
sub TELOPT_ENCRYPT () {38}; # Encryption Option
|
|
sub TELOPT_NEW_ENVIRON () {39}; # New Environment Option
|
|
sub TELOPT_TN3270E () {40}; # TN3270 Enhancements
|
|
sub TELOPT_CHARSET () {42}; # CHARSET Option
|
|
sub TELOPT_COMPORT () {44}; # Com Port Control Option
|
|
sub TELOPT_KERMIT () {47}; # Kermit Option
|
|
sub TELOPT_EXOPL () {255}; # Extended-Options-List
|
|
|
|
|
|
1;
|
|
__END__;
|
|
|
|
|
|
######################## User Documentation ##########################
|
|
|
|
|
|
## To format the following documentation into a more readable format,
|
|
## use one of these programs: perldoc; pod2man; pod2html; pod2text.
|
|
## For example, to nicely format this documentation for printing, you
|
|
## may use pod2man and groff to convert to postscript:
|
|
## pod2man Net/Telnet.pm | groff -man -Tps > Net::Telnet.ps
|
|
|
|
=head1 NAME
|
|
|
|
Net::Telnet - interact with TELNET port or other TCP ports
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
C<use Net::Telnet ();>
|
|
|
|
see METHODS or EXAMPLES sections below
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Net::Telnet allows you to make client connections to a TCP port and do
|
|
network I/O, especially to a port using the TELNET protocol. Simple
|
|
I/O methods such as print, get, and getline are provided. More
|
|
sophisticated interactive features are provided because connecting to
|
|
a TELNET port ultimately means communicating with a program designed
|
|
for human interaction. These interactive features include the ability
|
|
to specify a time-out and to wait for patterns to appear in the input
|
|
stream, such as the prompt from a shell. IPv6 support is available
|
|
when using perl 5.14 or later (see C<family()>.
|
|
|
|
Other reasons to use this module than strictly with a TELNET port are:
|
|
|
|
=over 2
|
|
|
|
=item *
|
|
|
|
You're not familiar with sockets and you want a simple way to make
|
|
client connections to TCP services.
|
|
|
|
=item *
|
|
|
|
You want to be able to specify your own time-out while connecting,
|
|
reading, or writing.
|
|
|
|
=item *
|
|
|
|
You're communicating with an interactive program at the other end of
|
|
some socket or pipe and you want to wait for certain patterns to
|
|
appear.
|
|
|
|
=back
|
|
|
|
Here's an example that prints who's logged-on to a remote host. In
|
|
addition to a username and password, you must also know the user's
|
|
shell prompt, which for this example is C<"bash$ ">
|
|
|
|
use Net::Telnet ();
|
|
$t = new Net::Telnet (Timeout => 10,
|
|
Prompt => '/bash\$ $/');
|
|
$t->open($host);
|
|
$t->login($username, $passwd);
|
|
@lines = $t->cmd("who");
|
|
print @lines;
|
|
|
|
See the B<EXAMPLES> section below for more examples.
|
|
|
|
Usage questions should be directed to the perlmonks.org discussion
|
|
group. Bugs can be viewed or reported at cpan.org on the Net::Telnet
|
|
page.
|
|
|
|
=head2 What To Know Before Using
|
|
|
|
=over 2
|
|
|
|
=item *
|
|
|
|
All output is flushed while all input is buffered. Each object
|
|
contains its own input buffer.
|
|
|
|
=item *
|
|
|
|
The output record separator for C<print()> and C<cmd()> is set to
|
|
C<"\n"> by default, so that you don't have to append all your commands
|
|
with a newline. To avoid printing a trailing C<"\n"> use C<put()> or
|
|
set the I<output_record_separator> to C<"">.
|
|
|
|
=item *
|
|
|
|
The methods C<login()> and C<cmd()> use the I<prompt> setting in the
|
|
object to determine when a login or remote command is complete. Those
|
|
methods will fail with a time-out if you don't set the prompt
|
|
correctly.
|
|
|
|
=item *
|
|
|
|
Use a combination of C<print()> and C<waitfor()> as an alternative to
|
|
C<login()> or C<cmd()> when they don't do what you want.
|
|
|
|
=item *
|
|
|
|
Errors such as timing-out are handled according to the error mode
|
|
action. The default action is to print an error message to standard
|
|
error and have the program die. See the C<errmode()> method for more
|
|
information.
|
|
|
|
=item *
|
|
|
|
When constructing the match operator argument for C<prompt()> or
|
|
C<waitfor()>, always use single quotes instead of double quotes to
|
|
avoid unexpected backslash interpretation (e.g. C<'/bash\$ $/'>). If
|
|
you're constructing a DOS like file path, you'll need to use four
|
|
backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>).
|
|
|
|
Of course don't forget about regexp metacharacters like C<.>, C<[>, or
|
|
C<$>. You'll only need a single backslash to quote them. The anchor
|
|
metacharacters C<^> and C<$> refer to positions in the input buffer.
|
|
To avoid matching characters read that look like a prompt, it's a good
|
|
idea to end your prompt pattern with the C<$> anchor. That way the
|
|
prompt will only match if it's the last thing read.
|
|
|
|
=item *
|
|
|
|
In the input stream, each sequence of I<carriage return> and I<line
|
|
feed> (i.e. C<"\015\012"> or CR LF) is converted to C<"\n">. In the
|
|
output stream, each occurrence of C<"\n"> is converted to a sequence
|
|
of CR LF. See C<binmode()> to change the behavior. TCP protocols
|
|
typically use the ASCII sequence, carriage return and line feed to
|
|
designate a newline.
|
|
|
|
=item *
|
|
|
|
Timing-out while making a connection is disabled for machines that
|
|
don't support the C<alarm()> function. Most notably these include
|
|
MS-Windows machines.
|
|
|
|
=item *
|
|
|
|
You'll need to be running at least Perl version 5.002 to use this
|
|
module. This module does not require any libraries that don't already
|
|
come with a standard Perl distribution.
|
|
|
|
If you have the IO:: libraries installed (they come standard with
|
|
perl5.004 and later) then IO::Socket::INET is used as a base class,
|
|
otherwise FileHandle is used.
|
|
|
|
=back
|
|
|
|
=head2 Debugging
|
|
|
|
The typical usage bug causes a time-out error because you've made
|
|
incorrect assumptions about what the remote side actually sends. The
|
|
easiest way to reconcile what the remote side sends with your
|
|
expectations is to use C<input_log()> or C<dump_log()>.
|
|
|
|
C<dump_log()> allows you to see the data being sent from the remote
|
|
side before any translation is done, while C<input_log()> shows you
|
|
the results after translation. The translation includes converting
|
|
end of line characters, removing and responding to TELNET protocol
|
|
commands in the data stream.
|
|
|
|
=head2 Style of Named Parameters
|
|
|
|
Two different styles of named parameters are supported. This document
|
|
only shows the IO:: style:
|
|
|
|
Net::Telnet->new(Timeout => 20);
|
|
|
|
however the dash-option style is also allowed:
|
|
|
|
Net::Telnet->new(-timeout => 20);
|
|
|
|
=head2 Connecting to a Remote MS-Windows Machine
|
|
|
|
By default MS-Windows doesn't come with a TELNET server. However
|
|
third party TELNET servers are available. Unfortunately many of these
|
|
servers falsely claim to be a TELNET server. This is especially true
|
|
of the so-called "Microsoft Telnet Server" that comes installed with
|
|
some newer versions MS-Windows.
|
|
|
|
When a TELNET server first accepts a connection, it must use the ASCII
|
|
control characters carriage-return and line-feed to start a new line
|
|
(see RFC854). A server like the "Microsoft Telnet Server" that
|
|
doesn't do this, isn't a TELNET server. These servers send ANSI
|
|
terminal escape sequences to position to a column on a subsequent line
|
|
and to even position while writing characters that are adjacent to
|
|
each other. Worse, when sending output these servers resend
|
|
previously sent command output in a misguided attempt to display an
|
|
entire terminal screen.
|
|
|
|
Connecting Net::Telnet to one of these false TELNET servers makes your
|
|
job of parsing command output very difficult. It's better to replace
|
|
a false TELNET server with a real TELNET server. The better TELNET
|
|
servers for MS-Windows allow you to avoid the ANSI escapes by turning
|
|
off something some of them call I<console mode>.
|
|
|
|
|
|
=head1 METHODS
|
|
|
|
In the calling sequences below, square brackets B<[]> represent
|
|
optional parameters.
|
|
|
|
=over 4
|
|
|
|
=item B<new> - create a new Net::Telnet object
|
|
|
|
$obj = new Net::Telnet ([$host]);
|
|
|
|
$obj = new Net::Telnet ([Binmode => $mode,]
|
|
[Cmd_remove_mode => $mode,]
|
|
[Dump_Log => $filename,]
|
|
[Errmode => $errmode,]
|
|
[Family => $family,]
|
|
[Fhopen => $filehandle,]
|
|
[Host => $host,]
|
|
[Input_log => $file,]
|
|
[Input_record_separator => $chars,]
|
|
[Localfamily => $family,]
|
|
[Localhost => $host,]
|
|
[Max_buffer_length => $len,]
|
|
[Ofs => $chars,]
|
|
[Option_log => $file,]
|
|
[Ors => $chars,]
|
|
[Output_field_separator => $chars,]
|
|
[Output_log => $file,]
|
|
[Output_record_separator => $chars,]
|
|
[Port => $port,]
|
|
[Prompt => $matchop,]
|
|
[Rs => $chars,]
|
|
[Telnetmode => $mode,]
|
|
[Timeout => $secs,]);
|
|
|
|
This is the constructor for Net::Telnet objects. A new object is
|
|
returned on success, the error mode action is performed on failure -
|
|
see C<errmode()>. The optional arguments are short-cuts to methods of
|
|
the same name.
|
|
|
|
If the I<$host> argument is given then the object is opened by
|
|
connecting to TCP I<$port> on I<$host>. Also see C<open()>. The new
|
|
object returned is given the following defaults in the absence of
|
|
corresponding named parameters:
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
The default I<Host> is C<"localhost">
|
|
|
|
=item
|
|
|
|
The default I<Port> is C<23>
|
|
|
|
=item
|
|
|
|
The default I<Family> is C<"ipv4">
|
|
|
|
=item
|
|
|
|
The default I<Prompt> is C<'/[\$%#E<gt>] $/'>
|
|
|
|
=item
|
|
|
|
The default I<Timeout> is C<10>
|
|
|
|
=item
|
|
|
|
The default I<Errmode> is C<"die">
|
|
|
|
=item
|
|
|
|
The default I<Output_record_separator> is C<"\n">. Note that I<Ors>
|
|
is synonymous with I<Output_record_separator>.
|
|
|
|
=item
|
|
|
|
The default I<Input_record_separator> is C<"\n">. Note that I<Rs> is
|
|
synonymous with I<Input_record_separator>.
|
|
|
|
=item
|
|
|
|
The default I<Binmode> is C<0>, which means do newline translation.
|
|
|
|
=item
|
|
|
|
The default I<Telnetmode> is C<1>, which means respond to TELNET
|
|
commands in the data stream.
|
|
|
|
=item
|
|
|
|
The default I<Cmd_remove_mode> is C<"auto">
|
|
|
|
=item
|
|
|
|
The defaults for I<Dump_log>, I<Input_log>, I<Option_log>, and
|
|
I<Output_log> are C<"">, which means that logging is turned-off.
|
|
|
|
=item
|
|
|
|
The default I<Max_buffer_length> is C<1048576> bytes, i.e. 1 MiB.
|
|
|
|
=item
|
|
|
|
The default I<Output_field_separator> is C<"">. Note that I<Ofs>
|
|
is synonymous with I<Output_field_separator>.
|
|
|
|
=item
|
|
|
|
The default I<Localhost> is C<"">
|
|
|
|
=item
|
|
|
|
The default I<Localfamily> is C<"ipv4">
|
|
|
|
=back
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<binmode> - toggle newline translation
|
|
|
|
$mode = $obj->binmode;
|
|
|
|
$prev = $obj->binmode($mode);
|
|
|
|
This method controls whether or not sequences of carriage returns and
|
|
line feeds (CR LF or more specifically C<"\015\012">) are translated.
|
|
By default they are translated (i.e. binmode is C<0>).
|
|
|
|
If no argument is given, the current mode is returned.
|
|
|
|
If I<$mode> is C<1> then binmode is I<on> and newline translation is
|
|
not done.
|
|
|
|
If I<$mode> is C<0> then binmode is I<off> and newline translation is
|
|
done. In the input stream, each sequence of CR LF is converted to
|
|
C<"\n"> and in the output stream, each occurrence of C<"\n"> is
|
|
converted to a sequence of CR LF.
|
|
|
|
Note that input is always buffered. Changing binmode doesn't effect
|
|
what's already been read into the buffer. Output is not buffered and
|
|
changing binmode will have an immediate effect.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<break> - send TELNET break character
|
|
|
|
$ok = $obj->break;
|
|
|
|
This method sends the TELNET break character. This character is
|
|
provided because it's a signal outside the ASCII character set which
|
|
is currently given local meaning within many systems. It's intended
|
|
to indicate that the Break Key or the Attention Key was hit.
|
|
|
|
This method returns C<1> on success, or performs the error mode action
|
|
on failure.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<buffer> - scalar reference to object's input buffer
|
|
|
|
$ref = $obj->buffer;
|
|
|
|
This method returns a scalar reference to the input buffer for
|
|
I<$obj>. Data in the input buffer is data that has been read from the
|
|
remote side but has yet to be read by the user. Modifications to the
|
|
input buffer are returned by a subsequent read.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<buffer_empty> - discard all data in object's input buffer
|
|
|
|
$obj->buffer_empty;
|
|
|
|
This method removes all data in the input buffer for I<$obj>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<close> - close object
|
|
|
|
$ok = $obj->close;
|
|
|
|
This method closes the socket, file, or pipe associated with the
|
|
object. It always returns a value of C<1>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<cmd> - issue command and retrieve output
|
|
|
|
$ok = $obj->cmd($string);
|
|
$ok = $obj->cmd(String => $string,
|
|
[Output => $ref,]
|
|
[Cmd_remove_mode => $mode,]
|
|
[Errmode => $mode,]
|
|
[Input_record_separator => $chars,]
|
|
[Ors => $chars,]
|
|
[Output_record_separator => $chars,]
|
|
[Prompt => $match,]
|
|
[Rs => $chars,]
|
|
[Timeout => $secs,]);
|
|
|
|
@output = $obj->cmd($string);
|
|
@output = $obj->cmd(String => $string,
|
|
[Output => $ref,]
|
|
[Cmd_remove_mode => $mode,]
|
|
[Errmode => $mode,]
|
|
[Input_record_separator => $chars,]
|
|
[Ors => $chars,]
|
|
[Output_record_separator => $chars,]
|
|
[Prompt => $match,]
|
|
[Rs => $chars,]
|
|
[Timeout => $secs,]);
|
|
|
|
This method sends the command I<$string>, and reads the characters
|
|
sent back by the command up until and including the matching prompt.
|
|
It's assumed that the program to which you're sending is some kind of
|
|
command prompting interpreter such as a shell.
|
|
|
|
The command I<$string> is automatically appended with the
|
|
output_record_separator, by default it is C<"\n">. This is similar
|
|
to someone typing a command and hitting the return key. Set the
|
|
output_record_separator to change this behavior.
|
|
|
|
In a scalar context, the characters read from the remote side are
|
|
discarded and C<1> is returned on success. On time-out, eof, or other
|
|
failures, the error mode action is performed. See C<errmode()>.
|
|
|
|
In a list context, just the output generated by the command is
|
|
returned, one line per element. In other words, all the characters in
|
|
between the echoed back command string and the prompt are returned.
|
|
If the command happens to return no output, a list containing one
|
|
element, the empty string is returned. This is so the list will
|
|
indicate true in a boolean context. On time-out, eof, or other
|
|
failures, the error mode action is performed. See C<errmode()>.
|
|
|
|
The characters that matched the prompt may be retrieved using
|
|
C<last_prompt()>.
|
|
|
|
Many command interpreters echo back the command sent. In most
|
|
situations, this method removes the first line returned from the
|
|
remote side (i.e. the echoed back command). See C<cmd_remove_mode()>
|
|
for more control over this feature.
|
|
|
|
Use C<dump_log()> to debug when this method keeps timing-out and you
|
|
don't think it should.
|
|
|
|
Consider using a combination of C<print()> and C<waitfor()> as an
|
|
alternative to this method when it doesn't do what you want, e.g. the
|
|
command you send prompts for input.
|
|
|
|
The I<Output> named parameter provides an alternative method of
|
|
receiving command output. If you pass a scalar reference, all the
|
|
output (even if it contains multiple lines) is returned in the
|
|
referenced scalar. If you pass an array or hash reference, the lines
|
|
of output are returned in the referenced array or hash. You can use
|
|
C<input_record_separator()> to change the notion of what separates a
|
|
line.
|
|
|
|
Optional named parameters are provided to override the current
|
|
settings of cmd_remove_mode, errmode, input_record_separator, ors,
|
|
output_record_separator, prompt, rs, and timeout. Rs is synonymous
|
|
with input_record_separator and ors is synonymous with
|
|
output_record_separator.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<cmd_remove_mode> - toggle removal of echoed commands
|
|
|
|
$mode = $obj->cmd_remove_mode;
|
|
|
|
$prev = $obj->cmd_remove_mode($mode);
|
|
|
|
This method controls how to deal with echoed back commands in the
|
|
output returned by cmd(). Typically, when you send a command to the
|
|
remote side, the first line of output returned is the command echoed
|
|
back. Use this mode to remove the first line of output normally
|
|
returned by cmd().
|
|
|
|
If no argument is given, the current mode is returned.
|
|
|
|
If I<$mode> is C<0> then the command output returned from cmd() has no
|
|
lines removed. If I<$mode> is a positive integer, then the first
|
|
I<$mode> lines of command output are stripped.
|
|
|
|
By default, I<$mode> is set to C<"auto">. Auto means that whether or
|
|
not the first line of command output is stripped, depends on whether
|
|
or not the remote side offered to echo. By default, Net::Telnet
|
|
always accepts an offer to echo by the remote side. You can change
|
|
the default to reject such an offer using C<option_accept()>.
|
|
|
|
A warning is printed to STDERR when attempting to set this attribute
|
|
to something that is not C<"auto"> or a non-negative integer.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<dump_log> - log all I/O in dump format
|
|
|
|
$fh = $obj->dump_log;
|
|
|
|
$fh = $obj->dump_log($fh);
|
|
|
|
$fh = $obj->dump_log($filename);
|
|
|
|
This method starts or stops dump format logging of all the object's
|
|
input and output. The dump format shows the blocks read and written
|
|
in a hexadecimal and printable character format. This method is
|
|
useful when debugging, however you might want to first try
|
|
C<input_log()> as it's more readable.
|
|
|
|
If no argument is given, the log filehandle is returned. A returned
|
|
empty string indicates logging is off.
|
|
|
|
To stop logging, use an empty string as an argument. The stopped
|
|
filehandle is not closed.
|
|
|
|
If an open filehandle is given, it is used for logging and returned.
|
|
Otherwise, the argument is assumed to be the name of a file, the
|
|
filename is opened for logging and a filehandle to it is returned. If
|
|
the filehandle is not already opened or the filename can't be opened
|
|
for writing, the error mode action is performed.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<eof> - end of file indicator
|
|
|
|
$eof = $obj->eof;
|
|
|
|
This method returns C<1> if end of file has been read, otherwise it
|
|
returns an empty string. Because the input is buffered this isn't the
|
|
same thing as I<$obj> has closed. In other words I<$obj> can be
|
|
closed but there still can be stuff in the buffer to be read. Under
|
|
this condition you can still read but you won't be able to write.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<errmode> - define action to be performed on error
|
|
|
|
$mode = $obj->errmode;
|
|
|
|
$prev = $obj->errmode($mode);
|
|
|
|
This method gets or sets the action used when errors are encountered
|
|
using the object. The first calling sequence returns the current
|
|
error mode. The second calling sequence sets it to I<$mode> and
|
|
returns the previous mode. Valid values for I<$mode> are C<"die">
|
|
(the default), C<"return">, a I<coderef>, or an I<arrayref>.
|
|
|
|
When mode is C<"die"> and an error is encountered using the object,
|
|
then an error message is printed to standard error and the program
|
|
dies.
|
|
|
|
When mode is C<"return"> then the method generating the error places
|
|
an error message in the object and returns an undefined value in a
|
|
scalar context and an empty list in list context. The error message
|
|
may be obtained using C<errmsg()>.
|
|
|
|
When mode is a I<coderef>, then when an error is encountered
|
|
I<coderef> is called with the error message as its first argument.
|
|
Using this mode you may have your own subroutine handle errors. If
|
|
I<coderef> itself returns then the method generating the error returns
|
|
undefined or an empty list depending on context.
|
|
|
|
When mode is an I<arrayref>, the first element of the array must be a
|
|
I<coderef>. Any elements that follow are the arguments to I<coderef>.
|
|
When an error is encountered, the I<coderef> is called with its
|
|
arguments. Using this mode you may have your own subroutine handle
|
|
errors. If the I<coderef> itself returns then the method generating
|
|
the error returns undefined or an empty list depending on context.
|
|
|
|
A warning is printed to STDERR when attempting to set this attribute
|
|
to something that is not C<"die">, C<"return">, a I<coderef>, or an
|
|
I<arrayref> whose first element isn't a I<coderef>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<errmsg> - most recent error message
|
|
|
|
$msg = $obj->errmsg;
|
|
|
|
$prev = $obj->errmsg(@msgs);
|
|
|
|
The first calling sequence returns the error message associated with
|
|
the object. The empty string is returned if no error has been
|
|
encountered yet. The second calling sequence sets the error message
|
|
for the object to the concatenation of I<@msgs> and returns the
|
|
previous error message. Normally, error messages are set internally
|
|
by a method when an error is encountered.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<error> - perform the error mode action
|
|
|
|
$obj->error(@msgs);
|
|
|
|
This method concatenates I<@msgs> into a string and places it in the
|
|
object as the error message. Also see C<errmsg()>. It then performs
|
|
the error mode action. Also see C<errmode()>.
|
|
|
|
If the error mode doesn't cause the program to die, then an undefined
|
|
value or an empty list is returned depending on the context.
|
|
|
|
This method is primarily used by this class or a sub-class to perform
|
|
the user requested action when an error is encountered.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<family> - IP address family for remote host
|
|
|
|
$family = $obj->family;
|
|
|
|
$prev = $obj->family($family);
|
|
|
|
This method designates which IP address family C<host()> refers to,
|
|
i.e. IPv4 or IPv6. IPv6 support is available when using perl 5.14 or
|
|
later. With no argument it returns the current value set in the
|
|
object. With an argument it sets the current address family to
|
|
I<$family> and returns the previous address family. Valid values are
|
|
C<"ipv4">, C<"ipv6">, or C<"any">. When C<"any">, the C<host()> can
|
|
be a hostname or IP address for either IPv4 or IPv6. After
|
|
connecting, you can use C<sockfamily()> to determine which IP address
|
|
family was used.
|
|
|
|
The default value is C<"ipv4">.
|
|
|
|
The error mode action is performed when attempting to set this
|
|
attribute to something that isn't C<"ipv4">, C<"ipv6">, or C<"any">.
|
|
It is also performed when attempting to set it to C<"ipv6"> when the
|
|
Socket module is less than version 1.94 or IPv6 is not supported in
|
|
the OS as indicated by Socket::AF_INET6 not being defined.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<fhopen> - use already open filehandle for I/O
|
|
|
|
$ok = $obj->fhopen($fh);
|
|
|
|
This method associates the open filehandle I<$fh> with I<$obj> for
|
|
further I/O. Filehandle I<$fh> must already be opened.
|
|
|
|
Suppose you want to use the features of this module to do I/O to
|
|
something other than a TCP port, for example STDIN or a filehandle
|
|
opened to read from a process. Instead of opening the object for I/O
|
|
to a TCP port by using C<open()> or C<new()>, call this method
|
|
instead.
|
|
|
|
The value C<1> is returned success, the error mode action is performed
|
|
on failure.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<get> - read block of data
|
|
|
|
$data = $obj->get([Binmode => $mode,]
|
|
[Errmode => $errmode,]
|
|
[Telnetmode => $mode,]
|
|
[Timeout => $secs,]);
|
|
|
|
This method reads a block of data from the object and returns it along
|
|
with any buffered data. If no buffered data is available to return,
|
|
it will wait for data to read using the timeout specified in the
|
|
object. You can override that timeout using I<$secs>. Also see
|
|
C<timeout()>. If buffered data is available to return, it also checks
|
|
for a block of data that can be immediately read.
|
|
|
|
On eof an undefined value is returned. On time-out or other failures,
|
|
the error mode action is performed. To distinguish between eof or an
|
|
error occurring when the error mode is not set to C<"die">, use
|
|
C<eof()>.
|
|
|
|
Optional named parameters are provided to override the current
|
|
settings of binmode, errmode, telnetmode, and timeout.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<getline> - read next line
|
|
|
|
$line = $obj->getline([Binmode => $mode,]
|
|
[Errmode => $errmode,]
|
|
[Input_record_separator => $chars,]
|
|
[Rs => $chars,]
|
|
[Telnetmode => $mode,]
|
|
[Timeout => $secs,]);
|
|
|
|
This method reads and returns the next line of data from the object.
|
|
You can use C<input_record_separator()> to change the notion of what
|
|
separates a line. The default is C<"\n">. If a line isn't
|
|
immediately available, this method blocks waiting for a line or a
|
|
time-out.
|
|
|
|
On eof an undefined value is returned. On time-out or other failures,
|
|
the error mode action is performed. To distinguish between eof or an
|
|
error occurring when the error mode is not set to C<"die">, use
|
|
C<eof()>.
|
|
|
|
Optional named parameters are provided to override the current
|
|
settings of binmode, errmode, input_record_separator, rs, telnetmode,
|
|
and timeout. Rs is synonymous with input_record_separator.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<getlines> - read next lines
|
|
|
|
@lines = $obj->getlines([Binmode => $mode,]
|
|
[Errmode => $errmode,]
|
|
[Input_record_separator => $chars,]
|
|
[Rs => $chars,]
|
|
[Telnetmode => $mode,]
|
|
[Timeout => $secs,]
|
|
[All => $boolean,]);
|
|
|
|
This method reads and returns all the lines of data from the object
|
|
until end of file is read. You can use C<input_record_separator()> to
|
|
change the notion of what separates a line. The default is C<"\n">.
|
|
A time-out error occurs if all the lines can't be read within the
|
|
time-out interval. See C<timeout()>.
|
|
|
|
The behavior of this method was changed in version 3.03. Prior to
|
|
version 3.03 this method returned just the lines available from the
|
|
next read. To get that old behavior, use the optional named parameter
|
|
I<All> and set I<$boolean> to C<""> or C<0>.
|
|
|
|
If only eof is read then an empty list is returned. On time-out or
|
|
other failures, the error mode action is performed. Use C<eof()> to
|
|
distinguish between reading only eof or an error occurring when the
|
|
error mode is not set to C<"die">.
|
|
|
|
Optional named parameters are provided to override the current
|
|
settings of binmode, errmode, input_record_separator, rs, telnetmode,
|
|
and timeout. Rs is synonymous with input_record_separator.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<host> - name or IP address of remote host
|
|
|
|
$host = $obj->host;
|
|
|
|
$prev = $obj->host($host);
|
|
|
|
This method designates the remote host for C<open()>. It is either a
|
|
hostname or an IP address. With no argument it returns the current
|
|
value set in the object. With an argument it sets the current host
|
|
name to I<$host> and returns the previous value. Use C<family()> to
|
|
control which IP address family, IPv4 or IPv6, host refers to.
|
|
|
|
The default value is C<"localhost">. It may also be set by C<open()>
|
|
or C<new()>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<input_log> - log all input
|
|
|
|
$fh = $obj->input_log;
|
|
|
|
$fh = $obj->input_log($fh);
|
|
|
|
$fh = $obj->input_log($filename);
|
|
|
|
This method starts or stops logging of input. This is useful when
|
|
debugging. Also see C<dump_log()>. Because most command interpreters
|
|
echo back commands received, it's likely all your output will also be
|
|
in this log. Note that input logging occurs after newline
|
|
translation. See C<binmode()> for details on newline translation.
|
|
|
|
If no argument is given, the log filehandle is returned. A returned
|
|
empty string indicates logging is off.
|
|
|
|
To stop logging, use an empty string as an argument. The stopped
|
|
filehandle is not closed.
|
|
|
|
If an open filehandle is given, it is used for logging and returned.
|
|
Otherwise, the argument is assumed to be the name of a file, the
|
|
filename is opened for logging and a filehandle to it is returned. If
|
|
the filehandle is not already opened or the filename can't be opened
|
|
for writing, the error mode action is performed.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<input_record_separator> - input line delimiter
|
|
|
|
$chars = $obj->input_record_separator;
|
|
|
|
$prev = $obj->input_record_separator($chars);
|
|
|
|
This method designates the line delimiter for input. It's used with
|
|
C<getline()>, C<getlines()>, and C<cmd()> to determine lines in the
|
|
input.
|
|
|
|
With no argument this method returns the current input record
|
|
separator set in the object. With an argument it sets the input
|
|
record separator to I<$chars> and returns the previous value. Note
|
|
that I<$chars> must have length.
|
|
|
|
A warning is printed to STDERR when attempting to set this attribute
|
|
to a string with no length.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<last_prompt> - last prompt read
|
|
|
|
$string = $obj->last_prompt;
|
|
|
|
$prev = $obj->last_prompt($string);
|
|
|
|
With no argument this method returns the last prompt read by cmd() or
|
|
login(). See C<prompt()>. With an argument it sets the last prompt
|
|
read to I<$string> and returns the previous value. Normally, only
|
|
internal methods set the last prompt.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<lastline> - last line read
|
|
|
|
$line = $obj->lastline;
|
|
|
|
$prev = $obj->lastline($line);
|
|
|
|
This method retrieves the last line read from the object. This may be
|
|
a useful error message when the remote side abnormally closes the
|
|
connection. Typically the remote side will print an error message
|
|
before closing.
|
|
|
|
With no argument this method returns the last line read from the
|
|
object. With an argument it sets the last line read to I<$line> and
|
|
returns the previous value. Normally, only internal methods set the
|
|
last line.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<localfamily> - IP address family for local host
|
|
|
|
$localfamily = $obj->localfamily;
|
|
|
|
$prev = $obj->localfamily($family);
|
|
|
|
This method designates which IP address family C<localhost()> refers
|
|
to, i.e. IPv4 or IPv6. IPv6 support is available when using perl 5.14
|
|
or later. With no argument it returns the current value set in the
|
|
object. With an argument it sets the current local address family to
|
|
I<$family> and returns the previous address family. Valid values
|
|
are C<"ipv4">, C<"ipv6">, or C<"any">. When C<"any">, the
|
|
C<localhost()> can be a hostname or IP address for either IPv4 or
|
|
IPv6.
|
|
|
|
The default value is C<"ipv4">.
|
|
|
|
The error mode action is performed when attempting to set this
|
|
attribute to something that isn't C<"ipv4">, C<"ipv6">, or C<"any">.
|
|
It is also performed when attempting to set it to C<"ipv6"> when the
|
|
Socket module is less than version 1.94 or IPv6 is not supported in
|
|
the OS as indicated by Socket::AF_INET6 not being defined.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<localhost> - bind local socket to a specific network interface
|
|
|
|
$localhost = $obj->localhost;
|
|
|
|
$prev = $obj->localhost($host);
|
|
|
|
This method designates the local socket IP address for C<open()>. It
|
|
is either a hostname, an IP address, or a null string (i.e. C<"">). A
|
|
null string disables this feature.
|
|
|
|
Normally the OS picks which local network interface to use. This
|
|
method is useful when the local machine has more than one network
|
|
interface and you want to bind to a specific one. With no argument it
|
|
returns the current value set in the object. With an argument it sets
|
|
the current local host name to I<$host> and returns the previous
|
|
value. Use C<localfamily()> to control which IP address family, IPv4
|
|
or IPv6, local host refers to.
|
|
|
|
The default value is C<"">.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<login> - perform standard login
|
|
|
|
$ok = $obj->login($username, $password);
|
|
|
|
$ok = $obj->login(Name => $username,
|
|
Password => $password,
|
|
[Errmode => $mode,]
|
|
[Prompt => $match,]
|
|
[Timeout => $secs,]);
|
|
|
|
This method performs a standard login by waiting for a login prompt
|
|
and responding with I<$username>, then waiting for the password prompt
|
|
and responding with I<$password>, and then waiting for the command
|
|
interpreter prompt. If any of those prompts sent by the remote side
|
|
don't match what's expected, this method will time-out, unless timeout
|
|
is turned off.
|
|
|
|
Login prompt must match either of these case insensitive patterns:
|
|
|
|
/login[: ]*$/i
|
|
/username[: ]*$/i
|
|
|
|
Password prompt must match this case insensitive pattern:
|
|
|
|
/password[: ]*$/i
|
|
|
|
The command interpreter prompt must match the current setting of
|
|
prompt. See C<prompt()>.
|
|
|
|
Use C<dump_log()> to debug when this method keeps timing-out and you
|
|
don't think it should.
|
|
|
|
Consider using a combination of C<print()> and C<waitfor()> as an
|
|
alternative to this method when it doesn't do what you want, e.g. the
|
|
remote host doesn't prompt for a username.
|
|
|
|
On success, C<1> is returned. On time out, eof, or other failures,
|
|
the error mode action is performed. See C<errmode()>.
|
|
|
|
Optional named parameters are provided to override the current
|
|
settings of errmode, prompt, and timeout.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<max_buffer_length> - maximum size of input buffer
|
|
|
|
$len = $obj->max_buffer_length;
|
|
|
|
$prev = $obj->max_buffer_length($len);
|
|
|
|
This method designates the maximum size of the input buffer. An error
|
|
is generated when a read causes the buffer to exceed this limit. The
|
|
default value is 1,048,576 bytes (1 MiB). The input buffer can grow
|
|
much larger than the block size when you continuously read using
|
|
C<getline()> or C<waitfor()> and the data stream contains no newlines
|
|
or matching waitfor patterns.
|
|
|
|
With no argument, this method returns the current maximum buffer
|
|
length set in the object. With an argument it sets the maximum buffer
|
|
length to I<$len> and returns the previous value. Values of I<$len>
|
|
smaller than 512 will be adjusted to 512.
|
|
|
|
A warning is printed to STDERR when attempting to set this attribute
|
|
to something that isn't a positive integer.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<ofs> - field separator for print
|
|
|
|
$chars = $obj->ofs
|
|
|
|
$prev = $obj->ofs($chars);
|
|
|
|
This method is synonymous with C<output_field_separator()>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<open> - connect to port on remote host
|
|
|
|
$ok = $obj->open($host);
|
|
|
|
$ok = $obj->open([Host => $host,]
|
|
[Port => $port,]
|
|
[Family => $family,]
|
|
[Errmode => $mode,]
|
|
[Timeout => $secs,]
|
|
[Localhost => $host,]
|
|
[Localfamily => $family,]);
|
|
|
|
This method opens a TCP connection to I<$port> on I<$host> for the IP
|
|
address I<$family>. If any of those arguments are missing then the
|
|
current attribute value for the object is used. Specifing I<Host>
|
|
sets that attribute for the object. Specifing any of the other
|
|
optional named parameters overrides the current setting.
|
|
|
|
The default IP address family is C<"ipv4">. I<$family> may be set to
|
|
C<"ipv4">, C<"ipv6">, or C<"any">. See C<family()> for more details.
|
|
|
|
I<Localhost> is used to bind to a specific local network interface.
|
|
|
|
If the object is already open, it is closed before attempting a
|
|
connection.
|
|
|
|
On success C<1> is returned. On time-out or other connection
|
|
failures, the error mode action is performed. See C<errmode()>.
|
|
|
|
Time-outs don't work for this method on machines that don't implement
|
|
SIGALRM - most notably MS-Windows machines. For those machines, an
|
|
error is returned when the system reaches its own time-out while
|
|
trying to connect.
|
|
|
|
A side effect of this method is to reset the alarm interval associated
|
|
with SIGALRM.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<option_accept> - indicate willingness to accept a TELNET option
|
|
|
|
$fh = $obj->option_accept([Do => $telopt,]
|
|
[Dont => $telopt,]
|
|
[Will => $telopt,]
|
|
[Wont => $telopt,]);
|
|
|
|
This method is used to indicate whether to accept or reject an offer
|
|
to enable a TELNET option made by the remote side. If you're using
|
|
I<Do> or I<Will> to indicate a willingness to enable, then a
|
|
notification callback must have already been defined by a prior call
|
|
to C<option_callback()>. See C<option_callback()> for details on
|
|
receiving enable/disable notification of a TELNET option.
|
|
|
|
You can give multiple I<Do>, I<Dont>, I<Will>, or I<Wont> arguments
|
|
for different TELNET options in the same call to this method.
|
|
|
|
The following example describes the meaning of the named parameters.
|
|
A TELNET option, such as C<TELOPT_ECHO> used below, is an integer
|
|
constant that you can import from Net::Telnet. See the source in file
|
|
Telnet.pm for the complete list.
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
I<Do> => C<TELOPT_ECHO>
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
we'll accept an offer to enable the echo option on the local side
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<Dont> => C<TELOPT_ECHO>
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
we'll reject an offer to enable the echo option on the local side
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<Will> => C<TELOPT_ECHO>
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
we'll accept an offer to enable the echo option on the remote side
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<Wont> => C<TELOPT_ECHO>
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
we'll reject an offer to enable the echo option on the remote side
|
|
|
|
=back
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
Use C<option_send()> to send a request to the remote side to enable or
|
|
disable a particular TELNET option.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<option_callback> - define the option negotiation callback
|
|
|
|
$coderef = $obj->option_callback;
|
|
|
|
$prev = $obj->option_callback($coderef);
|
|
|
|
This method defines the callback subroutine that is called when a
|
|
TELNET option is enabled or disabled. Once defined, the
|
|
I<option_callback> may not be undefined. However, calling this method
|
|
with a different I<$coderef> changes it.
|
|
|
|
A warning is printed to STDERR when attempting to set this attribute
|
|
to something that isn't a coderef.
|
|
|
|
Here are the circumstances that invoke I<$coderef>:
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
An option becomes enabled because the remote side requested an enable
|
|
and C<option_accept()> had been used to arrange that it be accepted.
|
|
|
|
=item
|
|
|
|
The remote side arbitrarily decides to disable an option that is
|
|
currently enabled. Note that Net::Telnet always accepts a request to
|
|
disable from the remote side.
|
|
|
|
=item
|
|
|
|
C<option_send()> was used to send a request to enable or disable an
|
|
option and the response from the remote side has just been received.
|
|
Note, that if a request to enable is rejected then I<$coderef> is
|
|
still invoked even though the option didn't change.
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
Here are the arguments passed to I<&$coderef>:
|
|
|
|
&$coderef($obj, $option, $is_remote,
|
|
$is_enabled, $was_enabled, $buf_position);
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
1. I<$obj> is the Net::Telnet object
|
|
|
|
=item
|
|
|
|
2. I<$option> is the TELNET option. Net::Telnet exports constants
|
|
for the various TELNET options which just equate to an integer.
|
|
|
|
=item
|
|
|
|
3. I<$is_remote> is a boolean indicating for which side the option
|
|
applies.
|
|
|
|
=item
|
|
|
|
4. I<$is_enabled> is a boolean indicating the option is enabled or
|
|
disabled
|
|
|
|
=item
|
|
|
|
5. I<$was_enabled> is a boolean indicating the option was previously
|
|
enabled or disabled
|
|
|
|
=item
|
|
|
|
6. I<$buf_position> is an integer indicating the position in the
|
|
object's input buffer where the option takes effect. See C<buffer()>
|
|
to access the object's input buffer.
|
|
|
|
=back
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<option_log> - log all TELNET options sent or received
|
|
|
|
$fh = $obj->option_log;
|
|
|
|
$fh = $obj->option_log($fh);
|
|
|
|
$fh = $obj->option_log($filename);
|
|
|
|
This method starts or stops logging of all TELNET options being sent
|
|
or received. This is useful for debugging when you send options via
|
|
C<option_send()> or you arrange to accept option requests from the
|
|
remote side via C<option_accept()>. Also see C<dump_log()>.
|
|
|
|
If no argument is given, the log filehandle is returned. An empty
|
|
string indicates logging is off.
|
|
|
|
To stop logging, use an empty string as an argument. The stopped
|
|
filehandle is not closed.
|
|
|
|
If an open filehandle is given, it is used for logging and returned.
|
|
Otherwise, the argument is assumed to be the name of a file, the
|
|
filename is opened for logging and a filehandle to it is returned. If
|
|
the filehandle is not already opened or the filename can't be opened
|
|
for writing, the error mode action is performed.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<option_send> - send TELNET option negotiation request
|
|
|
|
$ok = $obj->option_send([Do => $telopt,]
|
|
[Dont => $telopt,]
|
|
[Will => $telopt,]
|
|
[Wont => $telopt,]
|
|
[Async => $boolean,]);
|
|
|
|
This method is not yet implemented. Look for it in a future version.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<option_state> - get current state of a TELNET option
|
|
|
|
$hashref = $obj->option_state($telopt);
|
|
|
|
This method returns a hashref containing a copy of the current state
|
|
of TELNET option I<$telopt>.
|
|
|
|
Here are the values returned in the hash:
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
I<$hashref>->{remote_enabled}
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
boolean that indicates if the option is enabled on the remote side.
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<$hashref>->{remote_enable_ok}
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
boolean that indicates if it's ok to accept an offer to enable this
|
|
option on the remote side.
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<$hashref>->{remote_state}
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
string used to hold the internal state of option negotiation for this
|
|
option on the remote side.
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<$hashref>->{local_enabled}
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
boolean that indicates if the option is enabled on the local side.
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<$hashref>->{local_enable_ok}
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
boolean that indicates if it's ok to accept an offer to enable this
|
|
option on the local side.
|
|
|
|
=back
|
|
|
|
=item
|
|
|
|
I<$hashref>->{local_state}
|
|
|
|
=over 4
|
|
|
|
=item
|
|
|
|
string used to hold the internal state of option negotiation for this
|
|
option on the local side.
|
|
|
|
=back
|
|
|
|
=back
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<ors> - output line delimiter
|
|
|
|
$chars = $obj->ors;
|
|
|
|
$prev = $obj->ors($chars);
|
|
|
|
This method is synonymous with C<output_record_separator()>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<output_field_separator> - field separator for print
|
|
|
|
$chars = $obj->output_field_separator;
|
|
|
|
$prev = $obj->output_field_separator($chars);
|
|
|
|
This method designates the output field separator for C<print()>.
|
|
Ordinarily the print method simply prints out the comma separated
|
|
fields you specify. Set this to specify what's printed between
|
|
fields.
|
|
|
|
With no argument this method returns the current output field
|
|
separator set in the object. With an argument it sets the output
|
|
field separator to I<$chars> and returns the previous value.
|
|
|
|
By default it's set to an empty string.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<output_log> - log all output
|
|
|
|
$fh = $obj->output_log;
|
|
|
|
$fh = $obj->output_log($fh);
|
|
|
|
$fh = $obj->output_log($filename);
|
|
|
|
This method starts or stops logging of output. This is useful when
|
|
debugging. Also see C<dump_log()>. Because most command interpreters
|
|
echo back commands received, it's likely all your output would also be
|
|
in an input log. See C<input_log()>. Note that output logging occurs
|
|
before newline translation. See C<binmode()> for details on newline
|
|
translation.
|
|
|
|
If no argument is given, the log filehandle is returned. A returned
|
|
empty string indicates logging is off.
|
|
|
|
To stop logging, use an empty string as an argument. The stopped
|
|
filehandle is not closed.
|
|
|
|
If an open filehandle is given, it is used for logging and returned.
|
|
Otherwise, the argument is assumed to be the name of a file, the
|
|
filename is opened for logging and a filehandle to it is returned. If
|
|
the filehandle is not already opened or the filename can't be opened
|
|
for writing, the error mode action is performed.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<output_record_separator> - output line delimiter
|
|
|
|
$chars = $obj->output_record_separator;
|
|
|
|
$prev = $obj->output_record_separator($chars);
|
|
|
|
This method designates the output line delimiter for C<print()> and
|
|
C<cmd()>. Set this to specify what's printed at the end of C<print()>
|
|
and C<cmd()>.
|
|
|
|
The output record separator is set to C<"\n"> by default, so there's
|
|
no need to append all your commands with a newline. To avoid printing
|
|
the output_record_separator use C<put()> or set the
|
|
output_record_separator to an empty string.
|
|
|
|
With no argument this method returns the current output record
|
|
separator set in the object. With an argument it sets the output
|
|
record separator to I<$chars> and returns the previous value.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<peerhost> - IP address of the other end of the socket connection
|
|
|
|
$ipaddr = $obj->peerhost;
|
|
|
|
This method returns a string which is the IPv4 or IPv6 address the
|
|
remote socket is bound to (i.e. it is the IP address of C<host()>).
|
|
It returns C<""> when not connected.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<peerport> - TCP port of the other end of the socket connection
|
|
|
|
$port = $obj->peerport;
|
|
|
|
This method returns the port number which the remote socket is bound
|
|
to. It is the same as the C<port()> number when connected. It
|
|
returns C<""> when not connected.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<port> - remote port
|
|
|
|
$port = $obj->port;
|
|
|
|
$prev = $obj->port($port);
|
|
|
|
This method designates the remote TCP port for C<open()>. With no
|
|
argument this method returns the current port number. With an
|
|
argument it sets the current port number to I<$port> and returns the
|
|
previous port. If I<$port> is a TCP service name, then it's first
|
|
converted to a port number using the perl function C<getservbyname()>.
|
|
|
|
The default value is C<23>.
|
|
|
|
The error mode action is performed when attempting to set this
|
|
attribute to something that is not a positive integer or a valid TCP
|
|
service name.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<print> - write to object
|
|
|
|
$ok = $obj->print(@list);
|
|
|
|
This method writes I<@list> followed by the I<output_record_separator>
|
|
to the open object and returns C<1> if all data was successfully
|
|
written. On time-out or other failures, the error mode action is
|
|
performed. See C<errmode()>.
|
|
|
|
By default, the C<output_record_separator()> is set to C<"\n"> so all
|
|
your commands automatically end with a newline. In most cases your
|
|
output is being read by a command interpreter which won't accept a
|
|
command until newline is read. This is similar to someone typing a
|
|
command and hitting the return key. To avoid printing a trailing
|
|
C<"\n"> use C<put()> instead or set the output_record_separator to an
|
|
empty string.
|
|
|
|
On failure, it's possible that some data was written. If you choose
|
|
to try and recover from a print timing-out, use C<print_length()> to
|
|
determine how much was written before the error occurred.
|
|
|
|
You may also use the output field separator to print a string between
|
|
the list elements. See C<output_field_separator()>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<print_length> - number of bytes written by print
|
|
|
|
$num = $obj->print_length;
|
|
|
|
This returns the number of bytes successfully written by the most
|
|
recent C<print()> or C<put()>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<prompt> - pattern to match a prompt
|
|
|
|
$matchop = $obj->prompt;
|
|
|
|
$prev = $obj->prompt($matchop);
|
|
|
|
This method sets the pattern used to find a prompt in the input
|
|
stream. It must be a string representing a valid perl pattern match
|
|
operator. The methods C<login()> and C<cmd()> try to read until
|
|
matching the prompt. They will fail with a time-out error if the
|
|
pattern you've chosen doesn't match what the remote side sends.
|
|
|
|
With no argument this method returns the prompt set in the object.
|
|
With an argument it sets the prompt to I<$matchop> and returns the
|
|
previous value.
|
|
|
|
The default prompt is C<'/[\$%#E<gt>] $/'>
|
|
|
|
Always use single quotes, instead of double quotes, to construct
|
|
I<$matchop> (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like
|
|
file path, you'll need to use four backslashes to represent one
|
|
(e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>).
|
|
|
|
Of course don't forget about regexp metacharacters like C<.>, C<[>, or
|
|
C<$>. You'll only need a single backslash to quote them. The anchor
|
|
metacharacters C<^> and C<$> refer to positions in the input buffer.
|
|
|
|
The error mode action is performed when attempting to set this
|
|
attribute with a match operator missing its opening delimiter.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<put> - write to object
|
|
|
|
$ok = $obj->put($string);
|
|
|
|
$ok = $obj->put(String => $string,
|
|
[Binmode => $mode,]
|
|
[Errmode => $errmode,]
|
|
[Telnetmode => $mode,]
|
|
[Timeout => $secs,]);
|
|
|
|
This method writes I<$string> to the opened object and returns C<1> if
|
|
all data was successfully written. This method is like C<print()>
|
|
except that it doesn't write the trailing output_record_separator
|
|
("\n" by default). On time-out or other failures, the error mode
|
|
action is performed. See C<errmode()>.
|
|
|
|
On failure, it's possible that some data was written. If you choose
|
|
to try and recover from a put timing-out, use C<print_length()> to
|
|
determine how much was written before the error occurred.
|
|
|
|
Optional named parameters are provided to override the current
|
|
settings of binmode, errmode, telnetmode, and timeout.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<rs> - input line delimiter
|
|
|
|
$chars = $obj->rs;
|
|
|
|
$prev = $obj->rs($chars);
|
|
|
|
This method is synonymous with C<input_record_separator()>.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<sockfamily> - IP address family of connected local socket
|
|
|
|
$sockfamily = $obj->sockfamily;
|
|
|
|
This method returns which IP address family C<open()> used to
|
|
successfully connect. It is most useful when the requested address
|
|
C<family()> for C<open()> was C<"any">. Values returned may be
|
|
C<"ipv4">, C<"ipv6">, or C<""> (when not connected).
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<sockhost> - IP address of this end of the socket connection
|
|
|
|
$ipaddr = $obj->sockhost;
|
|
|
|
This method returns a string which is the IPv4 or IPv6 address the
|
|
local socket is bound to. It returns C<""> when not connected.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<sockport> - TCP port of this end of the socket connection
|
|
|
|
$port = $obj->sockport;
|
|
|
|
This method returns the port number which the local socket is bound
|
|
to. It returns C<""> when not connected.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<telnetmode> - turn off/on telnet command interpretation
|
|
|
|
$mode = $obj->telnetmode;
|
|
|
|
$prev = $obj->telnetmode($mode);
|
|
|
|
This method controls whether or not TELNET commands in the data stream
|
|
are recognized and handled. The TELNET protocol uses certain
|
|
character sequences sent in the data stream to control the session.
|
|
If the port you're connecting to isn't using the TELNET protocol, then
|
|
you should turn this mode off. The default is I<on>.
|
|
|
|
If no argument is given, the current mode is returned.
|
|
|
|
If I<$mode> is C<0> then telnet mode is off. If I<$mode> is C<1> then
|
|
telnet mode is on.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<timed_out> - time-out indicator
|
|
|
|
$boolean = $obj->timed_out;
|
|
|
|
$prev = $obj->timed_out($boolean);
|
|
|
|
This method indicates if a previous read, write, or open method
|
|
timed-out. Remember that timing-out is itself an error. To be able
|
|
to invoke C<timed_out()> after a time-out error, you'd have to change
|
|
the default error mode to something other than C<"die">. See
|
|
C<errmode()>.
|
|
|
|
With no argument this method returns C<1> if the previous method
|
|
timed-out. With an argument it sets the indicator. Normally, only
|
|
internal methods set this indicator.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<timeout> - I/O time-out interval
|
|
|
|
$secs = $obj->timeout;
|
|
|
|
$prev = $obj->timeout($secs);
|
|
|
|
This method sets the timeout interval used when performing I/O
|
|
or connecting to a port. When a method doesn't complete within the
|
|
timeout interval then it's an error and the error mode action is
|
|
performed.
|
|
|
|
A timeout may be expressed as a relative or absolute value. If
|
|
I<$secs> is greater than or equal to the time the program started, as
|
|
determined by $^T, then it's an absolute time value for when time-out
|
|
occurs. The perl function C<time()> may be used to obtain an absolute
|
|
time value. For a relative time-out value less than $^T, time-out
|
|
happens I<$secs> from when the method begins.
|
|
|
|
If I<$secs> is C<0> then time-out occurs if the data cannot be
|
|
immediately read or written. Use the undefined value to turn off
|
|
timing-out completely.
|
|
|
|
With no argument this method returns the timeout set in the object.
|
|
With an argument it sets the timeout to I<$secs> and returns the
|
|
previous value. The default timeout value is C<10> seconds.
|
|
|
|
A warning is printed to STDERR when attempting to set this attribute
|
|
to something that is not an C<undef> or a non-negative integer.
|
|
|
|
=back
|
|
|
|
|
|
=over 4
|
|
|
|
=item B<waitfor> - wait for pattern in the input
|
|
|
|
$ok = $obj->waitfor($matchop);
|
|
$ok = $obj->waitfor([Match => $matchop,]
|
|
[String => $string,]
|
|
[Binmode => $mode,]
|
|
[Errmode => $errmode,]
|
|
[Telnetmode => $mode,]
|
|
[Timeout => $secs,]);
|
|
|
|
($prematch, $match) = $obj->waitfor($matchop);
|
|
($prematch, $match) = $obj->waitfor([Match => $matchop,]
|
|
[String => $string,]
|
|
[Binmode => $mode,]
|
|
[Errmode => $errmode,]
|
|
[Telnetmode => $mode,]
|
|
[Timeout => $secs,]);
|
|
|
|
This method reads until a pattern match or string is found in the
|
|
input stream. All the characters before and including the match are
|
|
removed from the input stream.
|
|
|
|
In a list context the characters before the match and the matched
|
|
characters are returned in I<$prematch> and I<$match>. In a scalar
|
|
context, the matched characters and all characters before it are
|
|
discarded and C<1> is returned on success. On time-out, eof, or other
|
|
failures, for both list and scalar context, the error mode action is
|
|
performed. See C<errmode()>.
|
|
|
|
You can specify more than one pattern or string by simply providing
|
|
multiple I<Match> and/or I<String> named parameters. A I<$matchop>
|
|
must be a string representing a valid Perl pattern match operator.
|
|
The I<$string> is just a substring to find in the input stream.
|
|
|
|
Use C<dump_log()> to debug when this method keeps timing-out and you
|
|
don't think it should.
|
|
|
|
An optional named parameter is provided to override the current
|
|
setting of timeout.
|
|
|
|
To avoid unexpected backslash interpretation, always use single quotes
|
|
instead of double quotes to construct a match operator argument for
|
|
C<prompt()> and C<waitfor()> (e.g. C<'/bash\$ $/'>). If you're
|
|
constructing a DOS like file path, you'll need to use four backslashes
|
|
to represent one (e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>).
|
|
|
|
Of course don't forget about regexp metacharacters like C<.>, C<[>, or
|
|
C<$>. You'll only need a single backslash to quote them. The anchor
|
|
metacharacters C<^> and C<$> refer to positions in the input buffer.
|
|
|
|
Optional named parameters are provided to override the current
|
|
settings of binmode, errmode, telnetmode, and timeout.
|
|
|
|
=back
|
|
|
|
|
|
=head1 SEE ALSO
|
|
|
|
=over 2
|
|
|
|
=item RFC 854
|
|
|
|
S<TELNET Protocol Specification>
|
|
|
|
S<http://tools.ietf.org/html/rfc854>
|
|
|
|
=item RFC 1143
|
|
|
|
S<Q Method of Implementing TELNET Option Negotiation>
|
|
|
|
S<http://tools.ietf.org/html/rfc1143>
|
|
|
|
=item TELNET Option Assignments
|
|
|
|
S<http://www.iana.org/assignments/telnet-options>
|
|
|
|
=back
|
|
|
|
|
|
=head1 EXAMPLES
|
|
|
|
Setting C<prompt()> to match a user's shell prompt can be tricky.
|
|
This example logs in without knowing the shell prompt and then sets it
|
|
to match C<prompt()>. It requires /usr/bin/env and /bin/sh on the
|
|
remote host.
|
|
|
|
my $host = 'your_destination_host_here';
|
|
my $user = 'your_username_here';
|
|
my $passwd = 'your_password_here';
|
|
my ($t, @output);
|
|
|
|
## Create a Net::Telnet object.
|
|
use Net::Telnet ();
|
|
$t = new Net::Telnet (Timeout => 10);
|
|
|
|
## Connect and login.
|
|
$t->open($host);
|
|
|
|
$t->waitfor('/login: ?$/i');
|
|
$t->print($user);
|
|
|
|
$t->waitfor('/password: ?$/i');
|
|
$t->print($passwd);
|
|
|
|
## Switch to a known shell, using a known prompt.
|
|
$t->prompt('/<xPROMPTx> $/');
|
|
$t->errmode("return");
|
|
|
|
$t->cmd("exec /usr/bin/env 'PS1=<xPROMPTx> ' /bin/sh -i")
|
|
or die "login failed to remote host $host";
|
|
|
|
$t->errmode("die");
|
|
|
|
## Now you can do cmd() to your heart's content.
|
|
@output = $t->cmd("uname -a");
|
|
print @output;
|
|
|
|
exit;
|
|
|
|
|
|
Usually you want the remote TERM environment variable to be
|
|
set to something like "dumb" so you don't read escape
|
|
sequences meant to be interpreted by a display terminal. It
|
|
is best to set it via C<cmd()>, or via C<waitfor()> and
|
|
C<print()>. It is also possible to negotiate the terminal
|
|
type via telnet. Here is how to do that.
|
|
|
|
## Module import.
|
|
use Net::Telnet qw(TELNET_IAC TELNET_SB TELNET_SE TELOPT_TTYPE);
|
|
|
|
## Global variables.
|
|
my $Term;
|
|
|
|
## Main program.
|
|
{
|
|
my $host = "your_destination_host_here";
|
|
my $user = "your_username_here";
|
|
my $passwd = "your_password_here";
|
|
my $prompt = '/bash\$ $/'; # your regexp for shell prompt here
|
|
my $t;
|
|
|
|
$t = new Net::Telnet (Prompt => $prompt);
|
|
|
|
## Set up callbacks to negotiate terminal type.
|
|
$t->option_callback(sub {});
|
|
$t->suboption_callback(\&subopt_callback);
|
|
$t->option_accept(Do => TELOPT_TTYPE);
|
|
|
|
## Login and print value of TERM.
|
|
$Term = "dumb";
|
|
$t->open($host);
|
|
$t->login($user, $passwd);
|
|
print $t->cmd('hostname');
|
|
print "TERM=", $t->cmd('echo $TERM');
|
|
$t->close;
|
|
|
|
exit;
|
|
} # end main program
|
|
|
|
sub subopt_callback {
|
|
my ($t, $option, $parameters) = @_;
|
|
my $telcmd;
|
|
|
|
if ($option == TELOPT_TTYPE) {
|
|
$telcmd = pack("C4 A* C2", TELNET_IAC, TELNET_SB, TELOPT_TTYPE, 0,
|
|
$Term, TELNET_IAC, TELNET_SE);
|
|
$t->put(String => $telcmd,
|
|
Telnetmode => 0);
|
|
}
|
|
|
|
1;
|
|
} # end sub subopt_callback
|
|
|
|
|
|
You can also use Net::Telnet to interact with local programs. This
|
|
example changes a user's login password. It introduces the C<spawn()>
|
|
subroutine to start a program and associate a filehandle with its
|
|
standard I/O. Because the passwd program always prompts for passwords
|
|
on its controlling terminal, the IO::Pty module is used to create a
|
|
new pseudo terminal for use by passwd. The Net::Telnet object reads
|
|
and writes to that pseudo terminal. To use the code below, substitute
|
|
"changeme" with the actual old and new passwords.
|
|
|
|
## Main program.
|
|
{
|
|
my ($pty, $passwd);
|
|
my $oldpw = "changeme";
|
|
my $newpw = "changeme";
|
|
|
|
## Start passwd program.
|
|
$pty = spawn("passwd");
|
|
|
|
## Create a Net::Telnet object to perform I/O on passwd's tty.
|
|
use Net::Telnet;
|
|
$passwd = new Net::Telnet (-fhopen => $pty,
|
|
-timeout => 2,
|
|
-output_record_separator => "\r",
|
|
-telnetmode => 0,
|
|
-cmd_remove_mode => 1);
|
|
$passwd->errmode("return");
|
|
|
|
## Send existing password.
|
|
$passwd->waitfor('/password: ?$/i')
|
|
or die "no old password prompt: ", $passwd->lastline;
|
|
$passwd->print($oldpw);
|
|
|
|
## Send new password.
|
|
$passwd->waitfor('/new (\w+\s)?password: ?$/i')
|
|
or die "bad old password: ", $passwd->lastline;
|
|
$passwd->print($newpw);
|
|
|
|
## Send new password verification.
|
|
$passwd->waitfor('/new (\w+\s)?password: ?$/i')
|
|
or die "bad new password: ", $passwd->lastline;
|
|
$passwd->print($newpw);
|
|
|
|
## Display success or failure.
|
|
$passwd->waitfor('/(changed|updated)/')
|
|
or die "bad new password: ", $passwd->lastline;
|
|
print $passwd->lastline;
|
|
|
|
$passwd->close;
|
|
exit;
|
|
} # end main program
|
|
|
|
sub spawn {
|
|
my (@cmd) = @_;
|
|
my ($pid, $pty, $tty, $tty_fd);
|
|
|
|
## Create a new pseudo terminal.
|
|
use IO::Pty ();
|
|
$pty = new IO::Pty
|
|
or die $!;
|
|
|
|
## Execute the program in another process.
|
|
unless ($pid = fork) { # child process
|
|
die "problem spawning program: $!\n" unless defined $pid;
|
|
|
|
## Disassociate process from its controlling terminal.
|
|
use POSIX ();
|
|
POSIX::setsid()
|
|
or die "setsid failed: $!";
|
|
|
|
## Associate process with a new controlling terminal.
|
|
$pty->make_slave_controlling_terminal;
|
|
$tty = $pty->slave;
|
|
$tty_fd = $tty->fileno;
|
|
close $pty;
|
|
|
|
## Make standard I/O use the new controlling terminal.
|
|
open STDIN, "<&$tty_fd" or die $!;
|
|
open STDOUT, ">&$tty_fd" or die $!;
|
|
open STDERR, ">&STDOUT" or die $!;
|
|
close $tty;
|
|
|
|
## Execute requested program.
|
|
exec @cmd
|
|
or die "problem executing $cmd[0]\n";
|
|
} # end child process
|
|
|
|
$pty;
|
|
} # end sub spawn
|
|
|
|
|
|
Here is an example that uses the openssh program to connect to a
|
|
remote host. It uses the C<spawn()> subroutine, from the password
|
|
changing example above, to start the ssh program and then read and
|
|
write to it via a Net::Telnet object. This example turns off ssh host
|
|
key checking, which reduces your ability to know when someone on the
|
|
network is impersonating the remote host. To use the code below,
|
|
substitute "changeme" with the actual host, user, password, and
|
|
command prompt.
|
|
|
|
## Main program.
|
|
{
|
|
my $host = "changeme";
|
|
my $user = "changeme";
|
|
my $passwd = "changeme";
|
|
my $prompt = '/changeme\$ $/';
|
|
my ($buf, $match, $pty, $ssh, @lines);
|
|
|
|
## Start ssh program.
|
|
$pty = spawn("ssh",
|
|
"-l", $user,
|
|
"-e", "none",
|
|
"-F", "/dev/null",
|
|
"-o", "PreferredAuthentications=password",
|
|
"-o", "NumberOfPasswordPrompts=1",
|
|
"-o", "StrictHostKeyChecking=no",
|
|
"-o", "UserKnownHostsFile=/dev/null",
|
|
$host);
|
|
|
|
## Create a Net::Telnet object to perform I/O on ssh's tty.
|
|
use Net::Telnet;
|
|
$ssh = new Net::Telnet (-fhopen => $pty,
|
|
-prompt => $prompt,
|
|
-telnetmode => 0,
|
|
-output_record_separator => "\r",
|
|
-cmd_remove_mode => 1);
|
|
|
|
## Wait for the password prompt and send password.
|
|
$ssh->waitfor(-match => '/password: ?$/i',
|
|
-errmode => "return")
|
|
or die "problem connecting to \"$host\": ", $ssh->lastline;
|
|
$ssh->print($passwd);
|
|
|
|
## Wait for the shell prompt.
|
|
(undef, $match) = $ssh->waitfor(-match => $ssh->prompt,
|
|
-match => '/^Permission denied/m',
|
|
-errmode => "return")
|
|
or return $ssh->error("login failed: expected shell prompt ",
|
|
"doesn't match actual\n");
|
|
return $ssh->error("login failed: bad login-name or password\n")
|
|
if $match =~ /^Permission denied/m;
|
|
|
|
## Run commands on remote host.
|
|
print $ssh->cmd("hostname");
|
|
print $ssh->cmd("uptime");
|
|
|
|
$ssh->close;
|
|
exit;
|
|
} # end main program
|
|
|
|
|
|
Some shells have a rather restrictive 255 character line limit. If
|
|
you run into this problem, here is an example for sending lines longer
|
|
than 254 as a sequence of shorter lines.
|
|
|
|
## Main program.
|
|
{
|
|
my $host = "changeme";
|
|
my $user = "changeme";
|
|
my $passwd = "changeme";
|
|
my $prompt = '/changeme\$ $/';
|
|
my $cmd = join("", "echo ",
|
|
"11111111112222222222333333333344444444445555555555",
|
|
"66666666667777777777888888888899999999990000000000",
|
|
"11111111112222222222333333333344444444445555555555",
|
|
"66666666667777777777888888888899999999990000000000",
|
|
"11111111112222222222333333333344444444445555555555",
|
|
"66666666667777777777888888888899999999990000000000");
|
|
|
|
use Net::Telnet ();
|
|
my $t = new Net::Telnet (-prompt => $prompt);
|
|
$t->open($host);
|
|
$t->login($user, $passwd);
|
|
|
|
my @output = cmd_unixlong($t, $cmd);
|
|
print @output;
|
|
|
|
exit;
|
|
} # end main program
|
|
|
|
sub cmd_unixlong {
|
|
my ($obj, $cmd) = @_;
|
|
my ($line, $pos);
|
|
my $max_tty_line = 254;
|
|
|
|
## Start a Bourne shell.
|
|
$obj->cmd(-string => "/usr/bin/env " .
|
|
"'PS1=<xPROMPTx> ' 'PS2=<xPROMPTx> ' /bin/sh -i",
|
|
-prompt => '/<xPROMPTx> $/')
|
|
or return;
|
|
|
|
## Break-up the one large command line and send as shorter lines.
|
|
$pos = 0;
|
|
while (1) {
|
|
$line = substr $cmd, $pos, $max_tty_line;
|
|
$pos += length $line;
|
|
last unless $pos < length $cmd;
|
|
|
|
## Send the line with continuation char.
|
|
$obj->cmd(-string => "$line\\",
|
|
-prompt => '/<xPROMPTx> $/')
|
|
or return;
|
|
}
|
|
|
|
## Send the last line and return the output.
|
|
$obj->cmd("$line ; exit");
|
|
} # end sub cmd_unixlong
|
|
|
|
|
|
=head1 AUTHOR
|
|
|
|
Jay Rogers <jay@rgrs.com>
|
|
|
|
=head1 CREDITS
|
|
|
|
Dave Martin, Dave Cardosi
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 1997, 2000, 2002, 2013 by Jay Rogers. All rights reserved.
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl itself.
|