Control-CLI
view release on metacpan or search on metacpan
lib/Control/CLI.pm view on Meta::CPAN
package Control::CLI;
use strict;
use warnings;
use Exporter qw( import );
use Carp;
use Term::ReadKey;
use Time::HiRes qw( time sleep );
use IO::Handle;
use IO::Socket::INET;
use Errno qw( EINPROGRESS EWOULDBLOCK );
my $Package = __PACKAGE__;
our $VERSION = '2.13';
our %EXPORT_TAGS = (
use => [qw(useTelnet useSsh useSerial useIPv6)],
prompt => [qw(promptClear promptHide promptCredential)],
args => [qw(parseMethodArgs suppressMethodArgs)],
coderef => [qw(validCodeRef callCodeRef)],
_rest => [qw(passphraseRequired parse_errmode stripLastLine poll)],
);
push @{$EXPORT_TAGS{all}}, @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
Exporter::export_ok_tags('all');
########################################### Global Class Variables ###########################################
my $PollTimer = 100; # Some connection types require a polling loop; this is the loop sleep timer in ms
my $ComPortReadBuffer = 4096; # Size of serial port read buffers
my $ComReadInterval = 100; # Timeout between single character reads
my $ComBreakDuration = 300; # Number of milliseconds the break signal is held for
my $ComWriteDoneDelay = 1; # Number of milliseconds to wait after every Win32::SerialPort write before checking success
my $ChangeBaudDelay = 100; # Number of milliseconds to sleep between tearing down and restarting serial port connection
my $VT100_QueryDeviceStatus = "\e[5n"; # With report_query_status, if received from host
my $VT100_ReportDeviceOk = "\e[0n"; # .. sent to host, with report_query_status
my %Default = ( # Hash of default object settings which can be modified on a per object basis
timeout => 10, # Default Timeout value in secs
connection_timeout => undef, # Default Connection Timeout value in secs
connection_timeout_nb => 20, # If above is undefined, still need to set a value for connections in non-blocking mode
blocking => 1, # Default blocking mode
return_reference => 0, # Whether methods return data (0) or hard referece to it (1)
read_attempts => 5, # Empty reads to wait in readwait() before returning
readwait_timer => 100, # Polling loop timer for readwait() in millisecs, for further input
data_with_error => 0, # Readwait() behaviour in case of read error following some data read
prompt_credentials => 0, # Interactively prompt for credentials (1) or not (0)
tcp_port => {
SSH => 22, # Default TCP port number for SSH
TELNET => 23, # Default TCP port number for TELNET
},
read_block_size => {
SSH => 4096, # Default Read Block Size for SSH
SERIAL_WIN32 => 1024, # Default Read Block Size for Win32::SerialPort
SERIAL_DEVICE => 255, # Default Read Block Size for Device::SerialPort
},
baudrate => 9600, # Default baud rate used when connecting via Serial port
handshake => 'none', # Default handshake used when connecting via Serial port
parity => 'none', # Default parity used when connecting via Serial port
databits => 8, # Default data bits used when connecting via Serial port
stopbits => 1, # Default stop bits used when connecting via Serial port
ors => "\n", # Default Output Record Separator used by print() & cmd()
binmode => 0, # Default binmode; if disabled newline translation will be done
errmode => 'croak', # Default error mode; can be: die/croak/return/coderef/arrayref
errmsg_format => 'default', # Default error message format; can be: terse/default/verbose
poll_obj_complete => 'all', # Default mode for poll() method
poll_obj_error => 'ignore', # Default error mode for poll() method
report_query_status => 0, # Default setting of report_query_status for class object
prompt => '.*[\?\$%#>](?:\e\[00?m)?\s?$', # Default prompt used in login() and cmd() methods
username_prompt => '(?i:user(?: ?name)?|login)[: ]+$', # Default username prompt used in login() method
password_prompt => '(?i)(?<!new )password[: ]+$', # Default password prompt used in login() method
terminal_type => 'vt100', # Default terminal type (for SSH)
window_size => [], # Default terminal window size [width, height]
debug => 0, # Default debug level; 0 = disabled
);
our @ConstructorArgs = ( 'use', 'timeout', 'errmode', 'return_reference', 'prompt', 'username_prompt', 'password_prompt',
'input_log', 'output_log', 'dump_log', 'blocking', 'debug', 'prompt_credentials', 'read_attempts',
'readwait_timer', 'read_block_size', 'output_record_separator', 'connection_timeout', 'data_with_error',
'terminal_type', 'window_size', 'errmsg_format', 'report_query_status', 'binmode',
);
# Debug levels can be set using the debug() method or via debug argument to new() constructor
# Debug levels defined:
# 0 : No debugging
# bit 1 : Debugging activated for for polling methods + readwait() and enables carping on Win32/Device::SerialPort
# This level also resets Win32/Device::SerialPort constructor $quiet flag only when supplied in Control::CLI::new()
# bit 2 : Debugging is activated on underlying Net::SSH2 and Win32::SerialPort / Device::SerialPort
# There is no actual debugging for Net::Telnet
my ($UseTelnet, $UseSSH, $UseSerial, $UseSocketIP);
############################################## Required modules ##############################################
if (eval {require Net::Telnet}) { # Make Net::Telnet optional
import Net::Telnet qw( TELNET_IAC TELNET_SB TELNET_SE TELNET_WILL TELOPT_TTYPE TELOPT_NAWS );
$UseTelnet = 1
}
$UseSSH = 1 if eval {require Net::SSH2}; # Make Net::SSH2 optional
if ($^O eq 'MSWin32') {
$UseSerial = 1 if eval {require Win32::SerialPort}; # Win32::SerialPort optional on Windows
}
else {
$UseSerial = 1 if eval {require Device::SerialPort}; # Device::SerialPort optional on Unix
}
croak "$Package: no available module installed to operate on" unless $UseTelnet || $UseSSH || $UseSerial;
$UseSocketIP = 1 if eval { require IO::Socket::IP }; # Provides IPv4 and IPv6 support
################################################ Class Methods ###############################################
sub useTelnet {
return $UseTelnet;
}
sub useSsh {
return $UseSSH;
}
sub useSerial {
return $UseSerial;
}
sub useIPv6 {
return $UseSocketIP;
}
sub promptClear { # Interactively prompt for a username, in clear text
my $username = shift;
my $input;
print "Enter $username: ";
ReadMode('normal');
chomp($input = ReadLine(0));
ReadMode('restore');
lib/Control/CLI.pm view on Meta::CPAN
$connectionType = 'SSH';
}
else {
if ($^O eq 'MSWin32') {
croak "$pkgsub: Module 'Win32::SerialPort' required for serial access" unless $UseSerial;
@CLI::ISA = qw(Win32::SerialPort);
Win32::SerialPort->set_test_mode_active(!($debug & 1)); # Suppress carping except if debug bit1 set
Win32::SerialPort::debug($debug & 2 ? 'ON' : 'OFF');
$parent = Win32::SerialPort->new($connectionType, !($debug & 1))
or return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Cannot open serial port '$connectionType'", $msgFormat);
$parent->user_msg($debug & 2); # prints function messages like "Waiting for CTS"
$parent->error_msg($debug & 2); # prints hardware messages like "Framing Error"
}
else {
croak "$pkgsub: Module 'Device::SerialPort' required for serial access" unless $UseSerial;
@CLI::ISA = qw(Device::SerialPort);
Device::SerialPort->set_test_mode_active(!($debug & 1)); # Suppress carping except if debug bit1 set
Device::SerialPort::debug($debug & 2 ? 'ON' : 'OFF');
$parent = Device::SerialPort->new($connectionType, !($debug & 1))
or return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Cannot open serial port '$connectionType'", $msgFormat);
}
$comPort = $connectionType;
$connectionType = 'SERIAL';
}
my $self = {
# Lower Case ones can be set by user; Upper case ones are set internaly in the class
TYPE => $connectionType,
PARENT => $parent,
SOCKET => undef,
SSHCHANNEL => undef,
SSHAUTH => undef,
BUFFER => '', # Always defined; greater than 0 length if in use
QUERYBUFFER => '', # Always defined; greater than 0 length if in use
COMPORT => $comPort,
HOST => undef,
TCPPORT => undef,
HANDSHAKE => undef,
BAUDRATE => undef,
PARITY => undef,
DATABITS => undef,
STOPBITS => undef,
INPUTLOGFH => undef,
OUTPUTLOGFH => undef,
DUMPLOGFH => undef,
USERNAME => undef,
PASSWORD => undef,
PASSPHRASE => undef,
LOGINSTAGE => '',
LASTPROMPT => undef,
SERIALEOF => 1,
TELNETMODE => 1,
PUSHBACKCR => '', # Always defined; used to push back CR in newline translation with binmode disabled
POLL => undef, # Storage hash for poll-capable methods
POLLING => 0, # Flag to track if in polling-capable method or not
POLLREPORTED => 0, # Flag used by poll() to track already reported objects
WRITEFLAG => 0, # Flag to keep track of when a write was last performed
timeout => $Default{timeout},
connection_timeout => $Default{connection_timeout},
blocking => $Default{blocking},
return_reference => $Default{return_reference},
prompt_credentials => $Default{prompt_credentials},
read_attempts => $Default{read_attempts},
readwait_timer => $Default{readwait_timer},
data_with_error => $Default{data_with_error},
read_block_size => $Default{read_block_size}{$connectionType},
ors => $Default{ors},
binmode => $Default{binmode},
errmode => $Default{errmode},
errmsg => '',
errmsg_format => $Default{errmsg_format},
prompt => $Default{prompt},
prompt_qr => qr/$Default{prompt}/,
username_prompt => $Default{username_prompt},
username_prompt_qr => qr/$Default{username_prompt}/,
password_prompt => $Default{password_prompt},
password_prompt_qr => qr/$Default{password_prompt}/,
terminal_type => $connectionType eq 'SSH' ? $Default{terminal_type} : undef,
window_size => $Default{window_size},
report_query_status => $Default{report_query_status},
debug => $Default{debug},
};
if ($connectionType eq 'SERIAL') { # Adjust read_block_size defaults for Win32::SerialPort & Device::SerialPort
$self->{read_block_size} = ($^O eq 'MSWin32') ? $Default{read_block_size}{SERIAL_WIN32}
: $Default{read_block_size}{SERIAL_DEVICE};
}
bless $self, $class;
if ($connectionType eq 'TELNET') {
# We are going to setup option callbacks to handle telnet options terminal type and window size
# However the callbacks only provide the telnet object and there is no option to feed additional arguments
# So need to link our object into the telnet one; here we create a key to contain our object
*$parent->{net_telnet}->{$Package} = $self;
}
foreach my $arg (keys %args) { # Accepted arguments on constructor
if ($arg eq 'errmode') { $self->errmode($args{$arg}) }
elsif ($arg eq 'errmsg_format') { $self->errmsg_format($args{$arg}) }
elsif ($arg eq 'timeout') { $self->timeout($args{$arg}) }
elsif ($arg eq 'connection_timeout') { $self->connection_timeout($args{$arg}) }
elsif ($arg eq 'read_block_size') { $self->read_block_size($args{$arg}) }
elsif ($arg eq 'blocking') { $self->blocking($args{$arg}) }
elsif ($arg eq 'read_attempts') { $self->read_attempts($args{$arg}) }
elsif ($arg eq 'readwait_timer') { $self->readwait_timer($args{$arg}) }
elsif ($arg eq 'data_with_error') { $self->data_with_error($args{$arg}) }
elsif ($arg eq 'return_reference') { $self->return_reference($args{$arg}) }
elsif ($arg eq 'output_record_separator') { $self->output_record_separator($args{$arg}) }
elsif ($arg eq 'binmode') { $self->binmode($args{$arg}) }
elsif ($arg eq 'prompt_credentials') { $self->prompt_credentials($args{$arg}) }
elsif ($arg eq 'prompt') { $self->prompt($args{$arg}) }
elsif ($arg eq 'username_prompt') { $self->username_prompt($args{$arg}) }
elsif ($arg eq 'password_prompt') { $self->password_prompt($args{$arg}) }
elsif ($arg eq 'terminal_type') { $self->terminal_type($args{$arg}) }
elsif ($arg eq 'window_size') { $self->window_size(@{$args{$arg}}) }
elsif ($arg eq 'report_query_status') { $self->report_query_status($args{$arg}) }
elsif ($arg eq 'input_log') { $self->input_log($args{$arg}) }
elsif ($arg eq 'output_log') { $self->output_log($args{$arg}) }
elsif ($arg eq 'dump_log') { $self->dump_log($args{$arg}) }
elsif ($arg eq 'debug') { $self->debug($args{$arg}) }
}
return $self;
}
sub DESTROY { # Run disconnect
my $self = shift;
return $self->disconnect;
}
############################################### Object methods ###############################################
sub connect { # Connect to host
my $pkgsub = "${Package}::connect";
my $self = shift;
my %args;
if (@_ == 1) { # Method invoked in the shorthand form
$args{host} = shift;
if ($args{host} =~ /^(.+?)\s+(\d+)$/ || $args{host} =~ /^([^:\s]+?):(\d+)$/) {
($args{host}, $args{port}) = ($1, $2);
}
}
else {
my @validArgs = ('host', 'port', 'username', 'password', 'publickey', 'privatekey', 'passphrase',
'prompt_credentials', 'baudrate', 'parity', 'databits', 'stopbits', 'handshake',
'errmode', 'connection_timeout', 'blocking', 'terminal_type', 'window_size',
'callback', 'forcebaud', 'atomic_connect');
%args = parseMethodArgs($pkgsub, \@_, \@validArgs);
}
# Initialize the base POLL structure
$self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
$pkgsub,
__PACKAGE__->can('connect_poll'),
defined $args{blocking} ? $args{blocking} : $self->{blocking},
defined $args{connection_timeout} ? $args{connection_timeout} : $self->{connection_timeout},
defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef,
0, # no output
0, # no output
undef, # n/a
undef, # n/a
);
$self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
# Set method argument keys
host => $args{host},
port => $args{port},
username => $args{username},
password => $args{password},
publickey => $args{publickey},
privatekey => $args{privatekey},
passphrase => $args{passphrase},
baudrate => $args{baudrate},
parity => $args{parity},
databits => $args{databits},
stopbits => $args{stopbits},
handshake => $args{handshake},
prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
terminal_type => $args{terminal_type},
window_size => $args{window_size},
callback => $args{callback},
forcebaud => $args{forcebaud},
atomic_connect => $args{atomic_connect},
# Declare method storage keys which will be used
stage => 0,
authPublicKey => 0,
authPassword => 0,
};
if ($self->{TYPE} ne 'SERIAL' && !$UseSocketIP && defined $args{blocking} && !$args{blocking}) {
carp "$pkgsub: IO::Socket::IP is required for non-blocking connect";
}
local $self->{POLLING} = 1; # True until we come out of this polling-capable method
local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
return __PACKAGE__->can('poll_connect')->($self, $pkgsub); # Do not call a sub-classed version
}
sub connect_poll { # Poll status of connection (non-blocking mode)
my $pkgsub = "${Package}::connect_poll";
my $self = shift;
carp "$pkgsub: No arguments expected" if @_; # No arguments expected
unless (defined $self->{POLL} && $self->{POLL}{coderef} == __PACKAGE__->can('connect_poll')) {
return $self->error("$pkgsub: Method connect() needs to be called first with blocking false");
}
local $self->{POLLING} = 1; # True until we come out of this polling-capable method
local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
# If already completed (1) or we got an error (undef) from previous call (errmsg is already set) then we go no further
return $self->poll_return($self->{POLL}{complete}) unless defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0;
# We get here only if we are not complete: $self->{POLL}{complete} == 0
return __PACKAGE__->can('poll_connect')->($self, $pkgsub); # Do not call a sub-classed version
}
sub read { # Read in data from connection
my $pkgsub = "${Package}::read";
my $self = shift;
my @validArgs = ('blocking', 'timeout', 'binmode', 'errmode', 'return_reference');
my %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
my $timeout = defined $args{timeout} ? $args{timeout} : $self->{timeout};
my $blocking = defined $args{blocking} ? $args{blocking} : $self->{blocking};
my $returnRef = defined $args{return_reference} ? $args{return_reference} : $self->{return_reference};
my $binmode = defined $args{binmode} ? $args{binmode} : $self->{binmode};
my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef;
local $self->{binmode} = $binmode if defined $binmode;
local $self->{errmode} = $errmode if defined $errmode;
return $self->_read_blocking($pkgsub, $timeout, $returnRef) if $blocking && !length $self->{BUFFER};
return $self->_read_nonblocking($pkgsub, $returnRef); # if !$blocking || ($blocking && length $self->{BUFFER})
}
sub readwait { # Read in data initially in blocking mode, then perform subsequent non-blocking reads for more
my $pkgsub = "${Package}::readwait";
my $self = shift;
my ($outref, $bufref);
lib/Control/CLI.pm view on Meta::CPAN
# We get here only if we are not complete: $self->{POLL}{complete} == 0
return __PACKAGE__->can('poll_waitfor')->($self, $pkgsub); # Do not call a sub-classed version
}
sub put { # Send character strings to host (no \n appended)
my $pkgsub = "${Package}::put";
my $self = shift;
my %args;
if (@_ == 1) { # Method invoked with just the command argument
$args{string} = shift;
}
else {
my @validArgs = ('string', 'binmode', 'errmode');
%args = parseMethodArgs($pkgsub, \@_, \@validArgs);
}
return 1 unless defined $args{string};
my $binmode = defined $args{binmode} ? $args{binmode} : $self->{binmode};
my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef;
local $self->{binmode} = $binmode if defined $binmode;
local $self->{errmode} = $errmode if defined $errmode;
return $self->_put($pkgsub, \$args{string});
}
sub print { # Send CLI commands to host (\n appended)
my $pkgsub = "${Package}::print";
my $self = shift;
my %args;
if (@_ == 1) { # Method invoked with just the command argument
$args{line} = shift;
}
else {
my @validArgs = ('line', 'binmode', 'errmode');
%args = parseMethodArgs($pkgsub, \@_, \@validArgs);
}
my $binmode = defined $args{binmode} ? $args{binmode} : $self->{binmode};
my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef;
local $self->{binmode} = $binmode if defined $binmode;
local $self->{errmode} = $errmode if defined $errmode;
$args{line} .= $self->{ors};
return $self->_put($pkgsub, \$args{line});
}
sub printlist { # Send multiple lines to host switch (\n appended)
my $pkgsub = "${Package}::printlist";
my $self = shift;
my $output = join($self->{ors}, @_) . $self->{ors};
return $self->_put($pkgsub, \$output);
}
sub login { # Handles basic username/password login for Telnet/Serial login and locks onto 1st prompt
my $pkgsub = "${Package}::login";
my $self =shift;
my @validArgs = ('username', 'password', 'prompt_credentials', 'prompt', 'username_prompt', 'password_prompt',
'timeout', 'errmode', 'return_reference', 'blocking');
my %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
# Initialize the base POLL structure
$self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
$pkgsub,
__PACKAGE__->can('login_poll'),
defined $args{blocking} ? $args{blocking} : $self->{blocking},
defined $args{timeout} ? $args{timeout} : $self->{timeout},
defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef,
1,
wantarray,
defined $args{return_reference} ? $args{return_reference} : $self->{return_reference},
undef, # n/a
);
$self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
# Set method argument keys
username => $args{username},
password => $args{password},
prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
prompt => defined $args{prompt} ? $args{prompt} : $self->{prompt_qr},
username_prompt => defined $args{username_prompt} ? $args{username_prompt} : $self->{username_prompt_qr},
password_prompt => defined $args{password_prompt} ? $args{password_prompt} : $self->{password_prompt_qr},
# Declare method storage keys which will be used
stage => 0,
login_attempted => undef,
};
local $self->{POLLING} = 1; # True until we come out of this polling-capable method
local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
return __PACKAGE__->can('poll_login')->($self, $pkgsub); # Do not call a sub-classed version
}
sub login_poll { # Poll status of login (non-blocking mode)
my $pkgsub = "${Package}::login_poll";
my $self = shift;
carp "$pkgsub: No arguments expected" if @_; # No arguments expected
unless (defined $self->{POLL} && $self->{POLL}{coderef} == __PACKAGE__->can('login_poll')) {
return $self->error("$pkgsub: Method login() needs to be called first with blocking false");
}
$self->{POLL}{output_requested} = wantarray; # This might change at every call
local $self->{POLLING} = 1; # True until we come out of this polling-capable method
local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
# If already completed (1) or we got an error (undef) from previous call (errmsg is already set) then we go no further
return $self->poll_return($self->{POLL}{complete}) unless defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0;
# We get here only if we are not complete: $self->{POLL}{complete} == 0
return __PACKAGE__->can('poll_login')->($self, $pkgsub); # Do not call a sub-classed version
}
sub cmd { # Sends a CLI command to host and returns output
my $pkgsub = "${Package}::cmd";
my $self = shift;
my %args;
if (@_ == 1) { # Method invoked with just the command argument
$args{command} = shift;
}
else {
my @validArgs = ('command', 'prompt', 'timeout', 'errmode', 'return_reference', 'blocking', 'poll_syntax');
%args = parseMethodArgs($pkgsub, \@_, \@validArgs);
}
$args{command} = '' unless defined $args{command};
# Initialize the base POLL structure
$self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
$pkgsub,
__PACKAGE__->can('cmd_poll'),
defined $args{blocking} ? $args{blocking} : $self->{blocking},
defined $args{timeout} ? $args{timeout} : $self->{timeout},
defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef,
1,
undef, # This is set below
defined $args{return_reference} ? $args{return_reference} : $self->{return_reference},
undef, # n/a
);
my $cmd = $self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
# Set method argument keys
lib/Control/CLI.pm view on Meta::CPAN
sub blocking { # Set/read blocking/unblocking mode for reading connection and polling methods
my ($self, $newSetting) = @_;
my $currentSetting = $self->{blocking};
$self->{blocking} = $newSetting if defined $newSetting;
return $currentSetting;
}
sub read_attempts { # Set/read number of read attempts in readwait()
my ($self, $newSetting) = @_;
my $currentSetting = $self->{read_attempts};
$self->{read_attempts} = $newSetting if defined $newSetting;
return $currentSetting;
}
sub readwait_timer { # Set/read poll timer in readwait()
my ($self, $newSetting) = @_;
my $currentSetting = $self->{readwait_timer};
$self->{readwait_timer} = $newSetting if defined $newSetting;
return $currentSetting;
}
sub data_with_error { # Set/read behaviour flag for readwait() when some data read followed by a read error
my ($self, $newSetting) = @_;
my $currentSetting = $self->{data_with_error};
$self->{data_with_error} = $newSetting if defined $newSetting;
return $currentSetting;
}
sub return_reference { # Set/read return_reference mode
my ($self, $newSetting) = @_;
my $currentSetting = $self->{return_reference};
$self->{return_reference} = $newSetting if defined $newSetting;
return $currentSetting;
}
sub output_record_separator { # Set/read the Output Record Separator automaticaly appended by print() and cmd()
my ($self, $newSetting) = @_;
my $currentSetting = $self->{ors};
if (defined $newSetting) {
$self->{ors} = $newSetting;
$self->{TELNETMODE} = $newSetting eq "\r" ? 0 : 1;
}
return $currentSetting;
}
sub binmode { # Set/read bimode
my ($self, $newSetting) = @_;
my $currentSetting = $self->{binmode};
$self->{binmode} = $newSetting if defined $newSetting;
return $currentSetting;
}
sub prompt_credentials { # Set/read prompt_credentials mode
my $pkgsub = "${Package}::prompt_credentials";
my ($self, $newSetting) = @_;
my $currentSetting = $self->{prompt_credentials};
if (defined $newSetting) {
if (ref($newSetting) && !validCodeRef($newSetting)) {
carp "$pkgsub: First item of array ref must be a code ref";
}
$self->{prompt_credentials} = $newSetting;
}
return $currentSetting;
}
sub flush_credentials { # Clear the stored username, password, passphrases, if any
my $self = shift;
$self->{USERNAME} = $self->{PASSWORD} = $self->{PASSPHRASE} = undef;
return 1;
}
sub prompt { # Read/Set object prompt
my ($self, $newSetting) = @_;
my $currentSetting = $self->{prompt};
if (defined $newSetting) {
$self->{prompt} = $newSetting;
$self->{prompt_qr} = qr/$newSetting/;
}
return $currentSetting;
}
sub username_prompt { # Read/Set object username prompt
my ($self, $newSetting) = @_;
my $currentSetting = $self->{username_prompt};
if (defined $newSetting) {
$self->{username_prompt} = $newSetting;
$self->{username_prompt_qr} = qr/$newSetting/;
}
return $currentSetting;
}
sub password_prompt { # Read/Set object password prompt
my ($self, $newSetting) = @_;
my $currentSetting = $self->{password_prompt};
if (defined $newSetting) {
$self->{password_prompt} = $newSetting;
$self->{password_prompt_qr} = qr/$newSetting/;
}
return $currentSetting;
}
sub terminal_type { # Read/Set object terminal type
my ($self, $newSetting) = @_;
my $currentSetting = $self->{terminal_type};
if (defined $newSetting) {
$self->{terminal_type} = length $newSetting ? $newSetting : undef;
}
return $currentSetting;
}
sub window_size { # Read/Set object terminal window size
my $pkgsub = "${Package}::window_size";
my ($self, $width, $height) = @_;
my @currentSetting = @{$self->{window_size}};
if ((defined $width && !$width) || (defined $height && !$height)) { # Empty value undefines it
$self->{window_size} = [];
}
elsif (defined $width && defined $height) {
if ($width =~ /^\d+$/ && $height =~ /^\d+$/) {
$self->{window_size} = [$width, $height];
}
lib/Control/CLI.pm view on Meta::CPAN
my $outref = $self->read(
blocking => 0,
return_reference => 1,
errmode => 'return',
);
unless (defined $outref) { # Here we catch errors since errmode = 'return'
if ($dataWithError && length $self->{POLL}{read_buffer}) { # Data_with_error processing
$self->{POLL}{already_polled} = 1; # Set it for next cycle
$self->{POLL}{endtime} = undef; # Clear timeout endtime
$self->{POLL}{waittime} = undef; # Clear waittime
return 1; # We are done, available data in $self->{POLL}{read_buffer} can be read by calling loop, in spite of error
}
return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
return; # Otherwise
}
if (length $$outref) { # We read something, reset wait timer
$self->{POLL}{read_buffer} .= $$outref;
$self->{POLL}{waittime} = time + $readwaitTimer/1000 * $readAttempts;
return 0;
}
# We read nothing from device
if (defined $self->{POLL}{waittime}) { # Some data already read; now just doing waittimer for more
if (time > $self->{POLL}{waittime}) { # Wait timer has expired
$self->{POLL}{already_polled} = 1; # Set it for next cycle
$self->{POLL}{endtime} = undef; # Clear timeout endtime
$self->{POLL}{waittime} = undef; # Clear waittime
return 1; # This is effectively when we are done and $self->{POLL}{read_buffer} can be read by calling loop
}
else { # Wait timer has not expired yet
return 0;
}
}
else { # No data read yet, regular timeout checking
if (time > $self->{POLL}{endtime}) { # Timeout has expired
$self->{POLL}{endtime} = undef; # Clear timeout endtime
$self->errmsg("$pollsub: Poll Read Timeout");
return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
return; # Otherwise
}
else { # Still within timeout
return 0;
}
}
}
}
sub poll_connect { # Internal method to connect to host (used for both blocking & non-blocking modes)
my $self = shift;
my $pkgsub = shift;
my $pollsub = "${Package}::connect";
unless ($self->{POLLING}) { # Sanity check
my (undef, $fileName, $lineNumber) = caller;
croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
}
unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
my @validArgs = ('host', 'port', 'username', 'password', 'publickey', 'privatekey', 'passphrase',
'prompt_credentials', 'baudrate', 'parity', 'databits', 'stopbits', 'handshake',
'errmode', 'connection_timeout', 'terminal_type', 'window_size', 'callback',
'forcebaud', 'atomic_connect');
my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
if (@_ && !%args) { # Legacy syntax
($args{host}, $args{port}, $args{username}, $args{password}, $args{publickey}, $args{privatekey}, $args{passphrase}, $args{baudrate},
$args{parity}, $args{databits}, $args{stopbits}, $args{handshake}, $args{prompt_credentials}, $args{timeout}, $args{errmode}) = @_;
}
# In which case we need to setup the poll structure here (the main poll structure remains unchanged)
$self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
# Set method argument keys
host => $args{host},
port => $args{port},
username => defined $args{username} ? $args{username} : $self->{USERNAME},
password => defined $args{password} ? $args{password} : $self->{PASSWORD},
publickey => $args{publickey},
privatekey => $args{privatekey},
passphrase => defined $args{passphrase} ? $args{passphrase} : $self->{PASSPHRASE},
baudrate => $args{baudrate},
parity => $args{parity},
databits => $args{databits},
stopbits => $args{stopbits},
handshake => $args{handshake},
prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
terminal_type => $args{terminal_type},
window_size => $args{window_size},
callback => $args{callback},
forcebaud => $args{forcebaud},
atomic_connect => $args{atomic_connect},
# Declare method storage keys which will be used
stage => 0,
authPublicKey => 0,
authPassword => 0,
# Declare keys to be set if method called from another polled method
errmode => $args{errmode},
};
# Cache poll structure keys which this method will use
$self->poll_struct_cache($pollsub, $args{connection_timeout});
}
my $connect = $self->{POLL}{$pollsub};
local $self->{errmode} = $connect->{errmode} if defined $connect->{errmode};
my $ok;
if ($connect->{stage} < 1) { # Initial setup - do only once
$self->{BUFFER} = '';
$self->{LOGINSTAGE} = '';
# For these arguments, go change the object setting, as it will need accessing via Net:Telnet callbacks
$self->terminal_type($connect->{terminal_type}) if defined $connect->{terminal_type};
$self->window_size(@{$connect->{window_size}}) if defined $connect->{window_size};
}
if ($self->{TYPE} eq 'TELNET') {
if ($connect->{stage} < 1) { # Initial setup - do only once
$connect->{stage}++; # Ensure we don't come back here in non-blocking mode
return $self->poll_return($self->error("$pkgsub: No Telnet host provided")) unless defined $connect->{host};
$self->{PARENT}->errmode('return');
$self->{PARENT}->timeout($self->{timeout});
$connect->{port} = $Default{tcp_port}{TELNET} unless defined $connect->{port};
$self->{HOST} = $connect->{host};
$self->{TCPPORT} = $connect->{port};
if (!$self->{POLL}{blocking} && $connect->{atomic_connect}) {
$self->{POLL}{blocking} = 1; # Switch into blocking mode during connect phase
return $self->poll_return(0); # Next poll will be the atomic connect
}
else {
$connect->{atomic_connect} = undef; # In blocking mode undefine it
}
}
# TCP Socket setup and handoff to Net::Telnet object
# Open Socket ourselves
($ok, $self->{SOCKET}) = $self->poll_open_socket($pkgsub, $connect->{host}, $connect->{port});
return $self->poll_return($ok) unless $ok; # Covers 2 cases:
# - errmode is 'return' and $ok = undef ; so we come out due to error
# - $ok = 0 ; non-blocking mode; connection not ready yet
# Give Socket to Net::Telnet
$self->{PARENT}->fhopen($self->{SOCKET}) or return $self->poll_return($self->error("$pkgsub: unable to open Telnet over socket"));
if ($^O eq 'MSWin32') {
# We need this hack to workaround a bug introduced in Net::Telnet 3.04
# see Net::Telnet bug report 94913: https://rt.cpan.org/Ticket/Display.html?id=94913
my $telobj = *{$self->{PARENT}}->{net_telnet};
if (exists $telobj->{select_supported} && !$telobj->{select_supported}) {
lib/Control/CLI.pm view on Meta::CPAN
# If we get here, it is because it did not get set correctly by our fhopen above, which means
# we are using Net::Telnet 3.04 or a later version of it which still has not fixed the issue
$telobj->{select_supported} = 1; # Workaround, we set it
}
}
# Handle Telnet options
$self->_handle_telnet_options;
$self->{POLL}{blocking} = 0 if $connect->{atomic_connect}; # Restore non-blocking mode once connect complete
}
elsif ($self->{TYPE} eq 'SSH') {
if ($connect->{stage} < 1) { # Initial setup - do only once
$connect->{stage}++; # Ensure we don't come back here in non-blocking mode
return $self->poll_return($self->error("$pkgsub: No SSH host provided")) unless defined $connect->{host};
$connect->{port} = $Default{tcp_port}{SSH} unless defined $connect->{port};
$self->{HOST} = $connect->{host};
$self->{TCPPORT} = $connect->{port};
if (!$self->{POLL}{blocking} && $connect->{atomic_connect}) {
$self->{POLL}{blocking} = 1; # Switch into blocking mode during connect phase
return $self->poll_return(0); # Next poll will be the atomic connect
}
else {
$connect->{atomic_connect} = undef; # In blocking mode undefine it
}
}
if ($connect->{stage} < 2) { # TCP Socket setup and handoff to Net::SSH2 object
# Open Socket ourselves
($ok, $self->{SOCKET}) = $self->poll_open_socket($pkgsub, $connect->{host}, $connect->{port});
return $self->poll_return($ok) unless $ok; # Covers 2 cases:
# - errmode is 'return' and $ok = undef ; so we come out due to error
# - $ok = 0 ; non-blocking mode; connection not ready yet
$connect->{stage}++; # Ensure we don't come back here in non-blocking mode
# Set the SO_LINGER option as Net::SSH2 would do
$self->{SOCKET}->sockopt(&Socket::SO_LINGER, pack('SS', 0, 0));
# Give Socket to Net::SSH2
eval { # Older versions of Net::SSH2 need to be trapped so that we get desired error mode
$ok = $self->{PARENT}->connect($self->{SOCKET});
};
return $self->poll_return($self->error("$pkgsub: " . $@)) if $@;
return $self->poll_return($self->error("$pkgsub: SSH unable to connect")) unless $ok;
return $self->poll_return(0) unless $self->{POLL}{blocking};
}
if ($connect->{stage} < 3) { # Check for callback (if user wants to verify device hostkey against known hosts)
$connect->{stage}++; # Ensure we don't come back here in non-blocking mode
if ($connect->{callback}) {
if ( validCodeRef($connect->{callback}) ) {
($ok, my $errmsg) = callCodeRef($connect->{callback}, $self);
return $self->poll_return($self->error("$pkgsub: " . (defined $errmsg ? $errmsg : "SSH callback refused connection"))) unless $ok;
return $self->poll_return(0) unless $self->{POLL}{blocking};
}
else {
carp "$pkgsub: Callback is not a valid code ref; ignoring";
}
}
}
if ($connect->{stage} < 4) { # Find out available SSH authentication options
$connect->{stage}++; # Ensure we don't come back here in non-blocking mode
unless ( defined $connect->{username} ) {
return $self->poll_return($self->error("$pkgsub: Username required for SSH authentication")) unless $connect->{prompt_credentials};
$connect->{username} = promptCredential($connect->{prompt_credentials}, 'Clear', 'Username');
# Reset timeout endtime
$self->{POLL}{endtime} = time + $self->{POLL}{timeout};
}
if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
return $self->poll_return($self->error("$pkgsub: connection timeout expired (before auth_list)"));
}
my @authList = $self->{PARENT}->auth_list($connect->{username});
foreach my $auth (@authList) {
$connect->{authPublicKey} = 1 if $auth eq 'publickey';
$connect->{authPassword} |= 1 if $auth eq 'password'; # bit1 = password
$connect->{authPassword} |= 2 if $auth eq 'keyboard-interactive'; # bit2 = KI
}
$self->debugMsg(1,"SSH authentications accepted: ", \join(', ', @authList), "\n");
$self->debugMsg(1,"authPublicKey flag = $connect->{authPublicKey} ; authPassword flag = $connect->{authPassword}\n");
$self->{USERNAME} = $connect->{username}; # If we got here, we have a connection so store the username used
return $self->poll_return(0) unless $self->{POLL}{blocking};
}
if ($connect->{stage} < 5) { # Try publickey authentication
$connect->{stage}++; # Ensure we don't come back here in non-blocking mode
if ($connect->{authPublicKey}) { # Try Public Key authentication...
if (defined $connect->{publickey} && defined $connect->{privatekey}) { # ... if we have keys
return $self->poll_return($self->error("$pkgsub: Public Key '$connect->{publickey}' not found"))
unless -e $connect->{publickey};
return $self->poll_return($self->error("$pkgsub: Private Key '$connect->{privatekey}' not found"))
unless -e $connect->{privatekey};
unless ($connect->{passphrase}) { # Passphrase not provided
my $passphReq = passphraseRequired($connect->{privatekey});
return $self->poll_return($self->error("$pkgsub: Unable to read Private key")) unless defined $passphReq;
if ($passphReq) { # Passphrase is required
return $self->poll_return($self->error("$pkgsub: Passphrase required for Private Key")) unless $connect->{prompt_credentials};
# We are allowed to prompt for it
$connect->{passphrase} = promptCredential($connect->{prompt_credentials}, 'Hide', 'Passphrase for Private Key');
# Reset timeout endtime
$self->{POLL}{endtime} = time + $self->{POLL}{timeout};
}
}
if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
return $self->poll_return($self->error("$pkgsub: connection timeout expired (before auth_publickey"));
}
$ok = $self->{PARENT}->auth_publickey(
$connect->{username},
$connect->{publickey},
$connect->{privatekey},
$connect->{passphrase},
);
if ($ok) { # Store the passphrase used if publickey authentication succeded
$self->{PASSPHRASE} = $connect->{passphrase} if $connect->{passphrase};
$self->{SSHAUTH} = 'publickey';
}
elsif ( !($connect->{authPassword} && (defined $connect->{password} || $connect->{prompt_credentials})) ) {
# Unless we can try password authentication next, throw an error now
return $self->poll_return($self->error("$pkgsub: SSH unable to publickey authenticate"));
}
return $self->poll_return(0) unless $self->{POLL}{blocking};
}
elsif (!$connect->{authPassword}) { # If we don't have the keys and publickey authentication was the only one possible
return $self->poll_return($self->error("$pkgsub: Only publickey SSH authenticatication possible and no keys provided"));
}
}
}
if ($connect->{stage} < 6) { # Try password authentication
$connect->{stage}++; # Ensure we don't come back here in non-blocking mode
if ($connect->{authPassword} && !$self->{PARENT}->auth_ok) { # Try password authentication if not already publickey authenticated
unless ( defined $connect->{password} ) {
return $self->poll_return($self->error("$pkgsub: Password required for password authentication")) unless $connect->{prompt_credentials};
$connect->{password} = promptCredential($connect->{prompt_credentials}, 'Hide', 'Password');
# Reset timeout endtime
$self->{POLL}{endtime} = time + $self->{POLL}{timeout};
}
if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
return $self->poll_return($self->error("$pkgsub: connection timeout expired (before auth_password)"));
}
if ($connect->{authPassword} & 1) { # Use password authentication
$self->{PARENT}->auth_password($connect->{username}, $connect->{password})
or return $self->poll_return($self->error("$pkgsub: SSH unable to password authenticate"));
$self->{SSHAUTH} = 'password';
}
elsif ($connect->{authPassword} & 2) { # Use keyboard-interactive authentication
$self->{PARENT}->auth_keyboard($connect->{username}, $connect->{password})
or return $self->poll_return($self->error("$pkgsub: SSH unable to password authenticate (using keyboard-interactive)"));
$self->{SSHAUTH} = 'keyboard-interactive';
}
else {
return $self->poll_return($self->error("$pkgsub: Error in processing password authentication options"));
}
# Store password used
$self->{PASSWORD} = $connect->{password};
return $self->poll_return(0) unless $self->{POLL}{blocking};
}
}
# Make sure we are authenticated, in case neither publicKey nor password auth was accepted
return $self->poll_return($self->error("$pkgsub: SSH unable to authenticate")) unless $self->{PARENT}->auth_ok;
# Setup SSH channel
if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
return $self->poll_return($self->error("$pkgsub: connection timeout expired (before SSH channel setup)"));
}
$self->{SSHCHANNEL} = $self->{PARENT}->channel(); # Open an SSH channel
$self->{PARENT}->blocking(0); # Make the session non blocking for reads
$self->{SSHCHANNEL}->ext_data('merge'); # Merge stderr onto regular channel
$self->{SSHCHANNEL}->pty($self->{terminal_type}, undef, @{$self->{window_size}}); # Start interactive terminal; also set term type & window size
$self->{SSHCHANNEL}->shell(); # Start shell on channel
$self->{POLL}{blocking} = 0 if $connect->{atomic_connect}; # Restore non-blocking mode once connect complete
}
elsif ($self->{TYPE} eq 'SERIAL') {
$connect->{handshake} = $Default{handshake} unless defined $connect->{handshake};
$connect->{baudrate} = $Default{baudrate} unless defined $connect->{baudrate};
$connect->{parity} = $Default{parity} unless defined $connect->{parity};
$connect->{databits} = $Default{databits} unless defined $connect->{databits};
$connect->{stopbits} = $Default{stopbits} unless defined $connect->{stopbits};
$self->{PARENT}->handshake($connect->{handshake}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Handshake"));
$self->{PARENT}->baudrate($connect->{baudrate}) or do {
# If error, could be Win32::SerialPort bug https://rt.cpan.org/Ticket/Display.html?id=120068
if ($^O eq 'MSWin32' && $connect->{forcebaud}) { # With forcebaud we can force-set the desired baudrate
$self->{PARENT}->{"_N_BAUD"} = $connect->{baudrate};
}
else { # Else we come out with error
return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Baudrate"));
}
};
$self->{PARENT}->parity($connect->{parity}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Parity"));
unless ($connect->{parity} eq 'none') { # According to Win32::SerialPort, parity_enable needs to be set when parity is not 'none'...
$self->{PARENT}->parity_enable(1) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Parity_Enable"));
}
$self->{PARENT}->databits($connect->{databits}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort DataBits"));
$self->{PARENT}->stopbits($connect->{stopbits}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort StopBits"));
$self->{PARENT}->write_settings or return $self->poll_return($self->error("$pkgsub: Can't change Device_Control_Block: $^E"));
#Set Read & Write buffers
$self->{PARENT}->buffers($ComPortReadBuffer, 0) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Buffers"));
if ($^O eq 'MSWin32') {
$self->{PARENT}->read_interval($ComReadInterval) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Read_Interval"));
}
# Don't wait for each character
defined $self->{PARENT}->read_char_time(0) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Read_Char_Time"));
$self->{HANDSHAKE} = $connect->{handshake};
$self->{BAUDRATE} = $connect->{baudrate};
$self->{PARITY} = $connect->{parity};
$self->{DATABITS} = $connect->{databits};
$self->{STOPBITS} = $connect->{stopbits};
$self->{SERIALEOF} = 0;
}
else {
return $self->poll_return($self->error("$pkgsub: Invalid connection mode"));
}
return $self->poll_return(1);
}
sub poll_login { # Method to handle login for poll methods (used for both blocking & non-blocking modes)
my $self = shift;
my $pkgsub = shift;
my $pollsub = "${Package}::login";
unless ($self->{POLLING}) { # Sanity check
my (undef, $fileName, $lineNumber) = caller;
croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
}
unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
my @validArgs = ('username', 'password', 'prompt_credentials', 'prompt', 'username_prompt', 'password_prompt', 'timeout', 'errmode');
my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
if (@_ && !%args) { # Legacy syntax
($args{username}, $args{password}, $args{prompt}, $args{username_prompt}, $args{password_prompt},
$args{prompt_credentials}, $args{timeout}, $args{errmode}) = @_;
}
# In which case we need to setup the poll structure here (the main poll structure remains unchanged)
$self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
# Set method argument keys
username => defined $args{username} ? $args{username} : $self->{USERNAME},
password => defined $args{password} ? $args{password} : $self->{PASSWORD},
prompt => defined $args{prompt} ? $args{prompt} : $self->{prompt_qr},
username_prompt => defined $args{username_prompt} ? $args{username_prompt} : $self->{username_prompt_qr},
password_prompt => defined $args{password_prompt} ? $args{password_prompt} : $self->{password_prompt_qr},
prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
# Declare method storage keys which will be used
stage => 0,
login_attempted => undef,
# Declare keys to be set if method called from another polled method
errmode => $args{errmode},
};
# Cache poll structure keys which this method will use
$self->poll_struct_cache($pollsub, $args{timeout});
}
my $login = $self->{POLL}{$pollsub};
local $self->{errmode} = $login->{errmode} if defined $login->{errmode};
return $self->poll_return($self->error("$pkgsub: No connection to login to")) if $self->eof;
if ($login->{stage} < 1) { # Initial loginstage checking - do only once
$login->{stage}++; # Ensure we don't come back here in non-blocking mode
if ($self->{LOGINSTAGE} eq 'username') { # Resume login from where it was left
return $self->error("$pkgsub: Username required") unless $login->{username};
$self->print(line => $login->{username}, errmode => 'return')
or return $self->poll_return($self->error("$pkgsub: Unable to send username // ".$self->errmsg));
$self->{LOGINSTAGE} = '';
$login->{login_attempted} =1;
}
elsif ($self->{LOGINSTAGE} eq 'password') { # Resume login from where it was left
return $self->error("$pkgsub: Password required") unless $login->{password};
$self->print(line => $login->{password}, errmode => 'return')
or return $self->poll_return($self->error("$pkgsub: Unable to send password // ".$self->errmsg));
$self->{LOGINSTAGE} = '';
}
}
# Enter login loop..
do {{
my $ok = $self->poll_read($pkgsub, 'Failed reading login prompt');
return $self->poll_return($ok) unless $ok;
$self->{POLL}{local_buffer} .= $self->{POLL}{read_buffer}; # Login buffer can get flushed along the way
$self->{POLL}{output_buffer} .= $self->{POLL}{read_buffer}; # This buffer preserves all the output, in case it is requested
if ($self->{POLL}{local_buffer} =~ /$login->{username_prompt}/) { # Handle username prompt
if ($login->{login_attempted}) {
return $self->poll_return($self->error("$pkgsub: Incorrect Username or Password"));
}
unless ($login->{username}) {
if ($self->{TYPE} eq 'SSH') { # If an SSH connection, we already have the username
$login->{username} = $self->{USERNAME};
}
else {
unless ($login->{prompt_credentials}) {
$self->{LOGINSTAGE} = 'username';
return $self->poll_return($self->error("$pkgsub: Username required"));
}
$login->{username} = promptCredential($login->{prompt_credentials}, 'Clear', 'Username');
}
}
$self->print(line => $login->{username}, errmode => 'return')
or return $self->poll_return($self->error("$pkgsub: Unable to send username // ".$self->errmsg));
$self->{LOGINSTAGE} = '';
$login->{login_attempted} =1;
$self->{POLL}{local_buffer} = '';
next;
}
if ($self->{POLL}{local_buffer} =~ /$login->{password_prompt}/) { # Handle password prompt
unless (defined $login->{password}) {
unless (defined $login->{prompt_credentials}) {
$self->{LOGINSTAGE} = 'password';
return $self->poll_return($self->error("$pkgsub: Password required"));
}
$login->{password} = promptCredential($login->{prompt_credentials}, 'Hide', 'Password');
}
$self->print(line => $login->{password}, errmode => 'return')
or return $self->poll_return($self->error("$pkgsub: Unable to send password // ".$self->errmsg));
$self->{LOGINSTAGE} = '';
$self->{POLL}{local_buffer} = '';
next;
}
}} until ($self->{POLL}{local_buffer} =~ /($login->{prompt})/);
$self->{LASTPROMPT} = $1;
$self->{WRITEFLAG} = 0;
($self->{USERNAME}, $self->{PASSWORD}) = ($login->{username}, $login->{password}) if $login->{login_attempted};
return $self->poll_return(1);
}
sub poll_waitfor { # Method to handle waitfor for poll methods (used for both blocking & non-blocking modes)
my $self = shift;
my $pkgsub = shift;
my $pollsub = "${Package}::waitfor";
unless ($self->{POLLING}) { # Sanity check
my (undef, $fileName, $lineNumber) = caller;
croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
}
unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
my @validArgs = ('match_list', 'timeout', 'errmode');
my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
if (@_ && !%args) { # Legacy syntax
($args{match_list}, $args{timeout}, $args{errmode}) = @_;
}
$args{match_list} = [$args{match_list}] unless ref($args{match_list}) eq "ARRAY"; # We want it as an array reference
my @matchArray = grep {defined} @{$args{match_list}}; # Weed out undefined values, if any
# In which case we need to setup the poll structure here (the main poll structure remains unchanged)
$self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
# Set method argument keys
matchpat => \@matchArray,
# Declare method storage keys which will be used
stage => 0,
matchpat_qr => undef,
# Declare keys to be set if method called from another polled method
errmode => $args{errmode},
};
# Cache poll structure keys which this method will use
$self->poll_struct_cache($pollsub, $args{timeout});
}
my $waitfor = $self->{POLL}{$pollsub};
local $self->{errmode} = $waitfor->{errmode} if defined $waitfor->{errmode};
return $self->poll_return($self->error("$pkgsub: Received eof from connection")) if $self->eof;
if ($waitfor->{stage} < 1) { # 1st stage
$waitfor->{stage}++; # Ensure we don't come back here in non-blocking mode
return $self->poll_return($self->error("$pkgsub: Match pattern provided is undefined")) unless @{$waitfor->{matchpat}};
eval { # Eval the patterns as they may be invalid
@{$waitfor->{matchpat_qr}} = map {qr/^((?:.*\n?)*?)($_)/} @{$waitfor->{matchpat}}; # Convert match patterns into regex
# This syntax did not work: qr/^([\n.]*?)($_)/
};
if ($@) { # If we trap an error..
$@ =~ s/ at \S+ line .+$//s; # ..remove this module's line number
return $self->poll_return($self->error("$pkgsub: $@"));
lib/Control/CLI.pm view on Meta::CPAN
Net::Telnet for Telnet access
=item *
Net::SSH2 for SSH access
=item *
IO::Socket::IP for IPv6 support
=item *
Win32::SerialPort or Device::SerialPort for Serial port access respectively on Windows and Unix systems
=back
Since all of the above are Perl standalone modules (which do not rely on external binaries) scripts using Control::CLI can easily be ported to any OS platform (where either Perl is installed or by simply packaging the Perl script into an executable w...
All the above modules are optional, however if one of the modules is missing then no access of that type will be available.
For instance if Win32::SerialPort is not installed (on a Windows system) but both Net::Telnet and Net::SSH2 are, then Control::CLI will be able to operate over both Telnet and SSH, but not Serial port. There has to be, however, at least one of the Te...
Net::Telnet and Net::SSH2 both natively use IO::Socket::INET which only provides IPv4 support; if however IO::Socket::IP is installed, this class will use it as a drop in replacement to IO::Socket::INET and allow both Telnet and SSH connections to op...
For both Telnet and SSH this module allows setting of terminal type (e.g. vt100 or other) and windows size, which are not easy to achieve with Net::Telnet as they rely on Telnet option negotiation. Being able to set the terminal type is important wit...
Note that Net::SSH2 only supports SSHv2 and this class will always and only use Net::SSH2 to establish a channel over which an interactive shell is established with the remote host. Authentication methods supported are 'publickey', 'password' and 'ke...
As of version 2.00, this module offers non-blocking capability on all of its methods (in the case of connect method, IO::Socket::IP is required). Scripts using this class can now drive multiple hosts simultaneusly without resorting to Perl threads. S...
In the syntax layout below, square brackets B<[]> represent optional parameters.
All Control::CLI method arguments are case insensitive.
=head1 OBJECT CONSTRUCTOR
Used to create an object instance of Control::CLI
=over 4
=item B<new()> - create a new Control::CLI object
$obj = new Control::CLI ('TELNET'|'SSH'|'<COM_port_name>');
$obj = new Control::CLI (
Use => 'TELNET'|'SSH'|'<COM_port_name>',
[Timeout => $secs,]
[Connection_timeout => $secs,]
[Binmode => $binmode,]
[Errmode => $errmode,]
[Errmsg_format => $msgFormat,]
[Return_reference => $flag,]
[Prompt => $prompt,]
[Username_prompt => $usernamePrompt,]
[Password_prompt => $passwordPrompt,]
[Input_log => $fhOrFilename,]
[Output_log => $fhOrFilename,]
[Dump_log => $fhOrFilename,]
[Blocking => $flag,]
[Prompt_credentials => $flag,]
[Read_attempts => $numberOfReadAttemps,]
[Readwait_timer => $millisecs,]
[Data_with_error => $flag,]
[Read_block_size => $bytes,]
[Output_record_separator => $ors,]
[Terminal_type => $string,]
[Window_size => [$width, $height],]
[Report_query_status => $flag,]
[Debug => $debugFlag,]
);
This is the constructor for Control::CLI objects. A new object is returned on success. On failure the error mode action defined by "errmode" argument is performed. If the "errmode" argument is not specified the default is to croak. See errmode() for ...
The first parameter, or "use" argument, is required and should take value either "TELNET" or "SSH" (case insensitive) or the name of the Serial port such as "COM1" or "/dev/ttyS0". In the second form, the other arguments are optional and are just sho...
=back
=head1 OBJECT METHODS
Methods which can be run on a previously created Control::CLI object instance
=head2 Main I/O Object Methods
=over 4
=item B<connect() & connect_poll()> - connect to host
$ok = $obj->connect($host [$port]);
$ok = $obj->connect($host[:$port]); # Deprecated
$ok = $obj->connect(
[Host => $host,]
[Port => $port,]
[Username => $username,]
[Password => $password,]
[PublicKey => $publicKey,]
[PrivateKey => $privateKey,]
[Passphrase => $passphrase,]
[Prompt_credentials => $flag,]
[BaudRate => $baudRate,]
[ForceBaud => $flag,]
[Parity => $parity,]
[DataBits => $dataBits,]
[StopBits => $stopBits,]
[Handshake => $handshake,]
[Connection_timeout => $secs,]
[Blocking => $flag,]
[Errmode => $errmode,]
[Terminal_type => $string,]
[Window_size => [$width, $height],]
[Callback => \&codeRef,]
[Atomic_connect => $flag,]
);
$ok = $obj->connect_poll(); # Only applicable in non-blocking mode
This method connects to the host device. The connection will use either Telnet, SSH or Serial port, depending on how the object was created with the new() constructor.
On success a true (1) value is returned.
In non-blocking mode (blocking disabled) the connect() method will immediately return with a false, but defined, value of 0. You will then need to call the connect_poll() method at regular intervals until it returns a true (1) value indicating that t...
On connection timeout or other connection failures the error mode action is performed. See errmode().
The deprecated shorthand syntax is still accepted but it will not work if $host is an IPv6 address.
The optional "errmode", "connection_timeout" and "blocking" arguments are provided to override the global setting of the corresponding object parameter.
When a "connection_timeout" is defined, this will be used to enforce a connection timeout for Telnet and SSH TCP socket connections.
The "terminal_type" and "window_size" arguments are not overrides, they will change the object parameter as these settings are only applied during a connection.
Which arguments are used depends on the whether the object was created for Telnet, SSH or Serial port. The "host" argument is required by both Telnet and SSH. The other arguments are optional.
=over 4
=item *
For Telnet, these forms are allowed with the following arguments:
$ok = $obj->connect($host [$port]);
$ok = $obj->connect($host[:$port]); # Deprecated
$ok = $obj->connect(
Host => $host,
[Port => $port,]
[Connection_timeout => $secs,]
[Blocking => $flag,]
[Errmode => $errmode,]
[Terminal_type => $string,]
[Window_size => [$width, $height],]
[Atomic_connect => $flag,]
);
If not specified, the default port number for Telnet is 23.
Arguments "terminal_type" and "window_size" are negotiated via Telnet options; to debug telnet option negotiation use Net::Telnet's own option_log() method.
=item *
For SSH, these forms are allowed with the following arguments:
$ok = $obj->connect($host [$port]);
$ok = $obj->connect($host[:$port]); # Deprecated
$ok = $obj->connect(
Host => $host,
[Port => $port,]
[Username => $username,]
[Password => $password,]
[PublicKey => $publicKey,]
[PrivateKey => $privateKey,]
[Passphrase => $passphrase,]
[Prompt_credentials => $flag,]
[Connection_timeout => $secs,]
[Blocking => $flag,]
[Errmode => $errmode,]
[Terminal_type => $string,]
[Window_size => [$width, $height],]
[Callback => \&codeRef,]
[Atomic_connect => $flag,]
);
If not specified, the default port number for SSH is 22.
A username must always be provided for all SSH connections. If not provided and prompt_credentials is true then this method will prompt for it.
Once the SSH connection is established, this method will attempt one of two possible authentication types, based on the accepted authentications of the remote host:
=over 4
=item *
B<Publickey authentication> : If the remote host accepts it and the method was supplied with public/private keys. The public/private keys need to be in OpenSSH format. If the private key is protected by a passphrase then this must also be provided or...
=item *
B<Password authentication> : If the remote host accepts either 'password' or 'keyboard-interactive' authentication methods. A password must be provided or, if prompt_credentials is true, this method will prompt for the password. If password authentic...
=back
There are some devices, with a crude SSH implementation, which will accept an SSH connection without any SSH authentication, and then perform an interactive login, like Telnet does. In this case, the connect() method, will not perform any SSH authent...
The optional "prompt_credentials" argument is provided to override the global setting of the parameter by the same name which is by default false. See prompt_credentials().
If a code reference is provided via the 'callback' argument, that code will be called immediately after setting up the SSH connection and before attempting any authentication. You can use this callback to check the key of the remote host against a li...
An example on how to verify the host key against your known hosts is provided in the documentation of Net::SSH2::KnownHosts.
Note that Net::SSH2 methods remote_hostkey and known_hosts methods only exists as of version 0.54. This class does not require a minimum version of Net::SSH2 but your code will need to require a version of 0.54, or verify the availability of those me...
Instead of a code reference, an array reference can also be used provided that the first element in the array is a code reference. In this case the remainder of the array elements will be inserted as arguments to the code being called to which this c...
$ok = &$codeRef($netSsh2Obj);
($ok, [$error_message]) = &$codeRef($netSsh2Obj);
$ok = &{$codeRef->[0]}($codeRef->[1], $codeRef->[2], $codeRef->[3], ..., $controlCliObj);
($ok, [$error_message]) = &{$codeRef->[0]}($codeRef->[1], $codeRef->[2], $codeRef->[3], ..., $controlCliObj);
Your callback should return a true value (for $ok) if the SSH connection is to proceed.
Whereas a false/undefined value indicates that the connection should not go ahead; in this case an optional error message can be provided which will be used to perform the error mode action of this class. Otherwise a standard error message will be us...
The "atomic_connect" argument is only useful if using the connect() method in non-blocking mode across many objects of this class and using the Control::CLI poll() method to poll progress across all of them. Since SSH authentication is not handled in...
=item *
For Serial port, these arguments are used:
$ok = $obj->connect(
[BaudRate => $baudRate,]
[ForceBaud => $flag,]
[Parity => $parity,]
[DataBits => $dataBits,]
[StopBits => $stopBits,]
[Handshake => $handshake,]
[Blocking => $flag,] # Ignored
[Errmode => $errmode,]
);
If arguments are not specified, the defaults are: Baud Rate = 9600, Data Bits = 8, Parity = none, Stop Bits = 1, Handshake = none.
Allowed values for these arguments are the same allowed by underlying Win32::SerialPort / Device::SerialPort:
=over 4
=item *
B<Baud Rate> : Any legal value
=item *
B<Parity> : One of the following: "none", "odd", "even", "mark", "space"
=item *
B<Data Bits> : An integer from 5 to 8
=item *
B<Stop Bits> : Legal values are 1, 1.5, and 2. But 1.5 only works with 5 databits, 2 does not work with 5 databits, and other combinations may not work on all hardware if parity is also used
=item *
B<Handshake> : One of the following: "none", "rts", "xoff", "dtr"
=back
lib/Control/CLI.pm view on Meta::CPAN
In non-blocking mode (blocking disabled) the waitfor() method will most likely immediately return with a false, but defined, value of 0. You will then need to call the waitfor_poll() method at regular intervals until it returns a true (1) value indic...
$ok = $obj->waitfor(Poll_syntax => 1, Match => "seeked regex patterns", Blocking => 0);
until ($ok) { # This loop will be executed while $ok = 0
<do other stuff here..>
$ok = $obj->waitfor_poll;
}
print "Output data up to but excluding match string:", ($obj->waitfor_poll)[1];
print "Matched string:", ($obj->waitfor_poll)[2];
# In this order, otherwise output [1] would get flushed while reading just [2]
=item B<put()> - write data to object
$ok = $obj->put($string);
$ok = $obj->put(
String => $string,
[Binmode => $binmode,]
[Errmode => $errmode,]
);
This method writes $string to the object and returns a true (1) value if all data was successfully written.
On failure the error mode action is performed. See errmode().
This method is like print($string) except that no trailing character (usually a newline "\n") is appended.
=item B<print()> - write data to object with trailing output_record_separator
$ok = $obj->print($line);
$ok = $obj->print(
[Line => $line,]
[Binmode => $binmode,]
[Errmode => $errmode,]
);
This method writes $line to the object followed by the output record separator which is usually a newline "\n" - see output_record_separator() - and returns a true (1) value if all data was successfully written. If the method is called with no $line...
On failure the error mode action is performed. See errmode().
To avoid printing a trailing "\n" use put() instead.
=item B<printlist()> - write multiple lines to object each with trailing output_record_separator
$ok = $obj->printlist(@list);
This method writes every element of @list to the object followed by the output record separator which is usually a newline "\n" - see output_record_separator() - and returns a true (1) value if all data was successfully written.
On failure the error mode action is performed. See errmode().
Note that most devices have a limited input buffer and if you try and send too many commands in this manner you risk losing some of them at the far end. It is safer to send commands one at a time using the cmd() method which will acknowledge each com...
=item B<login() & login_poll()> - handle login for Telnet / Serial port
$ok = $obj->login(
[Username => $username,]
[Password => $password,]
[Prompt_credentials => $flag,]
[Prompt => $prompt,]
[Username_prompt => $usernamePrompt,]
[Password_prompt => $passwordPrompt,]
[Blocking => $flag,]
[Timeout => $secs,]
[Errmode => $errmode,]
);
($ok, $output || $outputRef) = $obj->login(
[Username => $username,]
[Password => $password,]
[Prompt_credentials => $flag,]
[Prompt => $prompt,]
[Username_prompt => $usernamePrompt,]
[Password_prompt => $passwordPrompt,]
[Blocking => $flag,]
[Timeout => $secs,]
[Return_reference => $flag,]
[Errmode => $errmode,]
);
Polling method (only applicable in non-blocking mode):
$ok = $obj->login_poll();
($ok, $output || $outputRef) = $obj->login_poll();
This method handles login authentication for Telnet and Serial port access on a generic host.
If a login/username prompt is seen, the supplied username is sent; if a password prompt is seen, the supplied password is sent; and once a valid CLI prompt is seen this method completes and returns a true (1) value.
This method is usually not required for SSH, where authentication is part of the connection process, however there are some devices where the SSH connection is allowed without any SSH authentication and you might then need to handle an interactive au...
In the first form only a success/failure value is returned in scalar context, while in the second form, in list context, both the success/failure value is returned as well as any output received from the host device during the login sequence; the lat...
For this method to succeed the username & password prompts from the remote host must match the default prompts defined for the object or the overrides specified via the optional "username_prompt" & "password_prompt" arguments. By default these regula...
'(?i:user(?: ?name)?|login)[: ]+$'
'(?i)(?<!new )password[: ]+$'
Following a successful authentication, if a valid CLI prompt is received, the method will return a true (1) value. The expected CLI prompt is either the globally set prompt - see prompt() - or the local override specified with the optional "prompt" a...
'.*[\?\$%#>](?:\e\[00?m)?\s?$'
On timeout or failure or if the remote host prompts for the username a second time (the method assumes that the credentials provided were invalid) then the error mode action is performed. See errmode().
If username/password are not provided but are required and prompt_credentials is true, the method will automatically prompt the user for them interactively; otherwise the error mode action is performed.
The optional "prompt_credentials" argument is provided to override the global setting of the parameter by the same name which is by default false. See prompt_credentials().
In non-blocking mode (blocking disabled) the login() method will most likely immediately return with a false, but defined, value of 0. You will then need to call the login_poll() method at regular intervals until it returns a true (1) value indicatin...
If using the login() method in non-blocking mode, the following examples illustrate how this works:
=over 4
=item *
If you do not care to retrieve the login sequence output:
$ok = $obj->login(Username => "admin", Password => "pwd", Blocking => 0);
until ($ok) { # This loop will be executed while $ok = 0
<do other stuff here..>
$ok = $obj->login_poll;
}
=item *
If you want to retrieve the login output sequence along the way (even in case of error/timeout):
($ok, $output) = $obj->login(Username => "admin", Password => "pwd", Blocking => 0, Errmode => 'return');
die $obj->errmsg unless defined $ok; # Login failed
until ($ok) {
<do other stuff here..>
($ok, $partialOutput) = $obj->login_poll;
die $obj->errmsg unless defined $ok; # Login failed or timeout
$output .= $partialOutput;
}
print "Complete login sequence output:\n", $output;
=item *
If you only want to retrieve the full login sequence output at the end:
$ok = $obj->login(Username => "admin", Password => "pwd", Blocking => 0);
until ($ok) {
<do other stuff here..>
$ok = $obj->login_poll;
}
print "Complete login sequence output:\n", ($obj->login_poll)[1];
=back
=item B<cmd() & cmd_poll()> - Sends a CLI command to host and returns output data
Backward compatible syntax:
$output || $outputRef = $obj->cmd($cliCommand);
$output || $outputRef = $obj->cmd(
[Command => $cliCommand,]
[Prompt => $prompt,]
[Blocking => $flag,]
lib/Control/CLI.pm view on Meta::CPAN
In the readwait() method, determines how many non-blocking read attempts are made to see if there is any further input data coming in after the initial blocking read. By default 5 read attempts are performed, each at readwait_timer() seconds apart.
This method also returns the current or previous value of the setting.
=item B<readwait_timer()> - set the polling timer used in readwait() method
$millisecs = $obj->readwait_timer;
$prev = $obj->readwait_timer($millisecs);
In the readwait() method, determines how long to wait between consecutive reads for more data. By default this is set to 100 milliseconds.
This method also returns the current or previous value of the setting.
=item B<data_with_error()> - set the readwait() method behaviour in case a read error occurs after some data was read
$flag = $obj->data_with_error;
$prev = $obj->data_with_error($flag);
In the readwait() method, if some data was initially read but an error occurs while trying to read in subsequent data this flag determines the behaviour for the method.
By default data_with_error is not set, and this will result in readwait() performing the error mode action regardless of whether some data was already read in or not.
If however data_with_error is set, then the readwait() method will hold off from performing the error mode action (only if some data was already read) and will instead return that data without completing any further read_attempts.
This method also returns the current or previous value of the setting.
=item B<return_reference()> - set whether read methods should return a hard reference or not
$flag = $obj->return_reference;
$prev = $obj->return_reference($flag);
This method gets or sets the setting for return_reference for the object.
This applies to the read(), readwait(), waitfor(), cmd() and login() methods and determines whether these methods should return a hard reference to any output data or the data itself. By default return_reference is false (0) and the data itself is re...
However, if reading large amounts of data via the above mentioned read methods, using references will result in faster and more efficient code.
=item B<binmode()> - enable/disable newline translation
$flag = $obj->binmode;
$prev = $obj->output_record_separator($flag);
This method gets or sets the setting for binmode for the object. By default binmode is disabled (0) which means that newlines "\n" are translated into CR+LF by print() and put() and in reverse CR+LF are translated back into newline "\n" by read() and...
=item B<output_record_separator()> - set the Output Record Separator automatically appended by print & cmd methods
$ors = $obj->output_record_separator;
$prev = $obj->output_record_separator($ors);
This method gets or sets the Output Record Separator character (or string) automatically appended by print(), printlist() and cmd() methods when sending a command string to the host.
By default the Output Record Separator is a new line character "\n".
Note that by default this modules does newline translation, see binmode(), so the default new line character "\n" will always be translated to CR + LF unless binmode is enabled.
If you do not want a new line character automatically appended consider using put() instead of print().
Alternatively (or if a different character than newline is required) modify the Output Record Separator for the object via this method.
=item B<prompt_credentials()> - set whether connect() and login() methods should be able to prompt for credentials
$flag = $obj->prompt_credentials;
$prev = $obj->prompt_credentials($flag | \&codeRef | \@arrayRef);
This method gets or sets the setting for prompt_credentials for the object.
This applies to the connect() and login() methods and determines whether these methods can interactively prompt for username/password/passphrase information if these are required but not already provided. Note that enabling prompt_credentials is inco...
Prompt_credentials may be set to a code reference or an array reference (provided that the first element of the array is a code reference); in this case if the user needs to be prompted for a credential, the code reference provided will be called, fo...
=over 4
=item *
$privacy : Will be set to either 'Clear' or 'Hide', depending on whether a username or password/passphrase is requested
=item *
$credential : This will contain the text of what information is seeked from user; e.g. "Username", "Password", "Passphrase", etc.
=back
The ability to use a code reference is also true on the prompt_credentials argument override that connect() and login() offer.
If prompt_credentials is set to a true value (which is not a reference) then the object will make use of class methods promptClear() and promptHide() which both make use of Term::ReadKey. By default prompt_credentials is false (0).
=item B<flush_credentials> - flush the stored username, password and passphrase credentials
$obj->flush_credentials;
The connect() and login() methods, if successful in authenticating, will automatically store the username/password or SSH passphrase supplied to them.
These can be retrieved via the username, password and passphrase methods. If you do not want these to persist in memory once the authentication has completed, use this method to flush them. This method always returns 1.
=item B<prompt()> - set the CLI prompt match pattern for this object
$string = $obj->prompt;
$prev = $obj->prompt($string);
This method sets the CLI prompt match pattern for this object. In the first form the current pattern match string is returned. In the second form a new pattern match string is set and the previous setting returned.
The default prompt match pattern used is:
'.*[\?\$%#>](?:\e\[00?m)?\s?$'
The object CLI prompt match pattern is only used by the login() and cmd() methods.
=item B<username_prompt()> - set the login() username prompt match pattern for this object
$string = $obj->username_prompt;
$prev = $obj->username_prompt($string);
This method sets the login() username prompt match pattern for this object. In the first form the current pattern match string is returned. In the second form a new pattern match string is set and the previous setting returned.
The default prompt match pattern used is:
'(?i:user(?: ?name)?|login)[: ]+$'
=item B<password_prompt()> - set the login() password prompt match pattern for this object
$string = $obj->password_prompt;
$prev = $obj->password_prompt($string);
This method sets the login() password prompt match pattern for this object. In the first form the current pattern match string is returned. In the second form a new pattern match string is set and the previous setting returned.
The default prompt match pattern used is:
'(?i)(?<!new )password[: ]+$'
=item B<terminal_type()> - set the terminal type for the connection
$string = $obj->terminal_type;
$prev = $obj->terminal_type($string);
This method sets the terminal type which will be setup/negotiated during connection. In the first form the current setting is returned.
Currently a terminal type is only negotiated with a SSH or TELNET connection, and only at connection time.
By default no terminal type is defined which results in TELNET simply not negotiating any terminal type while SSH will default to 'vt100'.
Once a terminal type is set via this method, both TELNET and SSH will negotiate that terminal type.
Use an empty string to undefine the terminal type.
=item B<window_size()> - set the terminal window size for the connection
($width, $height) = $obj->window_size;
lib/Control/CLI.pm view on Meta::CPAN
The $firstReadRequired argument determines whether an initial read of data is required (and if we don't get any, then we timeout; just like the readwait() method in blocking mode) or whether we just wait the wait timer and return any data received du...
If some output was read during the 1st call, the poll structure "waittime" is set to the waitread behaviour where we wait a certain amount of time before making the output available. Subsequent poll calls to this function will only make the output av...
If instead no data has yet been read (and $firstReadRequired was true) then a check is made to see if we have passed the timeout or not; the method will return 0 if the timeout has not expired yet, or $obj->error($pkgsub.'Timeout error string') in ca...
The $dataWithError flag can be set to obtain the equivalent behaviuor of readwait() when some data has been read and a read error occurs during subsequent reads.
Follows an example on how to use this method:
do {
my $ok = $self->poll_readwait($pkgsub, 1, $readAttempts, $readwaitTimer, 'Timeout <custom message>');
return $self->poll_return($ok) unless $ok; # Come out if error (if errmode='return'), or if nothing to read in non-blocking mode
< process data in $self->{POLL}{read_buffer}>
} until <loop satisfied condition>;
=item B<poll_waitfor()> - performs a non-blocking poll for waitfor()
($ok, $dataref, $matchref) = $obj->poll_waitfor($pkgsub,
[Match => $matchpattern | \@matchpatterns
[Timeout => $secs,]
[Errmode => $errmode,]
);
Normally this is the internal method used by waitfor() and waitfor_poll() methods.
It is exposed so that sub classing modules can leverage the functionality within new methods themselves implementing polling.
These newer methods would have already set up a polling structure of their own.
When calling poll_waitfor() directly for the 1st time, it will detect an already existing poll structure and add itself to it (as well as caching some of it's keys; see poll_struct_cache). It will also read in the arguments provided at this point.
On subsequent calls, the arguments provided are ignored and the method simply polls the progress of the current task.
Follows an example on how to use this method:
< processing previous stages >
if ($newMethod->{stage} < X) { # stage X
my ($ok, $dataref, $matchref) = $self->poll_waitfor(
Match => 'Login: $',
Timeout => [$timeout],
Errmode => [$errmode]
);
return $self->poll_return($ok) unless $ok;
$newMethod->{stage}++; # Move to next stage X+1
}
< processing of next stages here >
=item B<poll_connect()> - performs a non-blocking poll for connect()
$ok = $obj->poll_connect($pkgsub,
[Host => $host,]
[Port => $port,]
[Username => $username,]
[Password => $password,]
[PublicKey => $publicKey,]
[PrivateKey => $privateKey,]
[Passphrase => $passphrase,]
[Prompt_credentials => $flag,]
[BaudRate => $baudRate,]
[Parity => $parity,]
[DataBits => $dataBits,]
[StopBits => $stopBits,]
[Handshake => $handshake,]
[Connection_timeout => $secs,]
[Errmode => $errmode,]
[Terminal_type => $string,]
[Window_size => [$width, $height],]
);
Normally this is the internal method used by connect() and connect_poll() methods.
It is exposed so that sub classing modules can leverage the functionality within new methods themselves implementing polling.
These newer methods would have already set up a polling structure of their own.
When calling poll_connect() directly for the 1st time, it will detect an already existing poll structure and add itself to it (as well as caching some of it's keys; see poll_struct_cache). It will also read in the arguments provided at this point.
On subsequent calls, the arguments provided are ignored and the method simply polls the progress of the current task.
=item B<poll_login()> - performs a non-blocking poll for login()
($ok, $outputref) = $obj->poll_login($pkgsub,
[Username => $username,]
[Password => $password,]
[Prompt_credentials => $flag,]
[Prompt => $prompt,]
[Username_prompt => $usernamePrompt,]
[Password_prompt => $passwordPrompt,]
[Timeout => $secs,]
[Errmode => $errmode,]
);
Normally this is the internal method used by login() and login_poll() methods.
It is exposed so that sub classing modules can leverage the functionality within new methods themselves implementing polling.
These newer methods would have already set up a polling structure of their own.
When calling poll_login() directly for the 1st time, it will detect an already existing poll structure and add itself to it (as well as caching some of it's keys; see poll_struct_cache). It will also read in the arguments provided at this point.
On subsequent calls, the arguments provided are ignored and the method simply polls the progress of the current task.
Return values after $ok will only be defined if $ok is true(1).
=item B<poll_cmd()> - performs a non-blocking poll for cmd()
($ok, $outputref) = $obj->poll_cmd($pkgsub,
[Command => $cliCommand,]
[Prompt => $prompt,]
[Timeout => $secs,]
[Errmode => $errmode,]
);
Normally this is the internal method used by cmd() and cmd_poll() methods.
It is exposed so that sub classing modules can leverage the functionality within new methods themselves implementing polling.
These newer methods would have already set up a polling structure of their own.
When calling poll_cmd() directly for the 1st time, it will detect an already existing poll structure and add itself to it (as well as caching some of it's keys; see poll_struct_cache). It will also read in the arguments provided at this point.
On subsequent calls, the arguments provided are ignored and the method simply polls the progress of the current task.
Return values after $ok will only be defined if $ok is true(1).
=item B<poll_change_baudrate()> - performs a non-blocking poll for change_baudrate()
$ok = $obj->poll_change_baudrate($pkgsub,
[BaudRate => $baudRate,]
[Parity => $parity,]
[DataBits => $dataBits,]
[StopBits => $stopBits,]
[Handshake => $handshake,]
[Errmode => $errmode,]
);
Normally this is the internal method used by change_baudrate() method.
It is exposed so that sub classing modules can leverage the functionality within new methods themselves implementing polling.
These newer methods would have already set up a polling structure of their own.
When calling poll_change_baudrate() directly for the 1st time, it will detect an already existing poll structure and add itself to it (as well as caching some of it's keys; see poll_struct_cache). It will also read in the arguments provided at this p...
On subsequent calls, the arguments provided are ignored and the method simply polls the progress of the current task.
=item B<debugMsg()> - prints out a debug message
$obj->debugMsg($msgLevel, $string1 [, $stringRef [,$string2]]);
A logical AND is performed between $msgLevel and the object debug level - see debug(); if the result is true, then the message is printed.
The message can be provided in 3 chunks: $string1 is always present, followed by an optional string reference (to dump large amout of data) and $string2.
=back
lib/Control/CLI.pm view on Meta::CPAN
=over 4
=item B<useTelnet> - can Telnet be used ?
$yes = Control::CLI::useTelnet;
Returns a true (1) value if Net::Telnet is installed and hence Telnet access can be used with this class.
=item B<useSsh> - can SSH be used ?
$yes = Control::CLI::useSsh;
Returns a true (1) value if Net::SSH2 is installed and hence SSH access can be used with this class.
=item B<useSerial> - can Serial port be used ?
$yes = Control::CLI::useSerial;
Returns a true (1) value if Win32::SerialPort (on Windows) or Device::SerialPort (on non-Windows) is installed and hence Serial port access can be used with this class.
=item B<useIPv6> - can IPv6 be used with Telnet or SSH ?
$yes = Control::CLI::useIPv6;
Returns a true (1) value if IO::Socket::IP is installed and hence both Telnet and SSH can operate on IPv6 as well as IPv4.
=item B<poll()> - poll objects for completion
This method has a double identity, as object method or class method. It was already covered under the Object Methods section.
=back
The remainder of these class methods is exposed with the intention to make these available to modules sub-classing Control::CLI.
=over 4
=item B<promptClear()> - prompt for username in clear text
$username = Control::CLI::promptClear($prompt);
This method prompts (using $prompt) user to enter a value/string, typically a username.
User input is visible while typed in.
=item B<promptHide()> - prompt for password in hidden text
$password = Control::CLI::promptHide($prompt);
This method prompts (using $prompt) user to enter a value/string, typically a password or passphrase.
User input is hidden while typed in.
=item B<promptCredential()> - prompt for credential using either prompt class methods or code reference
$credential = Control::CLI::promptCredential($prompt_credentials, $privacy, $credentialNeeded);
This method should only be called when prompt_credentials is set and the value of prompt_credentials should be passed as the first argument. If prompt_credentials is not a reference and is set to a true value and privacy is 'Clear' then promptClear($...
=item B<passphraseRequired()> - check if private key requires passphrase
$yes = Control::CLI::passphraseRequired($privateKey);
This method opens the private key provided (DSA or RSA) and verifies whether the key requires a passphrase to be used.
Returns a true (1) value if the key requires a passphrase and false (0) if not.
On failure to open/find the private key provided an undefined value is returned.
=item B<parseMethodArgs()> - parse arguments passed to a method against list of valid arguments
%args = Control::CLI::parseMethodArgs($methodName, \@inputArgs, \@validArgs, $noCarpFlag);
This method checks all input arguments against a list of valid arguments and generates a warning message if an invalid argument is found. The warning message will contain the $methodName passed to this function. The warning message can be suppressed ...
Additionally, all valid input arguments are returned as a hash where the hash key (the argument) is set to lowercase.
=item B<suppressMethodArgs()> - parse arguments passed to a method and suppress selected arguments
%args = Control::CLI::suppressMethodArgs(\@inputArgs, \@suppressArgs);
This method checks all input arguments against a list of arguments to be suppressed. Remaining arguments are returned as a hash where the hash key (the argument) is set to lowercase.
=item B<parse_errmode()> - parse a new value for the error mode and return it if valid or undef otherwise
$errmode = Control::CLI::parse_errmode($inputErrmode);
This method will check the input error mode supplied to it to ensure that it is a valid error mode.
If one of the valid strings 'die', 'croak' or 'return' it will ensure that the returned $errmode has the string all in lowercase.
For an array ref it will ensure that the first element of the array ref is a code ref.
If the input errmode is found to be invalid in any way, a warning message is printed with carp and an undef value is returned.
=item B<stripLastLine()> - strip and return last incomplete line from string reference provided
$lastLine = Control::CLI::stripLastLine(\$stringRef);
This method will take a reference to a string and remove and return the last incomplete line, if any. An incomplete line is constituted by any text not followed by a newline (\n).
If the string terminates with a newline (\n) then this method will return an empty string.
=item B<validCodeRef()> - validates reference as either a code ref or an array ref where first element is a code ref
$ok = Control::CLI::validCodeRef($value);
This method will verify that the value provided is either a code reference or an array reference where the first element is a code reference and if so will return a true value.
If not, it will return an undefined value.
=item B<callCodeRef()> - calls the code ref provided (which should be a code ref or an array ref where first element is a code ref)
$ok = Control::CLI::callCodeRef($codeOrArrayRef, @arguments);
If provided with a code reference, this method will call that code reference together with the provided arguments.
If provided with an array reference, it will shift the first element of the array and call that as a code reference. The arguments provided to code being called will be the remainder of the elements of the array reference to which the provided argume...
=back
( run in 0.710 second using v1.01-cache-2.11-cpan-e1769b4cff6 )