Control-CLI
view release on metacpan or search on metacpan
lib/Control/CLI.pm view on Meta::CPAN
$self->{PARENT}->close;
$self->{SERIALEOF} = 1; # If all goes well we'll set this back to 0 on exit
if ($^O eq 'MSWin32') {
$self->{PARENT} = Win32::SerialPort->new($self->{COMPORT}, !($self->{debug} & 1))
or return $self->poll_return($self->error("$pkgsub: Cannot re-open serial port '$self->{COMPORT}'"));
}
else {
$self->{PARENT} = Device::SerialPort->new($self->{COMPORT}, !($self->{debug} & 1))
or return $self->poll_return($self->error("$pkgsub: Cannot re-open serial port '$self->{COMPORT}'"));
}
$self->{PARENT}->handshake($changeBaud->{handshake}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Handshake"));
$self->{PARENT}->baudrate($changeBaud->{baudrate}) or do {
# If error, could be Win32::SerialPort bug https://rt.cpan.org/Ticket/Display.html?id=120068
if ($^O eq 'MSWin32' && $changeBaud->{forcebaud}) { # With forcebaud we can force-set the desired baudrate
$self->{PARENT}->{"_N_BAUD"} = $changeBaud->{baudrate};
}
else { # Else we come out with error
return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Baudrate"));
}
};
$self->{PARENT}->parity($changeBaud->{parity}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Parity"));
unless ($changeBaud->{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($changeBaud->{databits}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort DataBits"));
$self->{PARENT}->stopbits($changeBaud->{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->{BAUDRATE} = $changeBaud->{baudrate};
$self->{PARITY} = $changeBaud->{parity};
$self->{DATABITS} = $changeBaud->{databits};
$self->{STOPBITS} = $changeBaud->{stopbits};
$self->{HANDSHAKE} = $changeBaud->{handshake};
$self->{SERIALEOF} = 0;
return $self->poll_return(1);
}
sub debugMsg { # Print a debug message
my $self = shift;
if (shift() & $self->{debug}) {
my $string1 = shift();
my $stringRef = shift() || \"";#" Ultraedit hack!
my $string2 = shift() || "";
print $string1, $$stringRef, $string2;
}
return;
}
########################################## Internal Private Methods ##########################################
sub _check_query { # Internal method to process Query Device Status escape sequences
my ($self, $pkgsub, $bufRef) = @_;
if (length $self->{QUERYBUFFER}) { # If an escape sequence fragment was cashed
$$bufRef = join('', $self->{QUERYBUFFER}, $$bufRef); # prepend it to new output
$self->{QUERYBUFFER} = '';
}
if ($$bufRef =~ /(\e(?:\[.?)?)$/){ # If output stream ends with \e, or \e[ or \e[.
# We could be looking at an escape sequence fragment; we check if it partially matches $VT100_QueryDeviceStatus
my $escFrag = $1;
if ($VT100_QueryDeviceStatus =~ /^\Q$escFrag\E/){ # If it does,
$$bufRef =~ s/\Q$escFrag\E$//; # we strip it
$self->{QUERYBUFFER} .= $escFrag; # and cache it
}
}
return unless $$bufRef =~ s/\Q$VT100_QueryDeviceStatus\E//go;
# A Query Device Status escape sequence was found and removed from output buffer
$self->_put($pkgsub, \$VT100_ReportDeviceOk); # Send a Report Device OK escape sequence
return;
}
sub _newlineTranslation { # Modified _interpret_cr() method from Net::Telnet; converts CR LF back into newlines upon reading data stream
my ($self, $bufRef) = @_;
my $pos = 0;
my $nextchar;
if (length $self->{PUSHBACKCR}) { # If an ending CR character was cashed
$$bufRef = join('', $self->{PUSHBACKCR}, $$bufRef); # prepend it to new output
$self->{PUSHBACKCR} = '';
}
while (($pos = index($$bufRef, "\015", $pos)) > -1) {
$nextchar = substr($$bufRef, $pos + 1, 1);
if ($nextchar eq "\012") { # Convert CR LF to newline
substr($$bufRef, $pos, 2) = "\n";
}
elsif (!length($nextchar)) { # Save CR in alt buffer for possible CR LF on next read
$self->{PUSHBACKCR} .= "\015";
chop $$bufRef;
}
$pos++;
}
return;
}
sub _read_buffer { # Internal method to read (and clear) any data cached in object buffer
my ($self, $returnRef) = @_;
my $buffer = $self->{BUFFER};
$self->{BUFFER} = '';
# $buffer will always be defined; worst case an empty string
return $returnRef ? \$buffer : $buffer;
}
sub _read_blocking { # Internal read method; data must be read or we timeout
my ($self, $pkgsub, $timeout, $returnRef) = @_;
my ($buffer, $startTime);
until (length $buffer) {
$startTime = time; # Record start time
if ($self->{TYPE} eq 'TELNET') {
$buffer = $self->{PARENT}->get(Timeout => $timeout);
return $self->error("$pkgsub: Received eof from connection") if $self->eof;
return $self->error("$pkgsub: Telnet ".$self->{PARENT}->errmsg) unless defined $buffer;
}
elsif ($self->{TYPE} eq 'SSH') {
return $self->error("$pkgsub: No SSH channel to read from") unless defined $self->{SSHCHANNEL};
$self->{SSHCHANNEL}->read($buffer, $self->{read_block_size});
lib/Control/CLI.pm view on Meta::CPAN
<do other stuff here..>
$ok = $obj->connect_poll;
die $obj->errmsg unless defined $ok; # Error or timeout connecting
}
Some considerations on using connect() in non-blocking mode:
=over 4
=item *
There is no delay in establishing a serial port connection, so setting non-blocking mode has no effect on serial port connections and the connection will be established after the first call to connect()
=item *
For Telnet and SSH connections, if you provided $host as a hostname which needs to resolve via DNS, the DNS lookup will still be blocking. You will either need to supply $host as a direct IP addresses or else write your own non-blocking DNS lookup co...
=item *
For SSH connections, only the TCP socket connection is treated in a true non-blocking fashion. SSH authentication will call Net::SSH2's auth_list(), auth_publickey() and/or auth_password() or auth_keyboard() which all behave in a blocking fashion; to...
=back
=item B<read()> - read block of data from object
$data || $dataref = $obj->read(
[Blocking => $flag,]
[Timeout => $secs,]
[Return_reference => $flag,]
[Binmode => $binmode,]
[Errmode => $errmode,]
);
This method reads a block of data from the object. If blocking is enabled - see blocking() - and no data is available, then the read method will wait for data until expiry of timeout - see timeout() -, then will perform the error mode action. See err...
In blocking mode, if no error or timeout, this method will always return a defined non-empty string.
In non-blocking mode, if no error and nothing was read, this method will always return a defined empty string.
In case of an error, and the error mode is 'return', this method will always return an undefined value.
The optional arguments are provided to override the global setting of the parameters by the same name for the duration of this method. Note that setting these arguments does not alter the global setting for the object. See also timeout(), blocking(),...
Returns either a hard reference to any data read or the data itself, depending on the applicable setting of "return_reference". See return_reference().
=item B<readwait()> - read in data initially in blocking mode, then perform subsequent non-blocking reads for more
$data || $dataref = $obj->readwait(
[Read_attempts => $numberOfReadAttemps,]
[Readwait_timer => $millisecs,]
[Data_with_error => $flag,]
[Blocking => $flag,]
[Timeout => $secs,]
[Return_reference => $flag,]
[Binmode => $binmode,]
[Errmode => $errmode,]
);
If blocking is enabled - see blocking() - this method implements an initial blocking read followed by a number of non-blocking reads. The intention is that we expect to receive at least some data and then we wait a little longer to make sure we have ...
For the initial blocking read, if no data is available, the method will wait until expiry of timeout. If a timeout occurs, then the error mode action is performed as with the regular read() method in blocking mode. See errmode().
If blocking is disabled then no initial blocking read is performed, instead the method will move directly to the non-blocking reads (in this case the "timeout" and "errmode" arguments are not applicable).
Once some data has been read or blocking is disabled, then the method will perform a number of non-blocking reads at certain time intervals to ensure that any subsequent data is also read before returning.
The time interval is by default 100 milliseconds and can be either set via the readwait_timer() method or by specifying the optional "readwait_timer" argument which will override whatever value is globally set for the object. See readwait_timer().
The number of non-blocking reads is dependent on whether more data is received or not but a certain number of consecutive reads with no more data received will make the method return. By default that number is 5 and can be either set via the read_att...
Therefore note that this method will always introduce a delay of "readwait_timer" milliseconds times the value of "read_attempts" and faster response times can be obtained using the regular read() method.
In the event that some data was initially read, but a read error occured while trying to read in subsequent data (for example the connection was lost), the "data_with_error" flag will determine how the readwait method behaves. If the "data_with_error...
Returns either a hard reference to data read or the data itself, depending on the applicable setting of return_reference. See return_reference().
In blocking mode, if no error or timeout, this method will always return a defined non-empty string.
In non-blocking mode, if no error and nothing was read, this method will always return a defined empty string.
In case of an error, and the error mode is 'return', this method will always return an undefined value.
The optional arguments are provided to override the global setting of the parameters by the same name for the duration of this method. Note that setting these arguments does not alter the global setting for the object. See also read_attempts(), timeo...
=item B<waitfor() & waitfor_poll()> - wait for pattern in the input stream
Backward compatible syntax:
$data || $dataref = $obj->waitfor($matchpat);
($data || $dataref, $match || $matchref) = $obj->waitfor($matchpat);
$data || $dataref = $obj->waitfor(
[Match => $matchpattern1,
[Match => $matchpattern2,
[Match => $matchpattern3,
... ]]]
[Match_list => \@arrayRef,]
[Blocking => $flag,]
[Timeout => $secs,]
[Return_reference => $flag,]
[Errmode => $errmode,]
);
($data || $dataref, $match || $matchref) = $obj->waitfor(
[Match => $matchpattern1,
[Match => $matchpattern2,
[Match => $matchpattern3,
... ]]]
[Match_list => \@arrayRef,]
[Blocking => $flag,]
[Timeout => $secs,]
[Return_reference => $flag,]
[Errmode => $errmode,]
);
New syntax (for non-blocking use):
$ok = $obj->waitfor(
Poll_syntax => 1,
[Match => $matchpattern1,
[Match => $matchpattern2,
[Match => $matchpattern3,
... ]]]
[Match_list => \@arrayRef,]
[Blocking => $flag,]
lib/Control/CLI.pm view on Meta::CPAN
[Return_reference => $flag,]
[Errmode => $errmode,]
);
Polling method (only applicable in non-blocking mode):
$ok = $obj->cmd_poll();
($ok, $output || $outputRef) = $obj->cmd_poll();
This method sends a CLI command to the host and returns once a new CLI prompt is received from the host. The output record separator - which is usually a newline "\n"; see output_record_separator() - is automatically appended to the command string. I...
Before sending the command to the host, any pending input data from host is read and flushed.
The CLI prompt expected by the cmd() method is either the prompt defined for the object - see prompt() - or the override defined using the optional "prompt" argument.
For backwards compatibility, in scalar context the output data from the command is returned.
The new syntax, in scalar context returns the poll status, while in list context, both the poll status together with the output data are returned. Note that to disambiguate the new scalar context syntax the 'poll_syntax' argument needs to be set (whi...
In non-blocking mode, the poll status will most likely immediately return with a false, but defined, value of 0. You will then need to call the cmd_poll() method at regular intervals until it returns a true (1) value indicating that the command has c...
The output data returned is either a hard reference to the output or the output itself, depending on the setting of return_reference; see return_reference().
The echoed command is automatically stripped from the output as well as the terminating CLI prompt (the last prompt received from the host device can be obtained with the last_prompt() method).
This means that when sending a command which generates no output, either a null string or a reference pointing to a null string will be returned.
On I/O failure to the host device, the error mode action is performed. See errmode().
If output is no longer received from the host and no valid CLI prompt has been seen, the method will timeout - see timeout() - and will then perform the error mode action.
The cmd() method is equivalent to the following combined methods:
$obj->read(Blocking => 0);
$obj->print($cliCommand);
$output = $obj->waitfor($obj->prompt);
In non-blocking mode (blocking disabled) the cmd() method will most likely immediately return with a false, but defined, value of 0. You will then need to call the cmd_poll() method at regular intervals until it returns a true (1) value indicating th...
=over 4
=item *
If you do not care to retrieve any output from the command:
$ok = $obj->cmd(Poll_syntax => 1, Command => "set command", Blocking => 0);
until ($ok) { # This loop will be executed while $ok = 0
<do other stuff here..>
$ok = $obj->cmd_poll;
}
=item *
If you want to retrieve the command output sequence along the way:
($ok, $output) = $obj->cmd(Command => "show command", Blocking => 0, Errmode => 'return');
die $obj->errmsg unless defined $ok; # Sending command failed
until ($ok) {
<do other stuff here..>
($ok, $partialOutput) = $obj->cmd_poll;
die $obj->errmsg unless defined $ok; # Timeout
$output .= $partialOutput;
}
print "Complete command output:\n", $output;
Note that $partialOutput returned will always terminate at output line boundaries (i.e. you can be sure that the last line is complete and not a fragment waiting for more output from device) so the output can be safely parsed for any seeked informato...
=item *
If you only want to retrieve the command output at the end:
$ok = $obj->cmd(Poll_syntax => 1, Command => "show command", Blocking => 0);
until ($ok) {
<do other stuff here..>
$ok = $obj->cmd_poll;
}
print "Complete command output:\n", ($obj->cmd_poll)[1];
=back
=item B<change_baudrate() & change_baudrate_poll()> - Change baud rate or other serial port parameter on current serial connection
$ok = $obj->change_baudrate($baudRate);
$ok = $obj->change_baudrate(
[BaudRate => $baudRate,]
[ForceBaud => $flag,]
[Parity => $parity,]
[DataBits => $dataBits,]
[StopBits => $stopBits,]
[Handshake => $handshake,]
[Blocking => $flag,]
[Errmode => $errmode,]
);
Polling method (only applicable in non-blocking mode):
$ok = $obj->change_baudrate_poll();
This method is only applicable to an already established Serial port connection and will return an error if the connection type is Telnet or SSH or if the object type is for Serial but no connection is yet established.
The serial connection is restarted with the new baudrate (in the background, the serial connection is actually disconnected and then re-connected) without losing the current CLI session. This method will introduce a 100 millisec delay between tearing...
If there is a problem restarting the serial port connection with the new settings then the error mode action is performed - see errmode().
If the baudrate (or other parameter) was successfully changed a true (1) value is returned.
Note that you have to change the baudrate on the far end device before calling this method to change the connection's baudrate. Follows an example:
use Control::CLI;
# Create the object instance for Serial port
$cli = new Control::CLI('COM1');
# Connect to host at default baudrate
$cli->connect( BaudRate => 9600 );
# Send some character sequence to wake up the other end, e.g. a carriage return
$cli->print;
# Perform login (or just lock onto 1st prompt)
$cli->login( Username => $username, Password => $password );
# Set the new baudrate on the far end device
# NOTE use print as you won't be able to read the prompt at the new baudrate right now
$cli->print("term speed 38400");
# Now change baudrate for the connection
$cli->change_baudrate(38400);
# Send a carriage return and expect to get a new prompt back
$cli->cmd; #If no prompt is seen at the new baudrate, we will timeout here
# Send a command and read the resulting output
$outref = $cli->cmd("command which generates lots of output...");
( run in 0.609 second using v1.01-cache-2.11-cpan-364913b4093 )