Control-CLI
view release on metacpan or search on metacpan
lib/Control/CLI.pm view on Meta::CPAN
}
sub stripLastLine { # Remove incomplete (not ending with \n) last line, if any from the string ref provided
my $dataRef = shift;
$$dataRef =~ s/(.*)\z//;
return defined $1 ? $1 : '';
}
sub validCodeRef { # Checks validity of code reference / array ref where 1st element is a code ref
my $codeRef = shift;
return 1 if ref($codeRef) eq 'CODE';
return 1 if ref($codeRef) eq 'ARRAY' && ref($codeRef->[0]) eq 'CODE';
return;
}
sub callCodeRef { # Executes a codeRef either as direct codeRef or array ref where 1st element is a code ref
my $callRef = shift;
return &$callRef(@_) if ref($callRef) eq 'CODE';
# Else ARRAY ref where 1st element is the codeRef
my @callArgs = @$callRef; # Copy the array before shifting it below, as we need to preserve it
my $codeRef = shift(@callArgs);
return &$codeRef(@callArgs, @_);
}
sub promptCredential { # Automatically handles credential prompt for code reference or local prompting
my ($mode, $privacy, $credential) = @_;
return callCodeRef($mode, $privacy, $credential) if validCodeRef($mode);
return promptClear($credential) if lc($privacy) eq 'clear';
return promptHide($credential) if lc($privacy) eq 'hide';
return;
}
############################################# Constructors/Destructors #######################################
sub new {
my $pkgsub = "${Package}::new";
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my (%args, $errmode, $msgFormat, $connectionType, $parent, $comPort, $debug);
if (@_ == 1) { # Method invoked with just the connection type argument
$connectionType = shift;
}
else {
%args = parseMethodArgs($pkgsub, \@_, \@ConstructorArgs);
$connectionType = $args{use};
}
$debug = defined $args{debug} ? $args{debug} : $Default{debug};
$errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : $Default{errmode};
$msgFormat = defined $args{errmsg_format} ? $args{errmsg_format} : $Default{errmsg_format};
return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Connection type must be specified in constructor", $msgFormat) unless defined $connectionType;
if ($connectionType =~ /^TELNET$/i) {
croak "$pkgsub: Module 'Net::Telnet' required for telnet access" unless $UseTelnet;
@CLI::ISA = qw(Net::Telnet);
$parent = Net::Telnet->new(Binmode => 1);
# Set up callbacks for telnet options
$parent->option_callback(\&_telnet_opt_callback);
$parent->suboption_callback(\&_telnet_subopt_callback);
$connectionType = 'TELNET';
}
elsif ($connectionType =~ /^SSH$/i) {
croak "$pkgsub: Module 'Net::SSH2' required for ssh access" unless $UseSSH;
@CLI::ISA = qw(Net::SSH2);
$parent = Net::SSH2->new();
$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,
lib/Control/CLI.pm view on Meta::CPAN
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}) {
# select_supported key is new in Net::Telnet 3.04 (does not exist in 3.03)
# 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
}
( run in 1.827 second using v1.01-cache-2.11-cpan-140bd7fdf52 )