File Coverage

blib/lib/Control/CLI.pm
Criterion Covered Total %
statement 81 1575 5.1
branch 44 1256 3.5
condition 4 279 1.4
subroutine 17 120 14.1
pod 93 93 100.0
total 239 3323 7.1


line stmt bran cond sub pod time code
1             package Control::CLI;
2              
3 1     1   162633 use strict;
  1         2  
  1         32  
4 1     1   3 use warnings;
  1         1  
  1         43  
5 1     1   3 use Exporter qw( import );
  1         1  
  1         41  
6 1     1   4 use Carp;
  1         1  
  1         54  
7 1     1   668 use Term::ReadKey;
  1         2942  
  1         139  
8 1     1   10 use Time::HiRes qw( time sleep );
  1         2  
  1         11  
9 1     1   94 use IO::Handle;
  1         2  
  1         47  
10 1     1   616 use IO::Socket::INET;
  1         23971  
  1         7  
11 1     1   644 use Errno qw( EINPROGRESS EWOULDBLOCK );
  1         2  
  1         35969  
12              
13             my $Package = __PACKAGE__;
14             our $VERSION = '2.12';
15             our %EXPORT_TAGS = (
16             use => [qw(useTelnet useSsh useSerial useIPv6)],
17             prompt => [qw(promptClear promptHide promptCredential)],
18             args => [qw(parseMethodArgs suppressMethodArgs)],
19             coderef => [qw(validCodeRef callCodeRef)],
20             _rest => [qw(passphraseRequired parse_errmode stripLastLine poll)],
21             );
22             push @{$EXPORT_TAGS{all}}, @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
23             Exporter::export_ok_tags('all');
24              
25             ########################################### Global Class Variables ###########################################
26              
27             my $PollTimer = 100; # Some connection types require a polling loop; this is the loop sleep timer in ms
28             my $ComPortReadBuffer = 4096; # Size of serial port read buffers
29             my $ComReadInterval = 100; # Timeout between single character reads
30             my $ComBreakDuration = 300; # Number of milliseconds the break signal is held for
31             my $ChangeBaudDelay = 100; # Number of milliseconds to sleep between tearing down and restarting serial port connection
32             my $VT100_QueryDeviceStatus = "\e[5n"; # With report_query_status, if received from host
33             my $VT100_ReportDeviceOk = "\e[0n"; # .. sent to host, with report_query_status
34              
35             my %Default = ( # Hash of default object settings which can be modified on a per object basis
36             timeout => 10, # Default Timeout value in secs
37             connection_timeout => undef, # Default Connection Timeout value in secs
38             connection_timeout_nb => 20, # If above is undefined, still need to set a value for connections in non-blocking mode
39             blocking => 1, # Default blocking mode
40             return_reference => 0, # Whether methods return data (0) or hard referece to it (1)
41             read_attempts => 5, # Empty reads to wait in readwait() before returning
42             readwait_timer => 100, # Polling loop timer for readwait() in millisecs, for further input
43             data_with_error => 0, # Readwait() behaviour in case of read error following some data read
44             prompt_credentials => 0, # Interactively prompt for credentials (1) or not (0)
45             tcp_port => {
46             SSH => 22, # Default TCP port number for SSH
47             TELNET => 23, # Default TCP port number for TELNET
48             },
49             read_block_size => {
50             SSH => 4096, # Default Read Block Size for SSH
51             SERIAL_WIN32 => 1024, # Default Read Block Size for Win32::SerialPort
52             SERIAL_DEVICE => 255, # Default Read Block Size for Device::SerialPort
53             },
54             baudrate => 9600, # Default baud rate used when connecting via Serial port
55             handshake => 'none', # Default handshake used when connecting via Serial port
56             parity => 'none', # Default parity used when connecting via Serial port
57             databits => 8, # Default data bits used when connecting via Serial port
58             stopbits => 1, # Default stop bits used when connecting via Serial port
59             ors => "\n", # Default Output Record Separator used by print() & cmd()
60             binmode => 0, # Default binmode; if disabled newline translation will be done
61             errmode => 'croak', # Default error mode; can be: die/croak/return/coderef/arrayref
62             errmsg_format => 'default', # Default error message format; can be: terse/default/verbose
63             poll_obj_complete => 'all', # Default mode for poll() method
64             poll_obj_error => 'ignore', # Default error mode for poll() method
65             report_query_status => 0, # Default setting of report_query_status for class object
66             prompt => '.*[\?\$%#>](?:\e\[00?m)?\s?$', # Default prompt used in login() and cmd() methods
67             username_prompt => '(?i:user(?: ?name)?|login)[: ]+$', # Default username prompt used in login() method
68             password_prompt => '(?i)(?
69             terminal_type => 'vt100', # Default terminal type (for SSH)
70             window_size => [], # Default terminal window size [width, height]
71             debug => 0, # Default debug level; 0 = disabled
72             );
73              
74             our @ConstructorArgs = ( 'use', 'timeout', 'errmode', 'return_reference', 'prompt', 'username_prompt', 'password_prompt',
75             'input_log', 'output_log', 'dump_log', 'blocking', 'debug', 'prompt_credentials', 'read_attempts',
76             'readwait_timer', 'read_block_size', 'output_record_separator', 'connection_timeout', 'data_with_error',
77             'terminal_type', 'window_size', 'errmsg_format', 'report_query_status', 'binmode',
78             );
79              
80             # Debug levels can be set using the debug() method or via debug argument to new() constructor
81             # Debug levels defined:
82             # 0 : No debugging
83             # bit 1 : Debugging activated for for polling methods + readwait() and enables carping on Win32/Device::SerialPort
84             # This level also resets Win32/Device::SerialPort constructor $quiet flag only when supplied in Control::CLI::new()
85             # bit 2 : Debugging is activated on underlying Net::SSH2 and Win32::SerialPort / Device::SerialPort
86             # There is no actual debugging for Net::Telnet
87              
88              
89             my ($UseTelnet, $UseSSH, $UseSerial, $UseSocketIP);
90              
91              
92             ############################################## Required modules ##############################################
93              
94             if (eval {require Net::Telnet}) { # Make Net::Telnet optional
95             import Net::Telnet qw( TELNET_IAC TELNET_SB TELNET_SE TELNET_WILL TELOPT_TTYPE TELOPT_NAWS );
96             $UseTelnet = 1
97             }
98             $UseSSH = 1 if eval {require Net::SSH2}; # Make Net::SSH2 optional
99              
100             if ($^O eq 'MSWin32') {
101             $UseSerial = 1 if eval {require Win32::SerialPort}; # Win32::SerialPort optional on Windows
102             }
103             else {
104             $UseSerial = 1 if eval {require Device::SerialPort}; # Device::SerialPort optional on Unix
105             }
106             croak "$Package: no available module installed to operate on" unless $UseTelnet || $UseSSH || $UseSerial;
107              
108             $UseSocketIP = 1 if eval { require IO::Socket::IP }; # Provides IPv4 and IPv6 support
109              
110              
111             ################################################ Class Methods ###############################################
112              
113             sub useTelnet {
114 3     3 1 246173 return $UseTelnet;
115             }
116              
117             sub useSsh {
118 2     2 1 658 return $UseSSH;
119             }
120              
121             sub useSerial {
122 2     2 1 1054 return $UseSerial;
123             }
124              
125             sub useIPv6 {
126 1     1 1 6 return $UseSocketIP;
127             }
128              
129             sub promptClear { # Interactively prompt for a username, in clear text
130 0     0 1 0 my $username = shift;
131 0         0 my $input;
132 0         0 print "Enter $username: ";
133 0         0 ReadMode('normal');
134 0         0 chomp($input = ReadLine(0));
135 0         0 ReadMode('restore');
136 0         0 return $input;
137             }
138              
139             sub promptHide { # Interactively prompt for a password, input is hidden
140 0     0 1 0 my $password = shift;
141 0         0 my $input;
142 0         0 print "Enter $password: ";
143 0         0 ReadMode('noecho');
144 0         0 chomp($input = ReadLine(0));
145 0         0 ReadMode('restore');
146 0         0 print "\n";
147 0         0 return $input;
148             }
149              
150             sub passphraseRequired { # Inspects a private key to see if it requires a passphrase to be used
151 0     0 1 0 my $privateKey = shift;
152 0         0 my $passphraseRequired = 0;
153              
154             # Open the private key to see if passphrase required.. Net::SSH2 does not do this for us..
155 0 0       0 open(my $key, '<', $privateKey) or return;
156 0         0 while (<$key>) {
157 0 0       0 /ENCRYPTED/ && do { # Keys in OpenSSH format and passphrase encrypted
158 0         0 $passphraseRequired = 1;
159 0         0 last;
160             };
161             }
162 0         0 close $key;
163 0         0 return $passphraseRequired;
164             }
165              
166              
167             sub parseMethodArgs { # Parse arguments fed into a method against accepted arguments; also set them to lower case
168 1     1 1 4 my ($pkgsub, $argsRef, $validArgsRef, $noCarp) = @_;
169 1 50       4 return unless @$argsRef;
170 1         3 my ($even_lc, @argsIn, @argsOut, %validArgs);
171 1 100 66     4 @argsIn = map {++$even_lc%2 && defined $_ ? lc : $_} @$argsRef; # Sets to lowercase the hash keys only
  4         25  
172 1         4 foreach my $key (@$validArgsRef) { $validArgs{lc $key} = 1 }
  24         65  
173 1         7 for (my $i = 0; $i < $#argsIn; $i += 2) {
174 2 50       7 return unless defined $argsIn[$i];
175 2 50       9 if ($validArgs{$argsIn[$i]}) {
176 2         7 push @argsOut, $argsIn[$i], $argsIn[$i + 1];
177 2         7 next;
178             }
179 0 0       0 carp "$pkgsub: Invalid argument \"$argsIn[$i]\"" unless $noCarp;
180             }
181 1         9 return @argsOut;
182             }
183              
184              
185             sub suppressMethodArgs { # Parse arguments and remove the ones listed
186 0     0 1 0 my ($argsRef, $suppressArgsRef) = @_;
187 0 0       0 return unless @$argsRef;
188 0         0 my ($even_lc, @argsIn, @argsOut, %suppressArgs);
189 0 0       0 @argsIn = map {++$even_lc%2 ? lc : $_} @$argsRef; # Sets to lowercase the hash keys only
  0         0  
190 0         0 foreach my $key (@$suppressArgsRef) { $suppressArgs{lc $key} = 1 }
  0         0  
191 0         0 for (my $i = 0; $i < $#argsIn; $i += 2) {
192 0 0       0 next if $suppressArgs{$argsIn[$i]};
193 0         0 push @argsOut, $argsIn[$i], $argsIn[$i + 1];
194             }
195 0         0 return @argsOut;
196             }
197              
198              
199             sub parse_errmode { # Parse a new value for the error mode and return it if valid or undef otherwise
200 2     2 1 7 my ($pkgsub, $mode) = @_;
201              
202 2 50       33 if (!defined $mode) {
    50          
    50          
    50          
    0          
203 0         0 carp "$pkgsub: Errmode undefined argument; ignoring";
204 0         0 $mode = undef;
205             }
206 0         0 elsif ($mode =~ /^\s*die\s*$/i) { $mode = 'die' }
207 0         0 elsif ($mode =~ /^\s*croak\s*$/i) { $mode = 'croak' }
208 2         16 elsif ($mode =~ /^\s*return\s*$/i) { $mode = 'return' }
209             elsif ( ref($mode) ) {
210 0 0       0 unless ( validCodeRef($mode) ) {
211 0         0 carp "$pkgsub: Errmode first item of array ref must be a code ref; ignoring";
212 0         0 $mode = undef;
213             }
214             }
215             else {
216 0         0 carp "$pkgsub: Errmode invalid argument '$mode'; ignoring";
217 0         0 $mode = undef;
218             }
219 2         10 return $mode;
220             }
221              
222              
223             sub stripLastLine { # Remove incomplete (not ending with \n) last line, if any from the string ref provided
224 0     0 1 0 my $dataRef = shift;
225 0         0 $$dataRef =~ s/(.*)\z//;
226 0 0       0 return defined $1 ? $1 : '';
227             }
228              
229              
230             sub validCodeRef { # Checks validity of code reference / array ref where 1st element is a code ref
231 0     0 1 0 my $codeRef = shift;
232 0 0       0 return 1 if ref($codeRef) eq 'CODE';
233 0 0 0     0 return 1 if ref($codeRef) eq 'ARRAY' && ref($codeRef->[0]) eq 'CODE';
234 0         0 return;
235             }
236              
237              
238             sub callCodeRef { # Executes a codeRef either as direct codeRef or array ref where 1st element is a code ref
239 0     0 1 0 my $callRef = shift;
240 0 0       0 return &$callRef(@_) if ref($callRef) eq 'CODE';
241             # Else ARRAY ref where 1st element is the codeRef
242 0         0 my @callArgs = @$callRef; # Copy the array before shifting it below, as we need to preserve it
243 0         0 my $codeRef = shift(@callArgs);
244 0         0 return &$codeRef(@callArgs, @_);
245             }
246              
247              
248             sub promptCredential { # Automatically handles credential prompt for code reference or local prompting
249 0     0 1 0 my ($mode, $privacy, $credential) = @_;
250 0 0       0 return callCodeRef($mode, $privacy, $credential) if validCodeRef($mode);
251 0 0       0 return promptClear($credential) if lc($privacy) eq 'clear';
252 0 0       0 return promptHide($credential) if lc($privacy) eq 'hide';
253 0         0 return;
254             }
255              
256              
257             ############################################# Constructors/Destructors #######################################
258              
259             sub new {
260 1     1 1 15 my $pkgsub = "${Package}::new";
261 1         3 my $invocant = shift;
262 1   33     11 my $class = ref($invocant) || $invocant;
263 1         4 my (%args, $errmode, $msgFormat, $connectionType, $parent, $comPort, $debug);
264 1 50       4 if (@_ == 1) { # Method invoked with just the connection type argument
265 0         0 $connectionType = shift;
266             }
267             else {
268 1         8 %args = parseMethodArgs($pkgsub, \@_, \@ConstructorArgs);
269 1         4 $connectionType = $args{use};
270             }
271 1 50       5 $debug = defined $args{debug} ? $args{debug} : $Default{debug};
272 1 50       26 $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : $Default{errmode};
273 1 50       5 $msgFormat = defined $args{errmsg_format} ? $args{errmsg_format} : $Default{errmsg_format};
274 1 50       4 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Connection type must be specified in constructor", $msgFormat) unless defined $connectionType;
275              
276 1 50       4 if ($connectionType =~ /^TELNET$/i) {
    0          
277 1 50       3 croak "$pkgsub: Module 'Net::Telnet' required for telnet access" unless $UseTelnet;
278 1         34 @CLI::ISA = qw(Net::Telnet);
279 1         22 $parent = Net::Telnet->new(Binmode => 1);
280             # Set up callbacks for telnet options
281 1         403 $parent->option_callback(\&_telnet_opt_callback);
282 1         123 $parent->suboption_callback(\&_telnet_subopt_callback);
283 1         19 $connectionType = 'TELNET';
284             }
285             elsif ($connectionType =~ /^SSH$/i) {
286 0 0       0 croak "$pkgsub: Module 'Net::SSH2' required for ssh access" unless $UseSSH;
287 0         0 @CLI::ISA = qw(Net::SSH2);
288 0         0 $parent = Net::SSH2->new();
289 0         0 $connectionType = 'SSH';
290             }
291             else {
292 0 0       0 if ($^O eq 'MSWin32') {
293 0 0       0 croak "$pkgsub: Module 'Win32::SerialPort' required for serial access" unless $UseSerial;
294 0         0 @CLI::ISA = qw(Win32::SerialPort);
295 0         0 Win32::SerialPort->set_test_mode_active(!($debug & 1)); # Suppress carping except if debug bit1 set
296 0 0       0 Win32::SerialPort::debug($debug & 2 ? 'ON' : 'OFF');
297 0 0       0 $parent = Win32::SerialPort->new($connectionType, !($debug & 1))
298             or return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Cannot open serial port '$connectionType'", $msgFormat);
299             }
300             else {
301 0 0       0 croak "$pkgsub: Module 'Device::SerialPort' required for serial access" unless $UseSerial;
302 0         0 @CLI::ISA = qw(Device::SerialPort);
303 0         0 Device::SerialPort->set_test_mode_active(!($debug & 1)); # Suppress carping except if debug bit1 set
304 0 0       0 Device::SerialPort::debug($debug & 2 ? 'ON' : 'OFF');
305 0 0       0 $parent = Device::SerialPort->new($connectionType, !($debug & 1))
306             or return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Cannot open serial port '$connectionType'", $msgFormat);
307             }
308 0         0 $comPort = $connectionType;
309 0         0 $connectionType = 'SERIAL';
310             }
311             my $self = {
312             # Lower Case ones can be set by user; Upper case ones are set internaly in the class
313             TYPE => $connectionType,
314             PARENT => $parent,
315             SOCKET => undef,
316             SSHCHANNEL => undef,
317             SSHAUTH => undef,
318             BUFFER => '', # Always defined; greater than 0 length if in use
319             QUERYBUFFER => '', # Always defined; greater than 0 length if in use
320             COMPORT => $comPort,
321             HOST => undef,
322             TCPPORT => undef,
323             HANDSHAKE => undef,
324             BAUDRATE => undef,
325             PARITY => undef,
326             DATABITS => undef,
327             STOPBITS => undef,
328             INPUTLOGFH => undef,
329             OUTPUTLOGFH => undef,
330             DUMPLOGFH => undef,
331             USERNAME => undef,
332             PASSWORD => undef,
333             PASSPHRASE => undef,
334             LOGINSTAGE => '',
335             LASTPROMPT => undef,
336             SERIALEOF => 1,
337             TELNETMODE => 1,
338             PUSHBACKCR => '', # Always defined; used to push back CR in newline translation with binmode disabled
339             POLL => undef, # Storage hash for poll-capable methods
340             POLLING => 0, # Flag to track if in polling-capable method or not
341             POLLREPORTED => 0, # Flag used by poll() to track already reported objects
342             WRITEFLAG => 0, # Flag to keep track of when a write was last performed
343             timeout => $Default{timeout},
344             connection_timeout => $Default{connection_timeout},
345             blocking => $Default{blocking},
346             return_reference => $Default{return_reference},
347             prompt_credentials => $Default{prompt_credentials},
348             read_attempts => $Default{read_attempts},
349             readwait_timer => $Default{readwait_timer},
350             data_with_error => $Default{data_with_error},
351             read_block_size => $Default{read_block_size}{$connectionType},
352             ors => $Default{ors},
353             binmode => $Default{binmode},
354             errmode => $Default{errmode},
355             errmsg => '',
356             errmsg_format => $Default{errmsg_format},
357             prompt => $Default{prompt},
358             prompt_qr => qr/$Default{prompt}/,
359             username_prompt => $Default{username_prompt},
360             username_prompt_qr => qr/$Default{username_prompt}/,
361             password_prompt => $Default{password_prompt},
362             password_prompt_qr => qr/$Default{password_prompt}/,
363             terminal_type => $connectionType eq 'SSH' ? $Default{terminal_type} : undef,
364             window_size => $Default{window_size},
365             report_query_status => $Default{report_query_status},
366             debug => $Default{debug},
367 1 50       275 };
368 1 50       9 if ($connectionType eq 'SERIAL') { # Adjust read_block_size defaults for Win32::SerialPort & Device::SerialPort
369             $self->{read_block_size} = ($^O eq 'MSWin32') ? $Default{read_block_size}{SERIAL_WIN32}
370 0 0       0 : $Default{read_block_size}{SERIAL_DEVICE};
371             }
372 1         6 bless $self, $class;
373 1 50       5 if ($connectionType eq 'TELNET') {
374             # We are going to setup option callbacks to handle telnet options terminal type and window size
375             # However the callbacks only provide the telnet object and there is no option to feed additional arguments
376             # So need to link our object into the telnet one; here we create a key to contain our object
377 1         4 *$parent->{net_telnet}->{$Package} = $self;
378             }
379 1         4 foreach my $arg (keys %args) { # Accepted arguments on constructor
380 2 100       59 if ($arg eq 'errmode') { $self->errmode($args{$arg}) }
  1 50       6  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
381 0         0 elsif ($arg eq 'errmsg_format') { $self->errmsg_format($args{$arg}) }
382 0         0 elsif ($arg eq 'timeout') { $self->timeout($args{$arg}) }
383 0         0 elsif ($arg eq 'connection_timeout') { $self->connection_timeout($args{$arg}) }
384 0         0 elsif ($arg eq 'read_block_size') { $self->read_block_size($args{$arg}) }
385 0         0 elsif ($arg eq 'blocking') { $self->blocking($args{$arg}) }
386 0         0 elsif ($arg eq 'read_attempts') { $self->read_attempts($args{$arg}) }
387 0         0 elsif ($arg eq 'readwait_timer') { $self->readwait_timer($args{$arg}) }
388 0         0 elsif ($arg eq 'data_with_error') { $self->data_with_error($args{$arg}) }
389 0         0 elsif ($arg eq 'return_reference') { $self->return_reference($args{$arg}) }
390 0         0 elsif ($arg eq 'output_record_separator') { $self->output_record_separator($args{$arg}) }
391 0         0 elsif ($arg eq 'binmode') { $self->binmode($args{$arg}) }
392 0         0 elsif ($arg eq 'prompt_credentials') { $self->prompt_credentials($args{$arg}) }
393 0         0 elsif ($arg eq 'prompt') { $self->prompt($args{$arg}) }
394 0         0 elsif ($arg eq 'username_prompt') { $self->username_prompt($args{$arg}) }
395 0         0 elsif ($arg eq 'password_prompt') { $self->password_prompt($args{$arg}) }
396 0         0 elsif ($arg eq 'terminal_type') { $self->terminal_type($args{$arg}) }
397 0         0 elsif ($arg eq 'window_size') { $self->window_size(@{$args{$arg}}) }
  0         0  
398 0         0 elsif ($arg eq 'report_query_status') { $self->report_query_status($args{$arg}) }
399 0         0 elsif ($arg eq 'input_log') { $self->input_log($args{$arg}) }
400 0         0 elsif ($arg eq 'output_log') { $self->output_log($args{$arg}) }
401 0         0 elsif ($arg eq 'dump_log') { $self->dump_log($args{$arg}) }
402 0         0 elsif ($arg eq 'debug') { $self->debug($args{$arg}) }
403             }
404 1         9 return $self;
405             }
406              
407             sub DESTROY { # Run disconnect
408 0     0   0 my $self = shift;
409 0         0 return $self->disconnect;
410             }
411              
412              
413             ############################################### Object methods ###############################################
414              
415             sub connect { # Connect to host
416 0     0 1 0 my $pkgsub = "${Package}::connect";
417 0         0 my $self = shift;
418 0         0 my %args;
419 0 0       0 if (@_ == 1) { # Method invoked in the shorthand form
420 0         0 $args{host} = shift;
421 0 0 0     0 if ($args{host} =~ /^(.+?)\s+(\d+)$/ || $args{host} =~ /^([^:\s]+?):(\d+)$/) {
422 0         0 ($args{host}, $args{port}) = ($1, $2);
423             }
424             }
425             else {
426 0         0 my @validArgs = ('host', 'port', 'username', 'password', 'publickey', 'privatekey', 'passphrase',
427             'prompt_credentials', 'baudrate', 'parity', 'databits', 'stopbits', 'handshake',
428             'errmode', 'connection_timeout', 'blocking', 'terminal_type', 'window_size',
429             'callback', 'forcebaud', 'atomic_connect');
430 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
431             }
432              
433             # Initialize the base POLL structure
434             $self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
435             $pkgsub,
436             __PACKAGE__->can('connect_poll'),
437             defined $args{blocking} ? $args{blocking} : $self->{blocking},
438             defined $args{connection_timeout} ? $args{connection_timeout} : $self->{connection_timeout},
439 0 0       0 defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef,
    0          
    0          
440             0, # no output
441             0, # no output
442             undef, # n/a
443             undef, # n/a
444             );
445             $self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
446             # Set method argument keys
447             host => $args{host},
448             port => $args{port},
449             username => $args{username},
450             password => $args{password},
451             publickey => $args{publickey},
452             privatekey => $args{privatekey},
453             passphrase => $args{passphrase},
454             baudrate => $args{baudrate},
455             parity => $args{parity},
456             databits => $args{databits},
457             stopbits => $args{stopbits},
458             handshake => $args{handshake},
459             prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
460             terminal_type => $args{terminal_type},
461             window_size => $args{window_size},
462             callback => $args{callback},
463             forcebaud => $args{forcebaud},
464             atomic_connect => $args{atomic_connect},
465             # Declare method storage keys which will be used
466 0 0       0 stage => 0,
467             authPublicKey => 0,
468             authPassword => 0,
469             };
470 0 0 0     0 if ($self->{TYPE} ne 'SERIAL' && !$UseSocketIP && defined $args{blocking} && !$args{blocking}) {
      0        
      0        
471 0         0 carp "$pkgsub: IO::Socket::IP is required for non-blocking connect";
472             }
473 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
474 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
475 0         0 return __PACKAGE__->can('poll_connect')->($self, $pkgsub); # Do not call a sub-classed version
476             }
477              
478              
479             sub connect_poll { # Poll status of connection (non-blocking mode)
480 0     0 1 0 my $pkgsub = "${Package}::connect_poll";
481 0         0 my $self = shift;
482 0 0       0 carp "$pkgsub: No arguments expected" if @_; # No arguments expected
483              
484 0 0 0     0 unless (defined $self->{POLL} && $self->{POLL}{coderef} == __PACKAGE__->can('connect_poll')) {
485 0         0 return $self->error("$pkgsub: Method connect() needs to be called first with blocking false");
486             }
487 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
488 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
489              
490             # If already completed (1) or we got an error (undef) from previous call (errmsg is already set) then we go no further
491 0 0 0     0 return $self->poll_return($self->{POLL}{complete}) unless defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0;
492              
493             # We get here only if we are not complete: $self->{POLL}{complete} == 0
494 0         0 return __PACKAGE__->can('poll_connect')->($self, $pkgsub); # Do not call a sub-classed version
495             }
496              
497              
498             sub read { # Read in data from connection
499 0     0 1 0 my $pkgsub = "${Package}::read";
500 0         0 my $self = shift;
501 0         0 my @validArgs = ('blocking', 'timeout', 'binmode', 'errmode', 'return_reference');
502 0         0 my %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
503 0 0       0 my $timeout = defined $args{timeout} ? $args{timeout} : $self->{timeout};
504 0 0       0 my $blocking = defined $args{blocking} ? $args{blocking} : $self->{blocking};
505 0 0       0 my $returnRef = defined $args{return_reference} ? $args{return_reference} : $self->{return_reference};
506 0 0       0 my $binmode = defined $args{binmode} ? $args{binmode} : $self->{binmode};
507 0 0       0 my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef;
508 0 0       0 local $self->{binmode} = $binmode if defined $binmode;
509 0 0       0 local $self->{errmode} = $errmode if defined $errmode;
510              
511 0 0 0     0 return $self->_read_blocking($pkgsub, $timeout, $returnRef) if $blocking && !length $self->{BUFFER};
512 0         0 return $self->_read_nonblocking($pkgsub, $returnRef); # if !$blocking || ($blocking && length $self->{BUFFER})
513             }
514              
515              
516             sub readwait { # Read in data initially in blocking mode, then perform subsequent non-blocking reads for more
517 0     0 1 0 my $pkgsub = "${Package}::readwait";
518 0         0 my $self = shift;
519 0         0 my ($outref, $bufref);
520 0         0 my $ticks = 0;
521 0         0 my @validArgs = ('read_attempts', 'readwait_timer', 'blocking', 'timeout', 'binmode', 'errmode', 'return_reference', 'data_with_error');
522 0         0 my %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
523 0 0       0 my $readAttempts = defined $args{read_attempts} ? $args{read_attempts} : $self->{read_attempts};
524 0 0       0 my $readwaitTimer = defined $args{readwait_timer} ? $args{readwait_timer} : $self->{readwait_timer};
525 0 0       0 my $dataWithError = defined $args{data_with_error} ? $args{data_with_error} : $self->{data_with_error};
526 0 0       0 my $timeout = defined $args{timeout} ? $args{timeout} : $self->{timeout};
527 0 0       0 my $blocking = defined $args{blocking} ? $args{blocking} : $self->{blocking};
528 0 0       0 my $returnRef = defined $args{return_reference} ? $args{return_reference} : $self->{return_reference};
529 0 0       0 my $binmode = defined $args{binmode} ? $args{binmode} : $self->{binmode};
530 0 0       0 my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef;
531 0 0       0 local $self->{binmode} = $binmode if defined $binmode;
532 0 0       0 local $self->{errmode} = $errmode if defined $errmode;
533              
534             # Wait until some data is read in
535 0         0 $bufref = $self->_read_buffer(1);
536 0 0 0     0 if (!length $$bufref && $blocking) {
537 0         0 $bufref = $self->_read_blocking($pkgsub, $timeout, 1);
538 0 0       0 return unless defined $bufref; # Catch errors in 'return' errmode
539             }
540             # Then keep reading until there is nothing more to read..
541 0         0 while ($ticks++ < $readAttempts) {
542 0         0 sleep($readwaitTimer/1000); # Fraction of a sec sleep using Time::HiRes::sleep
543 0         0 $outref = $self->read( blocking => 0, return_reference => 1, errmode => 'return' );
544 0 0       0 unless (defined $outref) { # Here we catch errors since errmode = 'return'
545 0 0 0     0 last if $dataWithError && length $$bufref; # Data_with_error processing
546 0         0 return $self->error("$pkgsub: Read error // ".$self->errmsg);
547             }
548 0 0       0 if (length $$outref) {
549 0         0 $$bufref .= $$outref;
550 0         0 $ticks = 0; # Reset ticks to zero upon successful read
551             }
552 0         0 $self->debugMsg(1,"readwait ticks = $ticks\n");
553             }
554 0 0       0 return $returnRef ? $bufref : $$bufref;
555             }
556              
557              
558             sub waitfor { # Wait to find pattern in the device output stream
559 0     0 1 0 my $pkgsub = "${Package}::waitfor";
560 0         0 my $self = shift;
561 0         0 my ($pollSyntax, $errmode, @matchpat);
562 0         0 my $timeout = $self->{timeout};
563 0         0 my $blocking = $self->{blocking};
564 0         0 my $returnRef = $self->{return_reference};
565              
566 0 0       0 if (@_ == 1) { # Method invoked with single argument form
567 0         0 $matchpat[0] = shift;
568             }
569             else { # Method invoked with multiple arguments form
570 0         0 my @validArgs = ('match', 'match_list', 'timeout', 'errmode', 'return_reference', 'blocking', 'poll_syntax');
571 0         0 my @args = parseMethodArgs($pkgsub, \@_, \@validArgs);
572 0         0 for (my $i = 0; $i < $#args; $i += 2) {
573 0 0       0 push @matchpat, $args[$i + 1] if $args[$i] eq 'match';
574 0 0 0     0 push @matchpat, @{$args[$i + 1]} if $args[$i] eq 'match_list' && ref($args[$i + 1]) eq "ARRAY";
  0         0  
575 0 0       0 $timeout = $args[$i + 1] if $args[$i] eq 'timeout';
576 0 0       0 $blocking = $args[$i + 1] if $args[$i] eq 'blocking';
577 0 0       0 $returnRef = $args[$i + 1] if $args[$i] eq 'return_reference';
578 0 0       0 $errmode = parse_errmode($pkgsub, $args[$i + 1]) if $args[$i] eq 'errmode';
579 0 0       0 $pollSyntax = $args[$i + 1] if $args[$i] eq 'poll_syntax';
580             }
581             }
582 0         0 my @matchArray = grep {defined} @matchpat; # Weed out undefined values, if any
  0         0  
583              
584             # Initialize the base POLL structure
585 0         0 $self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
586             $pkgsub,
587             __PACKAGE__->can('waitfor_poll'),
588             $blocking,
589             $timeout,
590             $errmode,
591             3,
592             undef, # This is set below
593             $returnRef,
594             undef, # n/a
595             );
596 0         0 my $waitfor = $self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
597             # Set method argument keys
598             matchpat => \@matchArray,
599             # Declare method storage keys which will be used
600             stage => 0,
601             matchpat_qr => undef,
602             };
603 0   0     0 $self->{POLL}{output_requested} = !$pollSyntax || wantarray; # Always true in legacy syntax and in poll_syntax if wantarray
604 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
605 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
606              
607 0         0 my ($ok, $prematch, $match) = __PACKAGE__->can('poll_waitfor')->($self, $pkgsub); # Do not call a sub-classed version
608             # We have an old and new syntax
609 0 0       0 if ($pollSyntax) { # New syntax
610 0 0       0 return wantarray ? ($ok, $prematch, $match) : $ok;
611             }
612             else { # Old syntax
613 0 0       0 return wantarray ? ($prematch, $match) : $prematch;
614             }
615             }
616              
617              
618             sub waitfor_poll { # Poll status of waitfor (non-blocking mode)
619 0     0 1 0 my $pkgsub = "${Package}::waitfor_poll";
620 0         0 my $self = shift;
621 0 0       0 carp "$pkgsub: No arguments expected" if @_; # No arguments expected
622              
623 0 0 0     0 unless (defined $self->{POLL} && $self->{POLL}{coderef} == __PACKAGE__->can('waitfor_poll')) {
624 0         0 return $self->error("$pkgsub: Method waitfor() needs to be called first with blocking false");
625             }
626 0         0 $self->{POLL}{output_requested} = wantarray; # This might change at every call
627 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
628 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
629              
630             # If already completed (1) or we got an error (undef) from previous call (errmsg is already set) then we go no further
631 0 0 0     0 return $self->poll_return($self->{POLL}{complete}) unless defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0;
632              
633             # We get here only if we are not complete: $self->{POLL}{complete} == 0
634 0         0 return __PACKAGE__->can('poll_waitfor')->($self, $pkgsub); # Do not call a sub-classed version
635             }
636              
637              
638             sub put { # Send character strings to host (no \n appended)
639 0     0 1 0 my $pkgsub = "${Package}::put";
640 0         0 my $self = shift;
641 0         0 my %args;
642 0 0       0 if (@_ == 1) { # Method invoked with just the command argument
643 0         0 $args{string} = shift;
644             }
645             else {
646 0         0 my @validArgs = ('string', 'binmode', 'errmode');
647 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
648             }
649 0 0       0 return 1 unless defined $args{string};
650 0 0       0 my $binmode = defined $args{binmode} ? $args{binmode} : $self->{binmode};
651 0 0       0 my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef;
652 0 0       0 local $self->{binmode} = $binmode if defined $binmode;
653 0 0       0 local $self->{errmode} = $errmode if defined $errmode;
654              
655 0         0 return $self->_put($pkgsub, \$args{string});
656             }
657              
658              
659             sub print { # Send CLI commands to host (\n appended)
660 0     0 1 0 my $pkgsub = "${Package}::print";
661 0         0 my $self = shift;
662 0         0 my %args;
663 0 0       0 if (@_ == 1) { # Method invoked with just the command argument
664 0         0 $args{line} = shift;
665             }
666             else {
667 0         0 my @validArgs = ('line', 'binmode', 'errmode');
668 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
669             }
670 0 0       0 my $binmode = defined $args{binmode} ? $args{binmode} : $self->{binmode};
671 0 0       0 my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef;
672 0 0       0 local $self->{binmode} = $binmode if defined $binmode;
673 0 0       0 local $self->{errmode} = $errmode if defined $errmode;
674 0         0 $args{line} .= $self->{ors};
675              
676 0         0 return $self->_put($pkgsub, \$args{line});
677             }
678              
679              
680             sub printlist { # Send multiple lines to host switch (\n appended)
681 0     0 1 0 my $pkgsub = "${Package}::printlist";
682 0         0 my $self = shift;
683 0         0 my $output = join($self->{ors}, @_) . $self->{ors};
684              
685 0         0 return $self->_put($pkgsub, \$output);
686             }
687              
688              
689             sub login { # Handles basic username/password login for Telnet/Serial login and locks onto 1st prompt
690 0     0 1 0 my $pkgsub = "${Package}::login";
691 0         0 my $self =shift;
692 0         0 my @validArgs = ('username', 'password', 'prompt_credentials', 'prompt', 'username_prompt', 'password_prompt',
693             'timeout', 'errmode', 'return_reference', 'blocking');
694 0         0 my %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
695              
696             # Initialize the base POLL structure
697             $self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
698             $pkgsub,
699             __PACKAGE__->can('login_poll'),
700             defined $args{blocking} ? $args{blocking} : $self->{blocking},
701             defined $args{timeout} ? $args{timeout} : $self->{timeout},
702             defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef,
703             1,
704             wantarray,
705             defined $args{return_reference} ? $args{return_reference} : $self->{return_reference},
706             undef, # n/a
707 0 0       0 );
    0          
    0          
    0          
708             $self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
709             # Set method argument keys
710             username => $args{username},
711             password => $args{password},
712             prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
713             prompt => defined $args{prompt} ? $args{prompt} : $self->{prompt_qr},
714             username_prompt => defined $args{username_prompt} ? $args{username_prompt} : $self->{username_prompt_qr},
715             password_prompt => defined $args{password_prompt} ? $args{password_prompt} : $self->{password_prompt_qr},
716             # Declare method storage keys which will be used
717 0 0       0 stage => 0,
    0          
    0          
    0          
718             login_attempted => undef,
719             };
720 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
721 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
722 0         0 return __PACKAGE__->can('poll_login')->($self, $pkgsub); # Do not call a sub-classed version
723             }
724              
725              
726             sub login_poll { # Poll status of login (non-blocking mode)
727 0     0 1 0 my $pkgsub = "${Package}::login_poll";
728 0         0 my $self = shift;
729 0 0       0 carp "$pkgsub: No arguments expected" if @_; # No arguments expected
730              
731 0 0 0     0 unless (defined $self->{POLL} && $self->{POLL}{coderef} == __PACKAGE__->can('login_poll')) {
732 0         0 return $self->error("$pkgsub: Method login() needs to be called first with blocking false");
733             }
734 0         0 $self->{POLL}{output_requested} = wantarray; # This might change at every call
735 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
736 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
737              
738             # If already completed (1) or we got an error (undef) from previous call (errmsg is already set) then we go no further
739 0 0 0     0 return $self->poll_return($self->{POLL}{complete}) unless defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0;
740              
741             # We get here only if we are not complete: $self->{POLL}{complete} == 0
742 0         0 return __PACKAGE__->can('poll_login')->($self, $pkgsub); # Do not call a sub-classed version
743             }
744              
745              
746             sub cmd { # Sends a CLI command to host and returns output
747 0     0 1 0 my $pkgsub = "${Package}::cmd";
748 0         0 my $self = shift;
749 0         0 my %args;
750 0 0       0 if (@_ == 1) { # Method invoked with just the command argument
751 0         0 $args{command} = shift;
752             }
753             else {
754 0         0 my @validArgs = ('command', 'prompt', 'timeout', 'errmode', 'return_reference', 'blocking', 'poll_syntax');
755 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
756             }
757 0 0       0 $args{command} = '' unless defined $args{command};
758              
759             # Initialize the base POLL structure
760             $self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
761             $pkgsub,
762             __PACKAGE__->can('cmd_poll'),
763             defined $args{blocking} ? $args{blocking} : $self->{blocking},
764             defined $args{timeout} ? $args{timeout} : $self->{timeout},
765             defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef,
766             1,
767             undef, # This is set below
768             defined $args{return_reference} ? $args{return_reference} : $self->{return_reference},
769             undef, # n/a
770 0 0       0 );
    0          
    0          
    0          
771             my $cmd = $self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
772             # Set method argument keys
773             command => $args{command},
774             prompt => defined $args{prompt} ? $args{prompt} : $self->{prompt_qr},
775             # Declare method storage keys which will be used
776 0 0       0 stage => 0,
777             cmdEchoRemoved => 0,
778             };
779 0   0     0 $self->{POLL}{output_requested} = !$args{poll_syntax} || wantarray; # Always true in legacy syntax and in poll_syntax if wantarray
780 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
781 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
782              
783 0         0 my ($ok, $output) = __PACKAGE__->can('poll_cmd')->($self, $pkgsub); # Do not call a sub-classed version
784             # We have a different syntax for scalar output in blocking and non-blocking modes
785 0 0       0 if ($args{poll_syntax}) { # New syntax
786 0 0       0 return wantarray ? ($ok, $output) : $ok;
787             }
788             else { # Old syntax
789 0 0       0 return wantarray ? ($ok, $output) : $output;
790             }
791             }
792              
793              
794             sub cmd_poll { # Poll status of cmd (non-blocking mode)
795 0     0 1 0 my $pkgsub = "${Package}::cmd_poll";
796 0         0 my $self = shift;
797 0 0       0 carp "$pkgsub: No arguments expected" if @_; # No arguments expected
798              
799 0 0 0     0 unless (defined $self->{POLL} && $self->{POLL}{coderef} == __PACKAGE__->can('cmd_poll')) {
800 0         0 return $self->error("$pkgsub: Method cmd() needs to be called first with blocking false");
801             }
802 0         0 $self->{POLL}{output_requested} = wantarray; # This might change at every call
803 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
804 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
805              
806             # If already completed (1) or we got an error (undef) from previous call (errmsg is already set) then we go no further
807 0 0 0     0 return $self->poll_return($self->{POLL}{complete}) unless defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0;
808              
809             # We get here only if we are not complete: $self->{POLL}{complete} == 0
810 0         0 return __PACKAGE__->can('poll_cmd')->($self, $pkgsub); # Do not call a sub-classed version
811             }
812              
813              
814             sub change_baudrate { # Change baud rate of active SERIAL connection
815 0     0 1 0 my $pkgsub = "${Package}::change_baudrate";
816 0         0 my $self = shift;
817 0         0 my %args;
818 0 0       0 if (@_ == 1) { # Method invoked with just the command argument
819 0         0 $args{baudrate} = shift;
820             }
821             else {
822 0         0 my @validArgs = ('baudrate', 'parity', 'databits', 'stopbits', 'handshake', 'blocking', 'errmode', 'forcebaud');
823 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
824             }
825              
826             # Initialize the base POLL structure
827             $self->poll_struct( # $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList
828             $pkgsub,
829             __PACKAGE__->can('change_baudrate_poll'),
830             defined $args{blocking} ? $args{blocking} : $self->{blocking},
831             undef,
832 0 0       0 defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : undef,
    0          
833             0, # n/a
834             undef, # n/a
835             undef, # n/a
836             undef, # n/a
837             );
838             $self->{POLL}{$pkgsub} = { # Populate structure with method arguments/storage
839             # Set method argument keys
840             baudrate => defined $args{baudrate} ? $args{baudrate} : $self->{BAUDRATE},
841             parity => defined $args{parity} ? $args{parity} : $self->{PARITY},
842             databits => defined $args{databits} ? $args{databits} : $self->{DATABITS},
843             stopbits => defined $args{stopbits} ? $args{stopbits} : $self->{STOPBITS},
844             handshake => defined $args{handshake} ? $args{handshake} : $self->{HANDSHAKE},
845             forcebaud => $args{forcebaud},
846             # Declare method storage keys which will be used
847 0 0       0 stage => 0,
    0          
    0          
    0          
    0          
848             };
849 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
850 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
851 0         0 return __PACKAGE__->can('poll_change_baudrate')->($self, $pkgsub); # Do not call a sub-classed version
852             }
853              
854              
855             sub change_baudrate_poll { # Poll status of change_baudrate (non-blocking mode)
856 0     0 1 0 my $pkgsub = "${Package}::change_baudrate_poll";
857 0         0 my $self = shift;
858 0 0       0 carp "$pkgsub: No arguments expected" if @_; # No arguments expected
859              
860 0 0 0     0 unless (defined $self->{POLL} && $self->{POLL}{coderef} == __PACKAGE__->can('change_baudrate_poll')) {
861 0         0 return $self->error("$pkgsub: Method change_baudrate() needs to be called first with blocking false");
862             }
863 0         0 local $self->{POLLING} = 1; # True until we come out of this polling-capable method
864 0 0       0 local $self->{errmode} = $self->{POLL}{errmode} if defined $self->{POLL}{errmode};
865              
866             # If already completed (1) or we got an error (undef) from previous call (errmsg is already set) then we go no further
867 0 0 0     0 return $self->poll_return($self->{POLL}{complete}) unless defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0;
868              
869             # We get here only if we are not complete: $self->{POLL}{complete} == 0
870 0         0 return __PACKAGE__->can('poll_change_baudrate')->($self, $pkgsub); # Do not call a sub-classed version
871             }
872              
873              
874             sub input_log { # Log to file all input sent to host
875 0     0 1 0 my $pkgsub = "${Package}::input_log";
876 0         0 my ($self, $fh) = @_;
877              
878 0 0       0 unless (defined $fh) { # No input = return current filehandle
879 0         0 return $self->{INPUTLOGFH};
880             }
881 0 0 0     0 unless (ref $fh or length $fh) { # Empty input = stop logging
882 0         0 $self->{INPUTLOGFH} = undef;
883 0         0 return;
884             }
885 0 0 0     0 if (!ref($fh) && !defined(fileno $fh)) { # Open a new filehandle if input is a filename
886 0         0 my $logfile = $fh;
887 0         0 $fh = IO::Handle->new;
888 0 0       0 open($fh, '>', "$logfile") or return $self->error("$pkgsub: Unable to open input log file: $!");
889             }
890 0         0 $fh->autoflush();
891 0         0 $self->{INPUTLOGFH} = $fh;
892 0         0 return $fh;
893             }
894              
895              
896             sub output_log { # Log to file all output received from host
897 0     0 1 0 my $pkgsub = "${Package}::output_log";
898 0         0 my ($self, $fh) = @_;
899              
900 0 0       0 unless (defined $fh) { # No input = return current filehandle
901 0         0 return $self->{OUTPUTLOGFH};
902             }
903 0 0 0     0 unless (ref $fh or length $fh) { # Empty input = stop logging
904 0         0 $self->{OUTPUTLOGFH} = undef;
905 0         0 return;
906             }
907 0 0 0     0 if (!ref($fh) && !defined(fileno $fh)) { # Open a new filehandle if input is a filename
908 0         0 my $logfile = $fh;
909 0         0 $fh = IO::Handle->new;
910 0 0       0 open($fh, '>', "$logfile") or return $self->error("$pkgsub: Unable to open output log file: $!");
911             }
912 0         0 $fh->autoflush();
913 0         0 $self->{OUTPUTLOGFH} = $fh;
914 0         0 return $fh;
915             }
916              
917              
918             sub dump_log { # Log hex and ascii for both input & output
919 0     0 1 0 my $pkgsub = "${Package}::dump_log";
920 0         0 my ($self, $fh) = @_;
921              
922 0 0       0 unless (defined $fh) { # No input = return current filehandle
923 0         0 return $self->{DUMPLOGFH};
924             }
925 0 0 0     0 unless (ref $fh or length $fh) { # Empty input = stop logging
926 0         0 $self->{DUMPLOGFH} = undef;
927 0         0 return;
928             }
929 0 0 0     0 if (!ref($fh) && !defined(fileno $fh)) { # Open a new filehandle if input is a filename
930 0         0 my $logfile = $fh;
931 0         0 $fh = IO::Handle->new;
932 0 0       0 open($fh, '>', "$logfile") or return $self->error("$pkgsub: Unable to open dump log file: $!");
933             }
934 0         0 $fh->autoflush();
935 0         0 $self->{DUMPLOGFH} = $fh;
936 0         0 return $fh;
937             }
938              
939              
940             sub eof { # End-Of-File indicator
941 0     0 1 0 my $pkgsub = "${Package}::eof";
942 0         0 my $self = shift;
943              
944 0 0       0 if ($self->{TYPE} eq 'TELNET') {
    0          
    0          
945             # Re-format Net::Telnet's own method to return 0 or 1
946 0 0       0 return $self->{PARENT}->eof ? 1 : 0;
947             }
948             elsif ($self->{TYPE} eq 'SSH') {
949             # Make SSH behave as Net::Telnet; return 1 if object created but not yet connected
950 0 0 0     0 return 1 if defined $self->{PARENT} && !defined $self->{SSHCHANNEL};
951             # Return Net::SSH2's own method if it is true (but it never is & seems not to work...)
952 0 0       0 return 1 if $self->{SSHCHANNEL}->eof;
953             # So we fudge it by checking Net::SSH2's last error code..
954 0         0 my $sshError = $self->{PARENT}->error; # Minimize calls to Net::SSH2 error method, as it leaks in version 0.58
955             # Libssh2 error codes: https://github.com/libssh2/libssh2/blob/master/include/libssh2.h
956 0 0       0 return 1 if $sshError == -1; # LIBSSH2_ERROR_SOCKET_NONE
957 0 0       0 return 1 if $sshError == -13; # LIBSSH2_ERROR_SOCKET_DISCONNECT
958 0 0       0 return 1 if $sshError == -43; # LIBSSH2_ERROR_SOCKET_RECV
959 0         0 return 0; # If we get here, return 0
960             }
961             elsif ($self->{TYPE} eq 'SERIAL') {
962 0         0 return $self->{SERIALEOF};
963             }
964             else {
965 0         0 return $self->error("$pkgsub: Invalid connection mode");
966             }
967 0         0 return 1;
968             }
969              
970              
971             sub break { # Send the break signal
972 0     0 1 0 my $pkgsub = "${Package}::break";
973 0         0 my $self = shift;
974 0   0     0 my $comBreakDuration = shift || $ComBreakDuration;
975              
976 0 0       0 return $self->error("$pkgsub: No connection to write to") if $self->eof;
977              
978 0 0       0 if ($self->{TYPE} eq 'TELNET') {
    0          
    0          
979             # Simply use Net::Telnet's implementation
980             $self->{PARENT}->break
981 0 0       0 or return $self->error("$pkgsub: Unable to send telnet break signal");
982             }
983             elsif ($self->{TYPE} eq 'SSH') {
984             # For SSH we just send '~B' and hope that the other end will interpret it as a break
985 0 0       0 $self->put(string => '~B', errmode => 'return')
986             or return $self->error("$pkgsub: Unable to send SSH break signal // ".$self->errmsg);
987             }
988             elsif ($self->{TYPE} eq 'SERIAL') {
989 0         0 $self->{PARENT}->pulse_break_on($comBreakDuration);
990             }
991             else {
992 0         0 return $self->error("$pkgsub: Invalid connection mode");
993             }
994 0         0 return 1;
995             }
996              
997              
998             sub disconnect { # Disconnect from host
999 0     0 1 0 my $pkgsub = "${Package}::disconnect";
1000 0         0 my $self = shift;
1001 0         0 my %args;
1002 0 0       0 if (@_ == 1) { # Method invoked with just the command argument
1003 0         0 $args{close_logs} = shift;
1004             }
1005             else {
1006 0         0 my @validArgs = ('close_logs');
1007 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
1008             }
1009              
1010 0 0       0 if ($self->{TYPE} eq 'TELNET') {
    0          
    0          
1011 0 0       0 $self->{PARENT}->close if defined $self->{PARENT};
1012 0         0 $self->{HOST} = $self->{TCPPORT} = undef;
1013 0 0       0 close $self->{SOCKET} if defined $self->{SOCKET};
1014 0         0 $self->{SOCKET} = undef;
1015             }
1016             elsif ($self->{TYPE} eq 'SSH') {
1017 0 0       0 $self->{SSHCHANNEL}->close if defined $self->{SSHCHANNEL};
1018 0         0 $self->{SSHCHANNEL} = $self->{SSHAUTH} = undef;
1019 0 0       0 $self->{PARENT}->disconnect() if defined $self->{PARENT};
1020 0         0 $self->{HOST} = $self->{TCPPORT} = undef;
1021 0 0       0 close $self->{SOCKET} if defined $self->{SOCKET};
1022 0         0 $self->{SOCKET} = undef;
1023             }
1024             elsif ($self->{TYPE} eq 'SERIAL') {
1025 0 0 0     0 if (defined $self->{PARENT} && !$self->{SERIALEOF}) {
1026             # Needed to flush writes before closing with Device::SerialPort (do once only)
1027 0 0       0 $self->{PARENT}->write_done(1) if defined $self->{BAUDRATE};
1028 0         0 $self->{PARENT}->close;
1029             }
1030 0         0 $self->{HANDSHAKE} = undef;
1031 0         0 $self->{BAUDRATE} = undef;
1032 0         0 $self->{PARITY} = undef;
1033 0         0 $self->{DATABITS} = undef;
1034 0         0 $self->{STOPBITS} = undef;
1035 0         0 $self->{SERIALEOF} = 1;
1036             }
1037             else {
1038 0         0 return $self->error("$pkgsub: Invalid connection mode");
1039             }
1040 0 0       0 if ($args{close_logs}) {
1041 0 0       0 if (defined $self->input_log) {
1042 0         0 close $self->input_log;
1043 0         0 $self->input_log('');
1044             }
1045 0 0       0 if (defined $self->output_log) {
1046 0         0 close $self->output_log;
1047 0         0 $self->output_log('');
1048             }
1049 0 0       0 if (defined $self->dump_log) {
1050 0         0 close $self->dump_log;
1051 0         0 $self->dump_log('');
1052             }
1053 0 0 0     0 if ($self->{TYPE} eq 'TELNET' && defined $self->parent->option_log) {
1054 0         0 close $self->parent->option_log;
1055 0         0 $self->parent->option_log('');
1056             }
1057             }
1058 0         0 return 1;
1059             }
1060              
1061              
1062             sub close { # Same as disconnect
1063 0     0 1 0 my $self = shift;
1064 0         0 return $self->disconnect(@_);
1065             }
1066              
1067              
1068             sub error { # Handle errors according to the object's error mode
1069 0     0 1 0 my $self = shift;
1070 0   0     0 my $errmsg = shift || '';
1071 0         0 my (undef, $fileName, $lineNumber) = caller; # Needed in case of die
1072              
1073 0         0 $self->errmsg($errmsg);
1074 0         0 return _error($fileName, $lineNumber, $self->{errmode}, $errmsg, $self->{errmsg_format});
1075             }
1076              
1077              
1078             sub poll { # Poll objects for completion
1079 0     0 1 0 my $pkgsub = "${Package}::poll";
1080 0         0 my ($self, %args);
1081 0         0 my ($running, $completed, $failed);
1082 0         0 my (@lastCompleted, @lastFailed);
1083 0         0 my $objComplete = $Default{poll_obj_complete};
1084 0         0 my $objError = $Default{poll_obj_error};
1085 0         0 my $pollTimer = $PollTimer/1000; # Convert to secs
1086 0         0 my ($mainLoopSleep, $mainLoopTime, $pollStartTime, $pollActHost, $objLastPollTime);
1087              
1088 0 0       0 if ($_[0]->isa($Package)) { # Method invoked as object method
    0          
1089 0         0 $self = shift;
1090 0         0 my @validArgs = ('poll_code', 'poll_timer', 'errmode');
1091 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
1092             }
1093             elsif (ref $_[0]) { # Method invoked with single argument array or hash ref
1094 0         0 $args{object_list} = shift;
1095             }
1096             else {
1097 0         0 my @validArgs = ('object_list', 'poll_code', 'object_complete', 'object_error', 'poll_timer', 'errmode', 'errmsg_format');
1098 0         0 %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
1099             }
1100 0 0       0 if (defined $args{object_complete}) {
1101 0 0       0 if ($args{object_complete} =~ /^all|next$/i) {
1102 0         0 $objComplete = lc $args{object_complete};
1103             }
1104             else {
1105 0         0 carp "$pkgsub: Invalid value for 'object_complete' argument; ignoring";
1106             }
1107             }
1108 0 0       0 if (defined $args{object_error}) {
1109 0 0       0 if ($args{object_error} =~ /^return|ignore$/i) {
1110 0         0 $objError = lc $args{object_error};
1111             }
1112             else {
1113 0         0 carp "$pkgsub: Invalid value for 'object_error' argument; ignoring";
1114             }
1115             }
1116 0 0       0 if (defined $args{poll_timer}) {
1117 0 0       0 if ($args{poll_timer} =~ /\d+/) {
1118 0         0 $pollTimer = $args{poll_timer}/1000; # Convert to secs
1119             }
1120             else {
1121 0         0 carp "$pkgsub: Invalid value for 'poll_timer' argument; ignoring";
1122             }
1123             }
1124 0 0       0 if (defined $args{poll_code}) {
1125 0 0       0 unless (validCodeRef($args{poll_code})) {
1126 0         0 $args{poll_code} = undef; # Only keep the argument if valid
1127 0         0 carp "$pkgsub: Argument 'poll_code' is not a valid code ref; ignoring";
1128             }
1129             }
1130 0 0       0 my $errmode = defined $args{errmode} ? parse_errmode($pkgsub, $args{errmode}) : ( defined $self ? $self->{errmode} : $Default{errmode} );
    0          
1131 0 0       0 my $msgFormat = defined $args{errmsg_format} ? $args{errmsg_format} : ( defined $self ? $self->{errmsg_format} : $Default{errmsg_format} );
    0          
1132 0 0 0     0 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: No 'object_list' provided", $msgFormat) unless defined $self || defined $args{object_list};
1133              
1134 0         0 $pollStartTime = time;
1135 0         0 while (1) {
1136 0         0 $mainLoopTime = time; # Record time before going over loop below
1137 0         0 ($running, $completed, $failed) = (0,0,0);
1138            
1139 0 0       0 if ( defined $self ) { # Called in object oriented form; single object
    0          
    0          
1140 0 0       0 unless (defined $self->{POLL}) { # No poll structure exists, throw an error
1141 0 0       0 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: No polling method was ever called for object", $msgFormat) if defined $args{errmode};
1142 0         0 return $self->error("$pkgsub: No polling method was ever called for object");
1143             }
1144 0 0       0 my $ok = _call_poll_method($self, 0, defined $args{errmode} ? $errmode : undef);
1145             # Return if completed or failed
1146 0 0 0     0 return $ok if $ok || !defined $ok;
1147 0         0 $running = 1; # Ensures we always loop below
1148             }
1149             elsif ( ref $args{object_list} eq 'ARRAY' ) { # Called in non-objectoriented form; list as arg
1150 0         0 for my $i ( 0 .. $#{$args{object_list}} ) {
  0         0  
1151 0         0 my $obj = ${$args{object_list}}[$i];
  0         0  
1152 0 0       0 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Array element $i is not a valid object", $msgFormat) unless $obj->isa($Package);
1153 0 0       0 unless (defined $obj->{POLL}) { # No poll structure exists, throw an error
1154 0 0       0 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: No polling method was ever called for object array element $i", $msgFormat) if defined $args{errmode};
1155 0         0 return $obj->error("$pkgsub: No polling method was ever called for object array element $i");
1156             }
1157 0         0 my $objStartTime = time;
1158 0 0       0 my $objTimeCredit = $objStartTime - (defined $objLastPollTime->[$i] ? $objLastPollTime->[$i] : $pollStartTime) - $pollTimer;
1159 0 0       0 my $ok = _call_poll_method($obj, $objTimeCredit, defined $args{errmode} ? $errmode : undef);
1160 0 0       0 if ($ok) {
    0          
1161 0         0 $completed++;
1162 0 0       0 unless ($obj->{POLLREPORTED}) {
1163 0         0 push (@lastCompleted, $i);
1164 0         0 $obj->{POLLREPORTED} = 1;
1165             }
1166             }
1167             elsif (!defined $ok) {
1168 0         0 $failed++;
1169 0 0       0 unless ($obj->{POLLREPORTED}) {
1170 0         0 push (@lastFailed, $i);
1171 0         0 $obj->{POLLREPORTED} = 1;
1172             }
1173             }
1174 0         0 else { $running++ }
1175 0         0 $objLastPollTime->[$i] = time;
1176 0 0 0     0 if ( ($objLastPollTime->[$i] - $objStartTime) > $pollTimer && $args{poll_code}) { # On slow poll methods, call activity between every host
1177 0         0 callCodeRef($args{poll_code}, $running, $completed, $failed, \@lastCompleted, \@lastFailed);
1178 0         0 $pollActHost = 1; # Make sure we don't run activity at end of cycle then
1179             }
1180             else {
1181 0         0 $pollActHost = 0; # Make sure we run activity at end of cycle
1182             }
1183             }
1184             }
1185             elsif ( ref $args{object_list} eq 'HASH' ) { # Called in non-objectoriented form; hash as arg
1186 0         0 foreach my $key ( keys %{$args{object_list}} ) {
  0         0  
1187 0         0 my $obj = ${$args{object_list}}{$key};
  0         0  
1188 0 0       0 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: Hash key $key is not a valid object", $msgFormat) unless $obj->isa($Package);
1189 0 0       0 unless (defined $obj->{POLL}) { # No poll structure exists, throw an error
1190 0 0       0 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: No polling method was ever called for object hash key $key", $msgFormat) if defined $args{errmode};
1191 0         0 return $obj->error("$pkgsub: No polling method was ever called for object hash key $key");
1192             }
1193 0         0 my $objStartTime = time;
1194 0 0       0 my $objTimeCredit = $objStartTime - (defined $objLastPollTime->{$key} ? $objLastPollTime->{$key} : $pollStartTime) - $pollTimer;
1195 0 0       0 my $ok = _call_poll_method($obj, $objTimeCredit, defined $args{errmode} ? $errmode : undef);
1196 0 0       0 if ($ok) {
    0          
1197 0         0 $completed++;
1198 0 0       0 unless ($obj->{POLLREPORTED}) {
1199 0         0 push (@lastCompleted, $key);
1200 0         0 $obj->{POLLREPORTED} = 1;
1201             }
1202             }
1203             elsif (!defined $ok) {
1204 0         0 $failed++;
1205 0 0       0 unless ($obj->{POLLREPORTED}) {
1206 0         0 push (@lastFailed, $key);
1207 0         0 $obj->{POLLREPORTED} = 1;
1208             }
1209             }
1210 0         0 else { $running++ }
1211 0         0 $objLastPollTime->{$key} = time;
1212 0 0 0     0 if ( ($objLastPollTime->{$key} - $objStartTime) > $pollTimer && $args{poll_code}) { # On slow poll methods, call activity between every host
1213 0         0 callCodeRef($args{poll_code}, $running, $completed, $failed, \@lastCompleted, \@lastFailed);
1214 0         0 $pollActHost = 1; # Make sure we don't run activity at end of cycle then
1215             }
1216             else {
1217 0         0 $pollActHost = 0; # Make sure we run activity at end of cycle
1218             }
1219             }
1220             }
1221             else {
1222 0         0 return _error(__FILE__, __LINE__, $errmode, "$pkgsub: 'object_list' is not a hash or array reference", $msgFormat);
1223             }
1224              
1225             # Check if we are done, before calling pollcode or doing cycle wait
1226 0 0 0     0 last if ($running == 0) || ($objComplete eq 'next' && @lastCompleted) || ($objError eq 'return' && @lastFailed);
      0        
      0        
      0        
1227              
1228 0 0 0     0 if ($args{poll_code} && !$pollActHost) { # If a valid activity coderef was supplied and we did not just perform this on last object..
1229 0         0 callCodeRef($args{poll_code}, $running, $completed, $failed, \@lastCompleted, \@lastFailed);
1230             }
1231 0         0 $pollActHost = 0; # Reset flag
1232 0         0 $mainLoopSleep = $pollTimer - (time - $mainLoopTime); # Timer less time it took to run through loop
1233 0 0       0 sleep($mainLoopSleep) if $mainLoopSleep > 0; # Only if positive
1234             }
1235              
1236 0 0       0 return $running unless wantarray;
1237 0         0 return ($running, $completed, $failed, \@lastCompleted, \@lastFailed);
1238             }
1239              
1240              
1241             #################################### Methods to set/read Object variables ####################################
1242              
1243             sub timeout { # Set/read timeout
1244 0     0 1 0 my ($self, $newSetting) = @_;
1245 0         0 my $currentSetting = $self->{timeout};
1246 0 0       0 if (defined $newSetting) {
1247 0         0 $self->{timeout} = $newSetting;
1248 0 0       0 if ($self->{TYPE} eq 'TELNET') {
1249 0         0 $self->{PARENT}->timeout($newSetting);
1250             }
1251             }
1252 0         0 return $currentSetting;
1253             }
1254              
1255              
1256             sub connection_timeout { # Set/read connection timeout
1257 0     0 1 0 my ($self, $newSetting) = @_;
1258 0         0 my $currentSetting = $self->{connection_timeout};
1259 0         0 $self->{connection_timeout} = $newSetting;
1260 0         0 return $currentSetting;
1261             }
1262              
1263              
1264             sub read_block_size { # Set/read read_block_size for either SSH or SERIAL (not applicable to TELNET)
1265 0     0 1 0 my ($self, $newSetting) = @_;
1266 0         0 my $currentSetting = $self->{read_block_size};
1267 0 0       0 $self->{read_block_size} = $newSetting if defined $newSetting;
1268 0         0 return $currentSetting;
1269             }
1270              
1271              
1272             sub blocking { # Set/read blocking/unblocking mode for reading connection and polling methods
1273 0     0 1 0 my ($self, $newSetting) = @_;
1274 0         0 my $currentSetting = $self->{blocking};
1275 0 0       0 $self->{blocking} = $newSetting if defined $newSetting;
1276 0         0 return $currentSetting;
1277             }
1278              
1279              
1280             sub read_attempts { # Set/read number of read attempts in readwait()
1281 0     0 1 0 my ($self, $newSetting) = @_;
1282 0         0 my $currentSetting = $self->{read_attempts};
1283 0 0       0 $self->{read_attempts} = $newSetting if defined $newSetting;
1284 0         0 return $currentSetting;
1285             }
1286              
1287              
1288             sub readwait_timer { # Set/read poll timer in readwait()
1289 0     0 1 0 my ($self, $newSetting) = @_;
1290 0         0 my $currentSetting = $self->{readwait_timer};
1291 0 0       0 $self->{readwait_timer} = $newSetting if defined $newSetting;
1292 0         0 return $currentSetting;
1293             }
1294              
1295              
1296             sub data_with_error { # Set/read behaviour flag for readwait() when some data read followed by a read error
1297 0     0 1 0 my ($self, $newSetting) = @_;
1298 0         0 my $currentSetting = $self->{data_with_error};
1299 0 0       0 $self->{data_with_error} = $newSetting if defined $newSetting;
1300 0         0 return $currentSetting;
1301             }
1302              
1303              
1304             sub return_reference { # Set/read return_reference mode
1305 0     0 1 0 my ($self, $newSetting) = @_;
1306 0         0 my $currentSetting = $self->{return_reference};
1307 0 0       0 $self->{return_reference} = $newSetting if defined $newSetting;
1308 0         0 return $currentSetting;
1309             }
1310              
1311              
1312             sub output_record_separator { # Set/read the Output Record Separator automaticaly appended by print() and cmd()
1313 0     0 1 0 my ($self, $newSetting) = @_;
1314 0         0 my $currentSetting = $self->{ors};
1315 0 0       0 if (defined $newSetting) {
1316 0         0 $self->{ors} = $newSetting;
1317 0 0       0 $self->{TELNETMODE} = $newSetting eq "\r" ? 0 : 1;
1318             }
1319 0         0 return $currentSetting;
1320             }
1321              
1322              
1323             sub binmode { # Set/read bimode
1324 0     0 1 0 my ($self, $newSetting) = @_;
1325 0         0 my $currentSetting = $self->{binmode};
1326 0 0       0 $self->{binmode} = $newSetting if defined $newSetting;
1327 0         0 return $currentSetting;
1328             }
1329              
1330              
1331             sub prompt_credentials { # Set/read prompt_credentials mode
1332 0     0 1 0 my $pkgsub = "${Package}::prompt_credentials";
1333 0         0 my ($self, $newSetting) = @_;
1334 0         0 my $currentSetting = $self->{prompt_credentials};
1335 0 0       0 if (defined $newSetting) {
1336 0 0 0     0 if (ref($newSetting) && !validCodeRef($newSetting)) {
1337 0         0 carp "$pkgsub: First item of array ref must be a code ref";
1338             }
1339 0         0 $self->{prompt_credentials} = $newSetting;
1340             }
1341 0         0 return $currentSetting;
1342             }
1343              
1344              
1345             sub flush_credentials { # Clear the stored username, password, passphrases, if any
1346 0     0 1 0 my $self = shift;
1347 0         0 $self->{USERNAME} = $self->{PASSWORD} = $self->{PASSPHRASE} = undef;
1348 0         0 return 1;
1349             }
1350              
1351              
1352             sub prompt { # Read/Set object prompt
1353 0     0 1 0 my ($self, $newSetting) = @_;
1354 0         0 my $currentSetting = $self->{prompt};
1355 0 0       0 if (defined $newSetting) {
1356 0         0 $self->{prompt} = $newSetting;
1357 0         0 $self->{prompt_qr} = qr/$newSetting/;
1358             }
1359 0         0 return $currentSetting;
1360             }
1361              
1362              
1363             sub username_prompt { # Read/Set object username prompt
1364 0     0 1 0 my ($self, $newSetting) = @_;
1365 0         0 my $currentSetting = $self->{username_prompt};
1366 0 0       0 if (defined $newSetting) {
1367 0         0 $self->{username_prompt} = $newSetting;
1368 0         0 $self->{username_prompt_qr} = qr/$newSetting/;
1369             }
1370 0         0 return $currentSetting;
1371             }
1372              
1373              
1374             sub password_prompt { # Read/Set object password prompt
1375 0     0 1 0 my ($self, $newSetting) = @_;
1376 0         0 my $currentSetting = $self->{password_prompt};
1377 0 0       0 if (defined $newSetting) {
1378 0         0 $self->{password_prompt} = $newSetting;
1379 0         0 $self->{password_prompt_qr} = qr/$newSetting/;
1380             }
1381 0         0 return $currentSetting;
1382             }
1383              
1384              
1385             sub terminal_type { # Read/Set object terminal type
1386 0     0 1 0 my ($self, $newSetting) = @_;
1387 0         0 my $currentSetting = $self->{terminal_type};
1388 0 0       0 if (defined $newSetting) {
1389 0 0       0 $self->{terminal_type} = length $newSetting ? $newSetting : undef;
1390             }
1391 0         0 return $currentSetting;
1392             }
1393              
1394              
1395             sub window_size { # Read/Set object terminal window size
1396 0     0 1 0 my $pkgsub = "${Package}::window_size";
1397 0         0 my ($self, $width, $height) = @_;
1398 0         0 my @currentSetting = @{$self->{window_size}};
  0         0  
1399 0 0 0     0 if ((defined $width && !$width) || (defined $height && !$height)) { # Empty value undefines it
    0 0        
      0        
      0        
1400 0         0 $self->{window_size} = [];
1401             }
1402             elsif (defined $width && defined $height) {
1403 0 0 0     0 if ($width =~ /^\d+$/ && $height =~ /^\d+$/) {
1404 0         0 $self->{window_size} = [$width, $height];
1405             }
1406             else {
1407 0         0 carp "$pkgsub: Invalid window size; numeric width & height required";
1408             }
1409             }
1410 0         0 return @currentSetting;
1411             }
1412              
1413              
1414             sub report_query_status { # Enable/Disable ability to Reply Device OK ESC sequence to Query Device Status ESC sequence
1415 0     0 1 0 my ($self, $newSetting) = @_;
1416 0         0 my $currentSetting = $self->{report_query_status};
1417 0 0       0 $self->{report_query_status} = $newSetting if defined $newSetting;
1418 0         0 return $currentSetting;
1419             }
1420              
1421              
1422             sub errmode { # Set/read error mode
1423 1     1 1 4 my $pkgsub = "${Package}::errmode";
1424 1         20 my ($self, $newSetting) = @_;
1425 1         9 my $currentSetting = $self->{errmode};
1426 1 50 33     6 if ((defined $newSetting) && (my $newMode = parse_errmode($pkgsub, $newSetting))) {
1427 1         3 $self->{errmode} = $newMode;
1428             }
1429 1         3 return $currentSetting;
1430             }
1431              
1432              
1433             sub errmsg { # Set/read the last generated error message for the object
1434 0     0 1   my $pkgsub = "${Package}::errmsg";
1435 0           my $self = shift;
1436 0           my %args;
1437 0 0         if (@_ == 1) { # Method invoked with just the command argument
1438 0           $args{set_message} = shift;
1439             }
1440             else {
1441 0           my @validArgs = ('set_message', 'errmsg_format');
1442 0           %args = parseMethodArgs($pkgsub, \@_, \@validArgs);
1443             }
1444 0 0         my $msgFormat = defined $args{errmsg_format} ? $args{errmsg_format} : $self->{errmsg_format};
1445 0           my $errmsg = $self->{errmsg};
1446 0 0         $self->{errmsg} = $args{set_message} if defined $args{set_message};
1447 0           return _error_format($msgFormat, $errmsg);
1448             }
1449              
1450              
1451             sub errmsg_format { # Set/read the error message format
1452 0     0 1   my $pkgsub = "${Package}::errmsg_format";
1453 0           my ($self, $newSetting) = @_;
1454 0           my $currentSetting = $self->{errmsg_format};
1455              
1456 0 0         if (defined $newSetting) {
1457 0 0         if ($newSetting =~ /^\s*terse\s*$/i) { $newSetting = 'terse' }
  0 0          
    0          
1458 0           elsif ($newSetting =~ /^\s*verbose\s*$/i) { $newSetting = 'verbose' }
1459 0           elsif ($newSetting =~ /^\s*default\s*$/i) { $newSetting = 'default' }
1460             else {
1461 0           carp "$pkgsub: invalid format '$newSetting'; ignoring";
1462 0           $newSetting = undef;
1463             }
1464 0 0         $self->{errmsg_format} = $newSetting if defined $newSetting;
1465             }
1466 0           return $currentSetting;
1467             }
1468              
1469              
1470             sub debug { # Set/read debug level
1471 0     0 1   my ($self, $newSetting) = @_;
1472 0           my $currentSetting = $self->{debug};
1473 0 0 0       if (defined $newSetting && $newSetting != $currentSetting) {
1474 0           $self->{debug} = $newSetting;
1475 0 0         if ($self->{TYPE} eq 'SSH') {
    0          
1476 0 0         $self->{PARENT}->debug($newSetting & 2 ? 1 : 0);
1477             }
1478             elsif ($self->{TYPE} eq 'SERIAL') {
1479 0 0         if ($^O eq 'MSWin32') {
1480 0           Win32::SerialPort->set_test_mode_active(!($newSetting & 1));
1481 0 0         Win32::SerialPort::debug($newSetting & 2 ? 'ON' : 'OFF');
1482             }
1483             else {
1484 0           Device::SerialPort->set_test_mode_active(!($newSetting & 1));
1485 0 0         Device::SerialPort::debug($newSetting & 2 ? 'ON' : 'OFF');
1486             }
1487             }
1488             }
1489 0           return $currentSetting;
1490             }
1491              
1492              
1493             ################################# Methods to read read-only Object variables #################################
1494              
1495             sub parent { # Return the parent object
1496 0     0 1   my $self = shift;
1497 0           return $self->{PARENT};
1498             }
1499              
1500              
1501             sub socket { # Return the socket object
1502 0     0 1   my $self = shift;
1503 0           return $self->{SOCKET};
1504             }
1505              
1506              
1507             sub ssh_channel { # Return the SSH channel object
1508 0     0 1   my $self = shift;
1509 0           return $self->{SSHCHANNEL};
1510             }
1511              
1512              
1513             sub ssh_authentication { # Return the SSH authentication type performed
1514 0     0 1   my $self = shift;
1515 0           return $self->{SSHAUTH};
1516             }
1517              
1518              
1519             sub connection_type { # Return the connection type of this object
1520 0     0 1   my $self = shift;
1521 0           return $self->{TYPE};
1522             }
1523              
1524              
1525             sub host { # Return the host we connect to
1526 0     0 1   my $self = shift;
1527 0           return $self->{HOST};
1528             }
1529              
1530              
1531             sub port { # Return the TCP port / COM port for the connection
1532 0     0 1   my $self = shift;
1533 0 0         if ($self->{TYPE} eq 'SERIAL') {
1534 0           return $self->{COMPORT};
1535             }
1536             else {
1537 0           return $self->{TCPPORT};
1538             }
1539             }
1540              
1541              
1542             sub connected { # Returns true if a connection is in place
1543 0     0 1   my $self = shift;
1544 0           return !$self->eof;
1545             }
1546              
1547              
1548             sub last_prompt { # Return the last prompt obtained
1549 0     0 1   my $self = shift;
1550 0           return $self->{LASTPROMPT};
1551             }
1552              
1553              
1554             sub username { # Read the username; this might have been provided or prompted for by a method in this class
1555 0     0 1   my $self = shift;
1556 0           return $self->{USERNAME};
1557             }
1558              
1559              
1560             sub password { # Read the password; this might have been provided or prompted for by a method in this class
1561 0     0 1   my $self = shift;
1562 0           return $self->{PASSWORD};
1563             }
1564              
1565              
1566             sub passphrase { # Read the passphrase; this might have been provided or prompted for by a method in this class
1567 0     0 1   my $self = shift;
1568 0           return $self->{PASSPHRASE};
1569             }
1570              
1571              
1572             sub handshake { # Read the serial handshake used
1573 0     0 1   my $self = shift;
1574 0           return $self->{HANDSHAKE};
1575             }
1576              
1577              
1578             sub baudrate { # Read the serial baudrate used
1579 0     0 1   my $self = shift;
1580 0           return $self->{BAUDRATE};
1581             }
1582              
1583              
1584             sub parity { # Read the serial parity used
1585 0     0 1   my $self = shift;
1586 0           return $self->{PARITY};
1587             }
1588              
1589              
1590             sub databits { # Read the serial databits used
1591 0     0 1   my $self = shift;
1592 0           return $self->{DATABITS};
1593             }
1594              
1595              
1596             sub stopbits { # Read the serial stopbits used
1597 0     0 1   my $self = shift;
1598 0           return $self->{STOPBITS};
1599             }
1600              
1601              
1602             #################################### Methods for modules sub-classing Control::CLI ####################################
1603              
1604             sub poll_struct { # Initialize the poll hash structure for a new method using it
1605 0     0 1   my ($self, $methodName, $codeRef, $blocking, $timeout, $errmode, $outputType, $outputRequested, $returnReference, $returnList) = @_;
1606 0           my $pollsub = "${Package}::poll_struct";
1607              
1608 0 0 0       if (defined $self->{POLL} && defined $self->{POLL}{complete} && $self->{POLL}{complete} == 0 ) { # Sanity check
      0        
1609 0           my (undef, $fileName, $lineNumber) = caller;
1610 0           my $pollOwner = $self->{POLL}{method};
1611 0           carp "$pollsub (called from $fileName line $lineNumber) $methodName is trampling over existing poll structure of $pollOwner";
1612             }
1613              
1614             $self->{POLL} = { # Initialize the base POLL structure
1615 0           method => $methodName,
1616             coderef => $codeRef,
1617             cache => [],
1618             blocking => $blocking,
1619             timeout => $timeout,
1620             endtime => undef,
1621             waittime => undef,
1622             errmode => $errmode,
1623             complete => 0,
1624             return_reference => $returnReference,
1625             return_list => $returnList,
1626             output_requested => $outputRequested,
1627             output_type => $outputType,
1628             output_result => undef,
1629             output_buffer => '',
1630             local_buffer => '',
1631             read_buffer => undef,
1632             already_polled => undef,
1633             socket => undef,
1634             };
1635 0           $self->{POLLREPORTED} = 0;
1636 0           $self->debugMsg(1," --> POLL : $methodName\n");
1637 0           return;
1638             }
1639              
1640              
1641             sub poll_reset { # Clears the existing poll structure, if any
1642 0     0 1   my $self = shift;
1643 0           my $methodName;
1644              
1645 0 0         return unless defined $self->{POLL};
1646 0           $methodName = $self->{POLL}{method};
1647 0 0         $methodName .= '-> ' . join('-> ', @{$self->{POLL}{cache}}) if @{$self->{POLL}{cache}};
  0            
  0            
1648 0           $self->{POLL} = undef;
1649 0           $self->debugMsg(1," --> POLL : undef (was $methodName)\n");
1650 0           return 1;
1651             }
1652              
1653              
1654             sub poll_struct_cache { # Cache selected poll structure keys into a sub polling structure
1655 0     0 1   my ($self, $cacheMethod, $timeout) = @_;
1656 0           my $pollsub = "${Package}::poll_struct_cache";
1657              
1658 0 0         unless ($self->{POLLING}) { # Sanity check
1659 0           my (undef, $fileName, $lineNumber) = caller;
1660 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
1661             }
1662              
1663 0           $self->{POLL}{$cacheMethod}{cache}{output_buffer} = $self->{POLL}{output_buffer};
1664 0           $self->{POLL}{output_buffer} = '';
1665              
1666 0           $self->{POLL}{$cacheMethod}{cache}{output_result} = $self->{POLL}{output_result};
1667 0           $self->{POLL}{output_result} = '';
1668              
1669 0           $self->{POLL}{$cacheMethod}{cache}{local_buffer} = $self->{POLL}{local_buffer};
1670 0           $self->{POLL}{local_buffer} = '';
1671              
1672 0 0         if (defined $timeout) {
1673 0           $self->{POLL}{$cacheMethod}{cache}{timeout} = $self->{POLL}{timeout};
1674 0           $self->{POLL}{timeout} = $timeout;
1675             }
1676              
1677 0 0         my $cacheChain = @{$self->{POLL}{cache}} ? '--> ' . join(' --> ', @{$self->{POLL}{cache}}) : '';
  0            
  0            
1678 0           push( @{$self->{POLL}{cache}}, $cacheMethod); # Point cache location
  0            
1679 0           $self->debugMsg(1," --> POLL : $self->{POLL}{method} $cacheChain --> $cacheMethod\n");
1680 0           return;
1681             }
1682              
1683              
1684             sub poll_struct_restore { # Restore original poll structure from cached values and return cache method output
1685 0     0 1   my $self = shift;
1686 0           my $pollsub = "${Package}::poll_struct_restore";
1687              
1688 0 0         unless ($self->{POLLING}) { # Sanity check
1689 0           my (undef, $fileName, $lineNumber) = caller;
1690 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
1691             }
1692              
1693 0           my $cacheMethod = pop( @{$self->{POLL}{cache}} );
  0            
1694             # Save the output buffer & result
1695 0           my $output_buffer = $self->{POLL}{output_buffer};
1696 0           my $output_result = $self->{POLL}{output_result};
1697             # Restore the cached keys
1698 0           foreach my $key (keys %{$self->{POLL}{$cacheMethod}{cache}}) {
  0            
1699 0           $self->{POLL}{$key} = $self->{POLL}{$cacheMethod}{cache}{$key};
1700             }
1701             # Undefine the method poll structure
1702 0           $self->{POLL}{$cacheMethod} = undef;
1703 0 0         my $cacheChain = @{$self->{POLL}{cache}} ? '--> ' . join(' --> ', @{$self->{POLL}{cache}}) : '';
  0            
  0            
1704 0           $self->debugMsg(1," --> POLL : $self->{POLL}{method} $cacheChain <-- $cacheMethod\n");
1705             # Return the output as reference
1706 0           return (\$output_buffer, \$output_result);
1707             }
1708              
1709              
1710             sub poll_return { # Method to return from poll methods
1711 0     0 1   my ($self, $ok) = @_;
1712 0           my $pollsub = "${Package}::poll_return";
1713              
1714 0 0         unless ($self->{POLLING}) { # Sanity check
1715 0           my (undef, $fileName, $lineNumber) = caller;
1716 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
1717             }
1718 0           $self->{POLL}{already_polled} = undef; # Always reset this flag on exit
1719              
1720 0 0         if (@{$self->{POLL}{cache}}) { # Current polled method was called by another polled method
  0            
1721 0 0 0       return 0 if defined $ok && $ok == 0; # Never return any output on non-blocking not ready
1722             # If error or poll complete then restore cached output to poll structure and recover output, if any
1723 0           my ($output_bufRef, $output_resRef) = $self->poll_struct_restore;
1724 0 0         return unless defined $ok; # Never return any output on error
1725 0 0         return 1 unless wantarray; # No output requested
1726 0           return (1, $output_bufRef, $output_resRef); # Only return output, as reference, on success & wantarray
1727             }
1728              
1729 0           $self->{POLL}{complete} = $ok; # Store status for next poll
1730 0 0 0       return $ok unless $self->{POLL}{output_requested} && $self->{POLL}{output_type};
1731             # If we did not return above, only in this case do we have to provide output
1732 0           my @output_list;
1733 0 0         if ($self->{POLL}{output_type} & 1) { # Provide Output_buffer
1734 0           my $output = $self->{POLL}{output_buffer}; # 1st store the output buffer
1735 0           $self->{POLL}{output_buffer} = ''; # Then clear it in the storage structure
1736 0 0         if ($self->{POLL}{return_reference}) {
1737 0           push(@output_list, \$output);
1738             }
1739             else {
1740 0           push(@output_list, $output);
1741             }
1742             }
1743 0 0         if ($self->{POLL}{output_type} & 2) { # Provide Output_result
1744 0 0         if (ref $self->{POLL}{output_result} eq 'ARRAY') { # If an array
1745 0 0         if ($self->{POLL}{return_list}) {
1746 0           push(@output_list, @{$self->{POLL}{output_result}});
  0            
1747             }
1748             else {
1749 0           push(@output_list, $self->{POLL}{output_result});
1750             }
1751             }
1752             else { # Anything else (scalar or hash ref)
1753 0           push(@output_list, $self->{POLL}{output_result});
1754             }
1755             }
1756 0           return ($ok, @output_list);
1757             }
1758              
1759              
1760             sub poll_sleep { # Method to handle sleep for poll methods (handles both blocking and non-blocking modes)
1761 0     0 1   my ($self, $pkgsub, $secs) = @_;
1762 0           my $pollsub = "${Package}::poll_sleep";
1763              
1764 0 0         unless ($self->{POLLING}) { # Sanity check
1765 0           my (undef, $fileName, $lineNumber) = caller;
1766 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
1767             }
1768              
1769 0 0         if ($self->{POLL}{blocking}) { # In blocking mode
1770 0           sleep $secs;
1771             }
1772             else { # In non-blocking mode
1773 0 0         unless(defined $self->{POLL}{endtime}) { # Set endtime for timeout
1774 0           $self->{POLL}{endtime} = time + $secs;
1775             }
1776 0 0         return 0 unless time > $self->{POLL}{endtime}; # Sleep time not expired yet
1777             }
1778 0           return 1;
1779             }
1780              
1781              
1782             sub poll_open_socket { # Internal method to open TCP socket for either Telnet or SSH
1783 0     0 1   my ($self, $pkgsub, $host, $port) = @_;
1784 0           my $pollsub = "${Package}::poll_open_socket";
1785              
1786 0 0         unless ($self->{POLLING}) { # Sanity check
1787 0           my (undef, $fileName, $lineNumber) = caller;
1788 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
1789             }
1790              
1791 0 0         if ($UseSocketIP) { # Use IO::Socket::IP if we can (works for both IPv4 & IPv6)
1792              
1793             # In non-blocking mode we will come back here, so open socket only 1st time
1794 0 0         unless (defined $self->{POLL}{socket}) {
1795              
1796             # In non-blocking mode need to set the connection endtime for timeouts
1797 0 0         unless ($self->{POLL}{blocking}) {
1798 0 0         if (defined $self->{POLL}{timeout}) { # If a connection_timeout is defined, use it
1799 0           $self->{POLL}{endtime} = time + $self->{POLL}{timeout};
1800             }
1801             else { # If no connection_timeout is defined, fall back onto module's own default value for non-blocking connections
1802 0           $self->{POLL}{endtime} = time + $Default{connection_timeout_nb};
1803             }
1804             }
1805              
1806 0 0         $self->{POLL}{socket} = IO::Socket::IP->new(
1807             PeerHost => $host,
1808             PeerPort => $port,
1809             Blocking => 0, # Use non-blocking mode to enforce connection timeout
1810             # even if blocking connect()
1811             ) or return $self->error("$pkgsub: cannot construct socket - $@");
1812             }
1813              
1814 0   0       while ( !$self->{POLL}{socket}->connect && ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) {
      0        
1815 0           my $wvec = '';
1816 0           vec( $wvec, fileno $self->{POLL}{socket}, 1 ) = 1;
1817 0           my $evec = '';
1818 0           vec( $evec, fileno $self->{POLL}{socket}, 1 ) = 1;
1819              
1820 0 0         if ($self->{POLL}{blocking}) { # In blocking mode perform connection timeout
1821             select( undef, $wvec, $evec, $self->{POLL}{timeout} )
1822 0 0         or return $self->error("$pkgsub: connection timeout expired");
1823             }
1824             else { # In non-blocking mode don't wait; just come out if not ready and timeout not expired
1825 0 0         select( undef, $wvec, $evec, 0 ) or do {
1826 0 0         return (0, undef) unless time > $self->{POLL}{endtime}; # Timeout not expired
1827 0           return $self->error("$pkgsub: connection timeout expired"); # Timeout expired
1828             };
1829             }
1830             }
1831 0 0         return $self->error("$pkgsub: unable to connect - $!") if $!;
1832             }
1833             else { # Use IO::Socket::INET (only IPv4 support)
1834             $self->{POLL}{socket} = IO::Socket::INET->new(
1835             PeerHost => $host,
1836             PeerPort => $port,
1837             Timeout => $self->{POLL}{timeout},
1838 0 0         ) or return $self->error("$pkgsub: unable to establish socket - $@");
1839             }
1840 0           return (1, $self->{POLL}{socket});
1841             }
1842              
1843              
1844             sub poll_read { # Method to handle reads for poll methods (handles both blocking and non-blocking modes)
1845 0     0 1   my ($self, $pkgsub, $errmsg) = @_;
1846 0           my $pollsub = "${Package}::poll_read";
1847              
1848 0 0         unless ($self->{POLLING}) { # Sanity check
1849 0           my (undef, $fileName, $lineNumber) = caller;
1850 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
1851             }
1852              
1853 0 0         if ($self->{POLL}{blocking}) { # In blocking mode
1854             $self->{POLL}{read_buffer} = $self->read(
1855             blocking => 1,
1856             timeout => $self->{POLL}{timeout},
1857 0           return_reference => 0,
1858             errmode => 'return',
1859             );
1860 0 0         unless (defined $self->{POLL}{read_buffer}) { # Here we catch errors since errmode = 'return'
1861 0 0         return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
1862 0           return; # Otherwise
1863             }
1864 0           return 1; # In blocking mode we come out here indicating we have read data
1865             }
1866             else { # In non-blocking mode
1867 0 0         if ($self->{POLL}{already_polled}) { # In non-blocking mode and if we already went round the calling loop once
1868 0           $self->{POLL}{already_polled} = undef; # Undefine it for next time
1869 0           $self->{POLL}{read_buffer} = undef; # Undefine it for next time
1870 0           return 0;
1871             }
1872              
1873 0 0         unless(defined $self->{POLL}{endtime}) { # Set endtime for timeout
1874 0           $self->{POLL}{endtime} = time + $self->{POLL}{timeout};
1875             }
1876              
1877 0           $self->{POLL}{read_buffer} = $self->read(
1878             blocking => 0,
1879             return_reference => 0,
1880             errmode => 'return',
1881             );
1882 0 0         unless (defined $self->{POLL}{read_buffer}) { # Here we catch errors since errmode = 'return'
1883 0 0         return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
1884 0           return; # Otherwise
1885             }
1886 0 0         if (length $self->{POLL}{read_buffer}) { # We read something
1887 0           $self->{POLL}{already_polled} = 1; # Set it for next cycle
1888 0           $self->{POLL}{endtime} = undef; # Clear timeout endtime
1889 0           return 1; # This is effectively when we are done and $self->{POLL}{read_buffer} can be read by calling loop
1890             }
1891              
1892             # We read nothing from device
1893 0 0         if (time > $self->{POLL}{endtime}) { # Timeout has expired
1894 0           $self->{POLL}{endtime} = undef; # Clear timeout endtime
1895 0           $self->errmsg("$pollsub: Poll Read Timeout");
1896 0 0         return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
1897 0           return; # Otherwise
1898             }
1899             else { # Still within timeout
1900 0           return 0;
1901             }
1902             }
1903             }
1904              
1905              
1906             sub poll_readwait { # Method to handle readwait for poll methods (handles both blocking and non-blocking modes)
1907 0     0 1   my ($self, $pkgsub, $firstReadRequired, $readAttempts, $readwaitTimer, $errmsg, $dataWithError) = @_;
1908 0 0         $readAttempts = $self->{read_attempts} unless defined $readAttempts;
1909 0 0         $readwaitTimer = $self->{readwait_timer} unless defined $readwaitTimer;
1910 0 0         $dataWithError = $self->{data_with_error} unless defined $dataWithError;
1911 0           my $pollsub = "${Package}::poll_readwait";
1912              
1913 0 0         unless ($self->{POLLING}) { # Sanity check
1914 0           my (undef, $fileName, $lineNumber) = caller;
1915 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
1916             }
1917              
1918             # Different read section for blocking and non-blocking modes
1919 0 0         if ($self->{POLL}{blocking}) { # In blocking mode use regular readwait() method
1920             $self->{POLL}{read_buffer} = $self->readwait(
1921             read_attempts => $readAttempts,
1922             readwait_timer => $readwaitTimer,
1923             data_with_error => $dataWithError,
1924             blocking => $firstReadRequired,
1925             timeout => $self->{POLL}{timeout},
1926 0           return_reference => 0,
1927             errmode => 'return',
1928             );
1929 0 0         unless (defined $self->{POLL}{read_buffer}) { # Here we catch errors since errmode = 'return'
1930 0 0         return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
1931 0           return; # Otherwise
1932             }
1933 0           return 1; # In non-blocking mode we come out here
1934             }
1935             else { # In non-blocking mode
1936 0 0         if ($self->{POLL}{already_polled}) { # In non-blocking mode and if we already went round the calling loop once
1937 0           $self->{POLL}{already_polled} = undef; # Undefine it for next time
1938 0           $self->{POLL}{read_buffer} = undef; # Undefine it for next time
1939 0           return 0;
1940             }
1941              
1942 0 0 0       if ($firstReadRequired && !defined $self->{POLL}{endtime}) { # First time we need to setup endtime timer
    0 0        
1943 0           $self->{POLL}{endtime} = time + $self->{POLL}{timeout};
1944             }
1945             elsif (!$firstReadRequired && !defined $self->{POLL}{waittime}) { # First time, no timeout, but we need to setup wait timer directly
1946 0           $self->{POLL}{waittime} = time + $readwaitTimer/1000 * $readAttempts;
1947 0           $self->{POLL}{read_buffer} = ''; # Make sure read buffer is defined and empty
1948             }
1949              
1950 0           my $outref = $self->read(
1951             blocking => 0,
1952             return_reference => 1,
1953             errmode => 'return',
1954             );
1955 0 0         unless (defined $outref) { # Here we catch errors since errmode = 'return'
1956 0 0 0       if ($dataWithError && length $self->{POLL}{read_buffer}) { # Data_with_error processing
1957 0           $self->{POLL}{already_polled} = 1; # Set it for next cycle
1958 0           $self->{POLL}{endtime} = undef; # Clear timeout endtime
1959 0           $self->{POLL}{waittime} = undef; # Clear waittime
1960 0           return 1; # We are done, available data in $self->{POLL}{read_buffer} can be read by calling loop, in spite of error
1961             }
1962 0 0         return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
1963 0           return; # Otherwise
1964             }
1965 0 0         if (length $$outref) { # We read something, reset wait timer
1966 0           $self->{POLL}{read_buffer} .= $$outref;
1967 0           $self->{POLL}{waittime} = time + $readwaitTimer/1000 * $readAttempts;
1968 0           return 0;
1969             }
1970              
1971             # We read nothing from device
1972 0 0         if (defined $self->{POLL}{waittime}) { # Some data already read; now just doing waittimer for more
1973 0 0         if (time > $self->{POLL}{waittime}) { # Wait timer has expired
1974 0           $self->{POLL}{already_polled} = 1; # Set it for next cycle
1975 0           $self->{POLL}{endtime} = undef; # Clear timeout endtime
1976 0           $self->{POLL}{waittime} = undef; # Clear waittime
1977 0           return 1; # This is effectively when we are done and $self->{POLL}{read_buffer} can be read by calling loop
1978             }
1979             else { # Wait timer has not expired yet
1980 0           return 0;
1981             }
1982             }
1983             else { # No data read yet, regular timeout checking
1984 0 0         if (time > $self->{POLL}{endtime}) { # Timeout has expired
1985 0           $self->{POLL}{endtime} = undef; # Clear timeout endtime
1986 0           $self->errmsg("$pollsub: Poll Read Timeout");
1987 0 0         return $self->error("$pkgsub: $errmsg // ".$self->errmsg) if defined $errmsg;
1988 0           return; # Otherwise
1989             }
1990             else { # Still within timeout
1991 0           return 0;
1992             }
1993             }
1994             }
1995             }
1996              
1997              
1998             sub poll_connect { # Internal method to connect to host (used for both blocking & non-blocking modes)
1999 0     0 1   my $self = shift;
2000 0           my $pkgsub = shift;
2001 0           my $pollsub = "${Package}::connect";
2002              
2003 0 0         unless ($self->{POLLING}) { # Sanity check
2004 0           my (undef, $fileName, $lineNumber) = caller;
2005 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
2006             }
2007              
2008 0 0         unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
2009 0           my @validArgs = ('host', 'port', 'username', 'password', 'publickey', 'privatekey', 'passphrase',
2010             'prompt_credentials', 'baudrate', 'parity', 'databits', 'stopbits', 'handshake',
2011             'errmode', 'connection_timeout', 'terminal_type', 'window_size', 'callback',
2012             'forcebaud', 'atomic_connect');
2013 0           my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
2014 0 0 0       if (@_ && !%args) { # Legacy syntax
2015             ($args{host}, $args{port}, $args{username}, $args{password}, $args{publickey}, $args{privatekey}, $args{passphrase}, $args{baudrate},
2016 0           $args{parity}, $args{databits}, $args{stopbits}, $args{handshake}, $args{prompt_credentials}, $args{timeout}, $args{errmode}) = @_;
2017             }
2018             # In which case we need to setup the poll structure here (the main poll structure remains unchanged)
2019             $self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
2020             # Set method argument keys
2021             host => $args{host},
2022             port => $args{port},
2023             username => defined $args{username} ? $args{username} : $self->{USERNAME},
2024             password => defined $args{password} ? $args{password} : $self->{PASSWORD},
2025             publickey => $args{publickey},
2026             privatekey => $args{privatekey},
2027             passphrase => defined $args{passphrase} ? $args{passphrase} : $self->{PASSPHRASE},
2028             baudrate => $args{baudrate},
2029             parity => $args{parity},
2030             databits => $args{databits},
2031             stopbits => $args{stopbits},
2032             handshake => $args{handshake},
2033             prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
2034             terminal_type => $args{terminal_type},
2035             window_size => $args{window_size},
2036             callback => $args{callback},
2037             forcebaud => $args{forcebaud},
2038             atomic_connect => $args{atomic_connect},
2039             # Declare method storage keys which will be used
2040             stage => 0,
2041             authPublicKey => 0,
2042             authPassword => 0,
2043             # Declare keys to be set if method called from another polled method
2044             errmode => $args{errmode},
2045 0 0         };
    0          
    0          
    0          
2046             # Cache poll structure keys which this method will use
2047 0           $self->poll_struct_cache($pollsub, $args{connection_timeout});
2048             }
2049 0           my $connect = $self->{POLL}{$pollsub};
2050 0 0         local $self->{errmode} = $connect->{errmode} if defined $connect->{errmode};
2051              
2052 0           my $ok;
2053              
2054 0 0         if ($connect->{stage} < 1) { # Initial setup - do only once
2055 0           $self->{BUFFER} = '';
2056 0           $self->{LOGINSTAGE} = '';
2057              
2058             # For these arguments, go change the object setting, as it will need accessing via Net:Telnet callbacks
2059 0 0         $self->terminal_type($connect->{terminal_type}) if defined $connect->{terminal_type};
2060 0 0         $self->window_size(@{$connect->{window_size}}) if defined $connect->{window_size};
  0            
2061             }
2062              
2063 0 0         if ($self->{TYPE} eq 'TELNET') {
    0          
    0          
2064 0 0         if ($connect->{stage} < 1) { # Initial setup - do only once
2065 0           $connect->{stage}++; # Ensure we don't come back here in non-blocking mode
2066 0 0         return $self->poll_return($self->error("$pkgsub: No Telnet host provided")) unless defined $connect->{host};
2067 0           $self->{PARENT}->errmode('return');
2068 0           $self->{PARENT}->timeout($self->{timeout});
2069 0 0         $connect->{port} = $Default{tcp_port}{TELNET} unless defined $connect->{port};
2070 0           $self->{HOST} = $connect->{host};
2071 0           $self->{TCPPORT} = $connect->{port};
2072 0 0 0       if (!$self->{POLL}{blocking} && $connect->{atomic_connect}) {
2073 0           $self->{POLL}{blocking} = 1; # Switch into blocking mode during connect phase
2074 0           return $self->poll_return(0); # Next poll will be the atomic connect
2075             }
2076             else {
2077 0           $connect->{atomic_connect} = undef; # In blocking mode undefine it
2078             }
2079             }
2080             # TCP Socket setup and handoff to Net::Telnet object
2081             # Open Socket ourselves
2082 0           ($ok, $self->{SOCKET}) = $self->poll_open_socket($pkgsub, $connect->{host}, $connect->{port});
2083 0 0         return $self->poll_return($ok) unless $ok; # Covers 2 cases:
2084             # - errmode is 'return' and $ok = undef ; so we come out due to error
2085             # - $ok = 0 ; non-blocking mode; connection not ready yet
2086              
2087             # Give Socket to Net::Telnet
2088 0 0         $self->{PARENT}->fhopen($self->{SOCKET}) or return $self->poll_return($self->error("$pkgsub: unable to open Telnet over socket"));
2089 0 0         if ($^O eq 'MSWin32') {
2090             # We need this hack to workaround a bug introduced in Net::Telnet 3.04
2091             # see Net::Telnet bug report 94913: https://rt.cpan.org/Ticket/Display.html?id=94913
2092 0           my $telobj = *{$self->{PARENT}}->{net_telnet};
  0            
2093 0 0 0       if (exists $telobj->{select_supported} && !$telobj->{select_supported}) {
2094             # select_supported key is new in Net::Telnet 3.04 (does not exist in 3.03)
2095             # If we get here, it is because it did not get set correctly by our fhopen above, which means
2096             # we are using Net::Telnet 3.04 or a later version of it which still has not fixed the issue
2097 0           $telobj->{select_supported} = 1; # Workaround, we set it
2098             }
2099             }
2100              
2101             # Handle Telnet options
2102 0           $self->_handle_telnet_options;
2103 0 0         $self->{POLL}{blocking} = 0 if $connect->{atomic_connect}; # Restore non-blocking mode once connect complete
2104             }
2105             elsif ($self->{TYPE} eq 'SSH') {
2106 0 0         if ($connect->{stage} < 1) { # Initial setup - do only once
2107 0           $connect->{stage}++; # Ensure we don't come back here in non-blocking mode
2108 0 0         return $self->poll_return($self->error("$pkgsub: No SSH host provided")) unless defined $connect->{host};
2109 0 0         $connect->{port} = $Default{tcp_port}{SSH} unless defined $connect->{port};
2110 0           $self->{HOST} = $connect->{host};
2111 0           $self->{TCPPORT} = $connect->{port};
2112 0 0 0       if (!$self->{POLL}{blocking} && $connect->{atomic_connect}) {
2113 0           $self->{POLL}{blocking} = 1; # Switch into blocking mode during connect phase
2114 0           return $self->poll_return(0); # Next poll will be the atomic connect
2115             }
2116             else {
2117 0           $connect->{atomic_connect} = undef; # In blocking mode undefine it
2118             }
2119             }
2120 0 0         if ($connect->{stage} < 2) { # TCP Socket setup and handoff to Net::SSH2 object
2121             # Open Socket ourselves
2122 0           ($ok, $self->{SOCKET}) = $self->poll_open_socket($pkgsub, $connect->{host}, $connect->{port});
2123 0 0         return $self->poll_return($ok) unless $ok; # Covers 2 cases:
2124             # - errmode is 'return' and $ok = undef ; so we come out due to error
2125             # - $ok = 0 ; non-blocking mode; connection not ready yet
2126 0           $connect->{stage}++; # Ensure we don't come back here in non-blocking mode
2127              
2128             # Set the SO_LINGER option as Net::SSH2 would do
2129 0           $self->{SOCKET}->sockopt(&Socket::SO_LINGER, pack('SS', 0, 0));
2130            
2131             # Give Socket to Net::SSH2
2132 0           eval { # Older versions of Net::SSH2 need to be trapped so that we get desired error mode
2133 0           $ok = $self->{PARENT}->connect($self->{SOCKET});
2134             };
2135 0 0         return $self->poll_return($self->error("$pkgsub: " . $@)) if $@;
2136 0 0         return $self->poll_return($self->error("$pkgsub: SSH unable to connect")) unless $ok;
2137 0 0         return $self->poll_return(0) unless $self->{POLL}{blocking};
2138             }
2139 0 0         if ($connect->{stage} < 3) { # Check for callback (if user wants to verify device hostkey against known hosts)
2140 0           $connect->{stage}++; # Ensure we don't come back here in non-blocking mode
2141 0 0         if ($connect->{callback}) {
2142 0 0         if ( validCodeRef($connect->{callback}) ) {
2143 0           ($ok, my $errmsg) = callCodeRef($connect->{callback}, $self);
2144 0 0         return $self->poll_return($self->error("$pkgsub: " . (defined $errmsg ? $errmsg : "SSH callback refused connection"))) unless $ok;
    0          
2145 0 0         return $self->poll_return(0) unless $self->{POLL}{blocking};
2146             }
2147             else {
2148 0           carp "$pkgsub: Callback is not a valid code ref; ignoring";
2149             }
2150             }
2151             }
2152 0 0         if ($connect->{stage} < 4) { # Find out available SSH authentication options
2153 0           $connect->{stage}++; # Ensure we don't come back here in non-blocking mode
2154 0 0         unless ( defined $connect->{username} ) {
2155 0 0         return $self->poll_return($self->error("$pkgsub: Username required for SSH authentication")) unless $connect->{prompt_credentials};
2156 0           $connect->{username} = promptCredential($connect->{prompt_credentials}, 'Clear', 'Username');
2157             # Reset timeout endtime
2158 0           $self->{POLL}{endtime} = time + $self->{POLL}{timeout};
2159             }
2160 0 0 0       if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
2161 0           return $self->poll_return($self->error("$pkgsub: connection timeout expired (before auth_list)"));
2162             }
2163 0           my @authList = $self->{PARENT}->auth_list($connect->{username});
2164 0           foreach my $auth (@authList) {
2165 0 0         $connect->{authPublicKey} = 1 if $auth eq 'publickey';
2166 0 0         $connect->{authPassword} |= 1 if $auth eq 'password'; # bit1 = password
2167 0 0         $connect->{authPassword} |= 2 if $auth eq 'keyboard-interactive'; # bit2 = KI
2168             }
2169 0           $self->debugMsg(1,"SSH authentications accepted: ", \join(', ', @authList), "\n");
2170 0           $self->debugMsg(1,"authPublicKey flag = $connect->{authPublicKey} ; authPassword flag = $connect->{authPassword}\n");
2171 0           $self->{USERNAME} = $connect->{username}; # If we got here, we have a connection so store the username used
2172 0 0         return $self->poll_return(0) unless $self->{POLL}{blocking};
2173             }
2174 0 0         if ($connect->{stage} < 5) { # Try publickey authentication
2175 0           $connect->{stage}++; # Ensure we don't come back here in non-blocking mode
2176 0 0         if ($connect->{authPublicKey}) { # Try Public Key authentication...
2177 0 0 0       if (defined $connect->{publickey} && defined $connect->{privatekey}) { # ... if we have keys
    0          
2178             return $self->poll_return($self->error("$pkgsub: Public Key '$connect->{publickey}' not found"))
2179 0 0         unless -e $connect->{publickey};
2180             return $self->poll_return($self->error("$pkgsub: Private Key '$connect->{privatekey}' not found"))
2181 0 0         unless -e $connect->{privatekey};
2182 0 0         unless ($connect->{passphrase}) { # Passphrase not provided
2183 0           my $passphReq = passphraseRequired($connect->{privatekey});
2184 0 0         return $self->poll_return($self->error("$pkgsub: Unable to read Private key")) unless defined $passphReq;
2185 0 0         if ($passphReq) { # Passphrase is required
2186 0 0         return $self->poll_return($self->error("$pkgsub: Passphrase required for Private Key")) unless $connect->{prompt_credentials};
2187             # We are allowed to prompt for it
2188 0           $connect->{passphrase} = promptCredential($connect->{prompt_credentials}, 'Hide', 'Passphrase for Private Key');
2189             # Reset timeout endtime
2190 0           $self->{POLL}{endtime} = time + $self->{POLL}{timeout};
2191             }
2192             }
2193 0 0 0       if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
2194 0           return $self->poll_return($self->error("$pkgsub: connection timeout expired (before auth_publickey"));
2195             }
2196             $ok = $self->{PARENT}->auth_publickey(
2197             $connect->{username},
2198             $connect->{publickey},
2199             $connect->{privatekey},
2200             $connect->{passphrase},
2201 0           );
2202 0 0 0       if ($ok) { # Store the passphrase used if publickey authentication succeded
    0          
2203 0 0         $self->{PASSPHRASE} = $connect->{passphrase} if $connect->{passphrase};
2204 0           $self->{SSHAUTH} = 'publickey';
2205             }
2206             elsif ( !($connect->{authPassword} && (defined $connect->{password} || $connect->{prompt_credentials})) ) {
2207             # Unless we can try password authentication next, throw an error now
2208 0           return $self->poll_return($self->error("$pkgsub: SSH unable to publickey authenticate"));
2209             }
2210 0 0         return $self->poll_return(0) unless $self->{POLL}{blocking};
2211             }
2212             elsif (!$connect->{authPassword}) { # If we don't have the keys and publickey authentication was the only one possible
2213 0           return $self->poll_return($self->error("$pkgsub: Only publickey SSH authenticatication possible and no keys provided"));
2214             }
2215             }
2216             }
2217 0 0         if ($connect->{stage} < 6) { # Try password authentication
2218 0           $connect->{stage}++; # Ensure we don't come back here in non-blocking mode
2219 0 0 0       if ($connect->{authPassword} && !$self->{PARENT}->auth_ok) { # Try password authentication if not already publickey authenticated
2220 0 0         unless ( defined $connect->{password} ) {
2221 0 0         return $self->poll_return($self->error("$pkgsub: Password required for password authentication")) unless $connect->{prompt_credentials};
2222 0           $connect->{password} = promptCredential($connect->{prompt_credentials}, 'Hide', 'Password');
2223             # Reset timeout endtime
2224 0           $self->{POLL}{endtime} = time + $self->{POLL}{timeout};
2225             }
2226 0 0 0       if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
2227 0           return $self->poll_return($self->error("$pkgsub: connection timeout expired (before auth_password)"));
2228             }
2229 0 0         if ($connect->{authPassword} & 1) { # Use password authentication
    0          
2230             $self->{PARENT}->auth_password($connect->{username}, $connect->{password})
2231 0 0         or return $self->poll_return($self->error("$pkgsub: SSH unable to password authenticate"));
2232 0           $self->{SSHAUTH} = 'password';
2233             }
2234             elsif ($connect->{authPassword} & 2) { # Use keyboard-interactive authentication
2235             $self->{PARENT}->auth_keyboard($connect->{username}, $connect->{password})
2236 0 0         or return $self->poll_return($self->error("$pkgsub: SSH unable to password authenticate (using keyboard-interactive)"));
2237 0           $self->{SSHAUTH} = 'keyboard-interactive';
2238             }
2239             else {
2240 0           return $self->poll_return($self->error("$pkgsub: Error in processing password authentication options"));
2241             }
2242             # Store password used
2243 0           $self->{PASSWORD} = $connect->{password};
2244 0 0         return $self->poll_return(0) unless $self->{POLL}{blocking};
2245             }
2246             }
2247             # Make sure we are authenticated, in case neither publicKey nor password auth was accepted
2248 0 0         return $self->poll_return($self->error("$pkgsub: SSH unable to authenticate")) unless $self->{PARENT}->auth_ok;
2249              
2250             # Setup SSH channel
2251 0 0 0       if ( !$self->{POLL}{blocking} && time > $self->{POLL}{endtime} ) { # Check if over time in non-blocking mode
2252 0           return $self->poll_return($self->error("$pkgsub: connection timeout expired (before SSH channel setup)"));
2253             }
2254 0           $self->{SSHCHANNEL} = $self->{PARENT}->channel(); # Open an SSH channel
2255 0           $self->{PARENT}->blocking(0); # Make the session non blocking for reads
2256 0           $self->{SSHCHANNEL}->ext_data('merge'); # Merge stderr onto regular channel
2257 0           $self->{SSHCHANNEL}->pty($self->{terminal_type}, undef, @{$self->{window_size}}); # Start interactive terminal; also set term type & window size
  0            
2258 0           $self->{SSHCHANNEL}->shell(); # Start shell on channel
2259 0 0         $self->{POLL}{blocking} = 0 if $connect->{atomic_connect}; # Restore non-blocking mode once connect complete
2260             }
2261             elsif ($self->{TYPE} eq 'SERIAL') {
2262 0 0         $connect->{handshake} = $Default{handshake} unless defined $connect->{handshake};
2263 0 0         $connect->{baudrate} = $Default{baudrate} unless defined $connect->{baudrate};
2264 0 0         $connect->{parity} = $Default{parity} unless defined $connect->{parity};
2265 0 0         $connect->{databits} = $Default{databits} unless defined $connect->{databits};
2266 0 0         $connect->{stopbits} = $Default{stopbits} unless defined $connect->{stopbits};
2267 0 0         $self->{PARENT}->handshake($connect->{handshake}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Handshake"));
2268 0 0         $self->{PARENT}->baudrate($connect->{baudrate}) or do {
2269             # If error, could be Win32::SerialPort bug https://rt.cpan.org/Ticket/Display.html?id=120068
2270 0 0 0       if ($^O eq 'MSWin32' && $connect->{forcebaud}) { # With forcebaud we can force-set the desired baudrate
2271 0           $self->{PARENT}->{"_N_BAUD"} = $connect->{baudrate};
2272             }
2273             else { # Else we come out with error
2274 0           return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Baudrate"));
2275             }
2276             };
2277 0 0         $self->{PARENT}->parity($connect->{parity}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Parity"));
2278 0 0         unless ($connect->{parity} eq 'none') { # According to Win32::SerialPort, parity_enable needs to be set when parity is not 'none'...
2279 0 0         $self->{PARENT}->parity_enable(1) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Parity_Enable"));
2280             }
2281 0 0         $self->{PARENT}->databits($connect->{databits}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort DataBits"));
2282 0 0         $self->{PARENT}->stopbits($connect->{stopbits}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort StopBits"));
2283 0 0         $self->{PARENT}->write_settings or return $self->poll_return($self->error("$pkgsub: Can't change Device_Control_Block: $^E"));
2284             #Set Read & Write buffers
2285 0 0         $self->{PARENT}->buffers($ComPortReadBuffer, 0) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Buffers"));
2286 0 0         if ($^O eq 'MSWin32') {
2287 0 0         $self->{PARENT}->read_interval($ComReadInterval) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Read_Interval"));
2288             }
2289             # Don't wait for each character
2290 0 0         defined $self->{PARENT}->read_char_time(0) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Read_Char_Time"));
2291 0           $self->{HANDSHAKE} = $connect->{handshake};
2292 0           $self->{BAUDRATE} = $connect->{baudrate};
2293 0           $self->{PARITY} = $connect->{parity};
2294 0           $self->{DATABITS} = $connect->{databits};
2295 0           $self->{STOPBITS} = $connect->{stopbits};
2296 0           $self->{SERIALEOF} = 0;
2297             }
2298             else {
2299 0           return $self->poll_return($self->error("$pkgsub: Invalid connection mode"));
2300             }
2301 0           return $self->poll_return(1);
2302             }
2303              
2304              
2305             sub poll_login { # Method to handle login for poll methods (used for both blocking & non-blocking modes)
2306 0     0 1   my $self = shift;
2307 0           my $pkgsub = shift;
2308 0           my $pollsub = "${Package}::login";
2309              
2310 0 0         unless ($self->{POLLING}) { # Sanity check
2311 0           my (undef, $fileName, $lineNumber) = caller;
2312 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
2313             }
2314              
2315 0 0         unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
2316 0           my @validArgs = ('username', 'password', 'prompt_credentials', 'prompt', 'username_prompt', 'password_prompt', 'timeout', 'errmode');
2317 0           my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
2318 0 0 0       if (@_ && !%args) { # Legacy syntax
2319             ($args{username}, $args{password}, $args{prompt}, $args{username_prompt}, $args{password_prompt},
2320 0           $args{prompt_credentials}, $args{timeout}, $args{errmode}) = @_;
2321             }
2322             # In which case we need to setup the poll structure here (the main poll structure remains unchanged)
2323             $self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
2324             # Set method argument keys
2325             username => defined $args{username} ? $args{username} : $self->{USERNAME},
2326             password => defined $args{password} ? $args{password} : $self->{PASSWORD},
2327             prompt => defined $args{prompt} ? $args{prompt} : $self->{prompt_qr},
2328             username_prompt => defined $args{username_prompt} ? $args{username_prompt} : $self->{username_prompt_qr},
2329             password_prompt => defined $args{password_prompt} ? $args{password_prompt} : $self->{password_prompt_qr},
2330             prompt_credentials => defined $args{prompt_credentials} ? $args{prompt_credentials} : $self->{prompt_credentials},
2331             # Declare method storage keys which will be used
2332             stage => 0,
2333             login_attempted => undef,
2334             # Declare keys to be set if method called from another polled method
2335             errmode => $args{errmode},
2336 0 0         };
    0          
    0          
    0          
    0          
    0          
2337             # Cache poll structure keys which this method will use
2338 0           $self->poll_struct_cache($pollsub, $args{timeout});
2339             }
2340 0           my $login = $self->{POLL}{$pollsub};
2341 0 0         local $self->{errmode} = $login->{errmode} if defined $login->{errmode};
2342 0 0         return $self->poll_return($self->error("$pkgsub: No connection to login to")) if $self->eof;
2343              
2344 0 0         if ($login->{stage} < 1) { # Initial loginstage checking - do only once
2345 0           $login->{stage}++; # Ensure we don't come back here in non-blocking mode
2346 0 0         if ($self->{LOGINSTAGE} eq 'username') { # Resume login from where it was left
    0          
2347 0 0         return $self->error("$pkgsub: Username required") unless $login->{username};
2348 0 0         $self->print(line => $login->{username}, errmode => 'return')
2349             or return $self->poll_return($self->error("$pkgsub: Unable to send username // ".$self->errmsg));
2350 0           $self->{LOGINSTAGE} = '';
2351 0           $login->{login_attempted} =1;
2352             }
2353             elsif ($self->{LOGINSTAGE} eq 'password') { # Resume login from where it was left
2354 0 0         return $self->error("$pkgsub: Password required") unless $login->{password};
2355 0 0         $self->print(line => $login->{password}, errmode => 'return')
2356             or return $self->poll_return($self->error("$pkgsub: Unable to send password // ".$self->errmsg));
2357 0           $self->{LOGINSTAGE} = '';
2358             }
2359             }
2360             # Enter login loop..
2361             do {{
2362 0           my $ok = $self->poll_read($pkgsub, 'Failed reading login prompt');
  0            
2363 0 0         return $self->poll_return($ok) unless $ok;
2364              
2365 0           $self->{POLL}{local_buffer} .= $self->{POLL}{read_buffer}; # Login buffer can get flushed along the way
2366 0           $self->{POLL}{output_buffer} .= $self->{POLL}{read_buffer}; # This buffer preserves all the output, in case it is requested
2367              
2368 0 0         if ($self->{POLL}{local_buffer} =~ /$login->{username_prompt}/) { # Handle username prompt
2369 0 0         if ($login->{login_attempted}) {
2370 0           return $self->poll_return($self->error("$pkgsub: Incorrect Username or Password"));
2371             }
2372 0 0         unless ($login->{username}) {
2373 0 0         if ($self->{TYPE} eq 'SSH') { # If an SSH connection, we already have the username
2374 0           $login->{username} = $self->{USERNAME};
2375             }
2376             else {
2377 0 0         unless ($login->{prompt_credentials}) {
2378 0           $self->{LOGINSTAGE} = 'username';
2379 0           return $self->poll_return($self->error("$pkgsub: Username required"));
2380             }
2381 0           $login->{username} = promptCredential($login->{prompt_credentials}, 'Clear', 'Username');
2382             }
2383             }
2384 0 0         $self->print(line => $login->{username}, errmode => 'return')
2385             or return $self->poll_return($self->error("$pkgsub: Unable to send username // ".$self->errmsg));
2386 0           $self->{LOGINSTAGE} = '';
2387 0           $login->{login_attempted} =1;
2388 0           $self->{POLL}{local_buffer} = '';
2389 0           next;
2390             }
2391 0 0         if ($self->{POLL}{local_buffer} =~ /$login->{password_prompt}/) { # Handle password prompt
2392 0 0         unless (defined $login->{password}) {
2393 0 0         unless (defined $login->{prompt_credentials}) {
2394 0           $self->{LOGINSTAGE} = 'password';
2395 0           return $self->poll_return($self->error("$pkgsub: Password required"));
2396             }
2397 0           $login->{password} = promptCredential($login->{prompt_credentials}, 'Hide', 'Password');
2398             }
2399 0 0         $self->print(line => $login->{password}, errmode => 'return')
2400             or return $self->poll_return($self->error("$pkgsub: Unable to send password // ".$self->errmsg));
2401 0           $self->{LOGINSTAGE} = '';
2402 0           $self->{POLL}{local_buffer} = '';
2403 0           next;
2404             }
2405 0           }} until ($self->{POLL}{local_buffer} =~ /($login->{prompt})/);
2406 0           $self->{LASTPROMPT} = $1;
2407 0           $self->{WRITEFLAG} = 0;
2408 0 0         ($self->{USERNAME}, $self->{PASSWORD}) = ($login->{username}, $login->{password}) if $login->{login_attempted};
2409 0           return $self->poll_return(1);
2410             }
2411              
2412              
2413             sub poll_waitfor { # Method to handle waitfor for poll methods (used for both blocking & non-blocking modes)
2414 0     0 1   my $self = shift;
2415 0           my $pkgsub = shift;
2416 0           my $pollsub = "${Package}::waitfor";
2417              
2418 0 0         unless ($self->{POLLING}) { # Sanity check
2419 0           my (undef, $fileName, $lineNumber) = caller;
2420 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
2421             }
2422              
2423 0 0         unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
2424 0           my @validArgs = ('match_list', 'timeout', 'errmode');
2425 0           my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
2426 0 0 0       if (@_ && !%args) { # Legacy syntax
2427 0           ($args{match_list}, $args{timeout}, $args{errmode}) = @_;
2428             }
2429 0 0         $args{match_list} = [$args{match_list}] unless ref($args{match_list}) eq "ARRAY"; # We want it as an array reference
2430 0           my @matchArray = grep {defined} @{$args{match_list}}; # Weed out undefined values, if any
  0            
  0            
2431             # In which case we need to setup the poll structure here (the main poll structure remains unchanged)
2432             $self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
2433             # Set method argument keys
2434             matchpat => \@matchArray,
2435             # Declare method storage keys which will be used
2436             stage => 0,
2437             matchpat_qr => undef,
2438             # Declare keys to be set if method called from another polled method
2439             errmode => $args{errmode},
2440 0           };
2441             # Cache poll structure keys which this method will use
2442 0           $self->poll_struct_cache($pollsub, $args{timeout});
2443             }
2444 0           my $waitfor = $self->{POLL}{$pollsub};
2445 0 0         local $self->{errmode} = $waitfor->{errmode} if defined $waitfor->{errmode};
2446 0 0         return $self->poll_return($self->error("$pkgsub: Received eof from connection")) if $self->eof;
2447              
2448 0 0         if ($waitfor->{stage} < 1) { # 1st stage
2449 0           $waitfor->{stage}++; # Ensure we don't come back here in non-blocking mode
2450 0 0         return $self->poll_return($self->error("$pkgsub: Match pattern provided is undefined")) unless @{$waitfor->{matchpat}};
  0            
2451 0           eval { # Eval the patterns as they may be invalid
2452 0           @{$waitfor->{matchpat_qr}} = map {qr/^((?:.*\n?)*?)($_)/} @{$waitfor->{matchpat}}; # Convert match patterns into regex
  0            
  0            
  0            
2453             # This syntax did not work: qr/^([\n.]*?)($_)/
2454             };
2455 0 0         if ($@) { # If we trap an error..
2456 0           $@ =~ s/ at \S+ line .+$//s; # ..remove this module's line number
2457 0           return $self->poll_return($self->error("$pkgsub: $@"));
2458             }
2459             }
2460              
2461 0           READ: while (1) {
2462 0           my $ok = $self->poll_read($pkgsub, 'Failed waiting for output');
2463 0 0         return $self->poll_return($ok) unless $ok;
2464 0           $self->{POLL}{local_buffer} .= $self->{POLL}{read_buffer};
2465              
2466 0           foreach my $pattern (@{$waitfor->{matchpat_qr}}) {
  0            
2467 0 0         if ($self->{POLL}{local_buffer} =~ s/$pattern//) {
2468 0           ($self->{POLL}{output_buffer}, $self->{POLL}{output_result}) = ($1, $2);
2469 0           last READ;
2470             }
2471             }
2472             }
2473 0 0         $self->{BUFFER} = $self->{POLL}{local_buffer} if length $self->{POLL}{local_buffer};
2474 0           return $self->poll_return(1);
2475             }
2476              
2477              
2478             sub poll_cmd { # Method to handle cmd for poll methods (used for both blocking & non-blocking modes)
2479 0     0 1   my $self = shift;
2480 0           my $pkgsub = shift;
2481 0           my $pollsub = "${Package}::cmd";
2482              
2483 0 0         unless ($self->{POLLING}) { # Sanity check
2484 0           my (undef, $fileName, $lineNumber) = caller;
2485 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
2486             }
2487              
2488 0 0         unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
2489 0           my @validArgs = ('command', 'prompt', 'timeout', 'errmode');
2490 0           my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
2491 0 0 0       if (@_ && !%args) { # Legacy syntax
2492 0           ($args{command}, $args{prompt}, $args{timeout}, $args{errmode}) = @_;
2493             }
2494             # In which case we need to setup the poll structure here (the main poll structure remains unchanged)
2495             $self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
2496             # Set method argument keys
2497             command => $args{command},
2498             prompt => defined $args{prompt} ? $args{prompt} : $self->{prompt_qr},
2499             # Declare method storage keys which will be used
2500             stage => 0,
2501             cmdEchoRemoved => 0,
2502             # Declare keys to be set if method called from another polled method
2503             errmode => $args{errmode},
2504 0 0         };
2505             # Cache poll structure keys which this method will use
2506 0           $self->poll_struct_cache($pollsub, $args{timeout});
2507             }
2508 0           my $cmd = $self->{POLL}{$pollsub};
2509 0 0         local $self->{errmode} = $cmd->{errmode} if defined $cmd->{errmode};
2510 0 0         return $self->poll_return($self->error("$pkgsub: No connection to send cmd to")) if $self->eof;
2511              
2512 0 0         if ($cmd->{stage} < 1) { # Send command - do only once
2513 0           $cmd->{stage}++; # Ensure we don't come back here in non-blocking mode
2514              
2515             # Flush any unread data which might be pending
2516 0           $self->read(blocking => 0);
2517              
2518             # Send the command
2519 0 0         $self->print(line => $cmd->{command}, errmode => 'return')
2520             or return $self->poll_return($self->error("$pkgsub: Unable to send CLI command: $cmd->{command} // ".$self->errmsg));
2521             }
2522              
2523             # Wait for next prompt
2524             do {
2525 0           my $ok = $self->poll_read($pkgsub, 'Failed after sending command');
2526 0 0         return $self->poll_return($ok) unless $ok;
2527              
2528 0 0         if ($cmd->{cmdEchoRemoved}) { # Initial echoed command was already removed from output
2529 0           $self->{POLL}{local_buffer} .= $self->{POLL}{read_buffer}; # Add new output
2530 0           my $lastLine = stripLastLine(\$self->{POLL}{local_buffer}); # Remove incomplete last line if any
2531 0           $self->{POLL}{output_buffer} .= $self->{POLL}{local_buffer}; # This buffer preserves all the output
2532 0           $self->{POLL}{local_buffer} = $lastLine; # Keep incomplete lines in this buffer
2533             }
2534             else { # We have not yet received a complete line
2535 0           $self->{POLL}{local_buffer} .= $self->{POLL}{read_buffer}; # Use this buffer until we can strip the echoed command
2536 0 0         if ($self->{POLL}{local_buffer} =~ s/^.*\n//) { # We can remove initial echoed command from output
2537 0           my $lastLine = stripLastLine(\$self->{POLL}{local_buffer}); # Remove incomplete last line if any
2538 0           $self->{POLL}{output_buffer} = $self->{POLL}{local_buffer}; # Copy it across; it can now be retrieved
2539 0           $self->{POLL}{local_buffer} = $lastLine; # Keep incomplete lines in this buffer
2540 0           $cmd->{cmdEchoRemoved} = 1;
2541             }
2542             }
2543 0           } until $self->{POLL}{local_buffer} =~ s/($cmd->{prompt})//;
2544 0           $self->{LASTPROMPT} = $1;
2545 0           $self->{WRITEFLAG} = 0;
2546 0           return $self->poll_return(1);
2547             }
2548              
2549              
2550             sub poll_change_baudrate { # Method to handle change_baudrate for poll methods (used for both blocking & non-blocking modes)
2551 0     0 1   my $self = shift;
2552 0           my $pkgsub = shift;
2553 0           my $pollsub = "${Package}::change_baudrate";
2554              
2555 0 0         unless ($self->{POLLING}) { # Sanity check
2556 0           my (undef, $fileName, $lineNumber) = caller;
2557 0           croak "$pollsub (called from $fileName line $lineNumber) can only be used within polled methods";
2558             }
2559              
2560 0 0         unless (defined $self->{POLL}{$pollsub}) { # Only applicable if called from another method already in polling mode
2561 0           my @validArgs = ('baudrate', 'parity', 'databits', 'stopbits', 'handshake', 'errmode', 'forcebaud');
2562 0           my %args = parseMethodArgs($pkgsub, \@_, \@validArgs, 1);
2563 0 0 0       if (@_ && !%args) { # Legacy syntax
2564 0           ($args{baudrate}, $args{parity}, $args{databits}, $args{stopbits}, $args{handshake}, $args{errmode}) = @_;
2565             }
2566             # In which case we need to setup the poll structure here (the main poll structure remains unchanged)
2567             $self->{POLL}{$pollsub} = { # Populate structure with method arguments/storage
2568             # Set method argument keys
2569             baudrate => defined $args{baudrate} ? $args{baudrate} : $self->{BAUDRATE},
2570             parity => defined $args{parity} ? $args{parity} : $self->{PARITY},
2571             databits => defined $args{databits} ? $args{databits} : $self->{DATABITS},
2572             stopbits => defined $args{stopbits} ? $args{stopbits} : $self->{STOPBITS},
2573             handshake => defined $args{handshake} ? $args{handshake} : $self->{HANDSHAKE},
2574             forcebaud => $args{forcebaud},
2575             # Declare method storage keys which will be used
2576             stage => 0,
2577             # Declare keys to be set if method called from another polled method
2578             errmode => $args{errmode},
2579 0 0         };
    0          
    0          
    0          
    0          
2580             # Cache poll structure keys which this method will use
2581 0           $self->poll_struct_cache($pollsub);
2582             }
2583 0           my $changeBaud = $self->{POLL}{$pollsub};
2584 0 0         local $self->{errmode} = $changeBaud->{errmode} if defined $changeBaud->{errmode};
2585              
2586 0 0         return $self->poll_return($self->error("$pkgsub: Cannot change baudrate on Telnet/SSH")) unless $self->{TYPE} eq 'SERIAL';
2587 0 0         return $self->poll_return($self->error("$pkgsub: No serial connection established yet")) if $self->{SERIALEOF};
2588              
2589 0 0         if ($changeBaud->{stage} < 1) { # 1st stage
2590 0           $self->{PARENT}->write_done(1); # Needed to flush writes before closing with Device::SerialPort
2591 0           $changeBaud->{stage}++; # Move to 2nd stage
2592             }
2593 0 0         if ($changeBaud->{stage} < 2) { # 2nd stage - delay
2594 0           my $ok = $self->poll_sleep($pkgsub, $ChangeBaudDelay/1000);
2595 0 0         return $self->poll_return($ok) unless $ok;
2596 0           $changeBaud->{stage}++; # Move to next stage
2597             }
2598 0           $self->{PARENT}->close;
2599 0           $self->{SERIALEOF} = 1; # If all goes well we'll set this back to 0 on exit
2600 0 0         if ($^O eq 'MSWin32') {
2601 0 0         $self->{PARENT} = Win32::SerialPort->new($self->{COMPORT}, !($self->{debug} & 1))
2602             or return $self->poll_return($self->error("$pkgsub: Cannot re-open serial port '$self->{COMPORT}'"));
2603             }
2604             else {
2605 0 0         $self->{PARENT} = Device::SerialPort->new($self->{COMPORT}, !($self->{debug} & 1))
2606             or return $self->poll_return($self->error("$pkgsub: Cannot re-open serial port '$self->{COMPORT}'"));
2607             }
2608 0 0         $self->{PARENT}->handshake($changeBaud->{handshake}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Handshake"));
2609 0 0         $self->{PARENT}->baudrate($changeBaud->{baudrate}) or do {
2610             # If error, could be Win32::SerialPort bug https://rt.cpan.org/Ticket/Display.html?id=120068
2611 0 0 0       if ($^O eq 'MSWin32' && $changeBaud->{forcebaud}) { # With forcebaud we can force-set the desired baudrate
2612 0           $self->{PARENT}->{"_N_BAUD"} = $changeBaud->{baudrate};
2613             }
2614             else { # Else we come out with error
2615 0           return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Baudrate"));
2616             }
2617             };
2618 0 0         $self->{PARENT}->parity($changeBaud->{parity}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Parity"));
2619 0 0         unless ($changeBaud->{parity} eq 'none') { # According to Win32::SerialPort, parity_enable needs to be set when parity is not 'none'...
2620 0 0         $self->{PARENT}->parity_enable(1) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Parity_Enable"));
2621             }
2622 0 0         $self->{PARENT}->databits($changeBaud->{databits}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort DataBits"));
2623 0 0         $self->{PARENT}->stopbits($changeBaud->{stopbits}) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort StopBits"));
2624 0 0         $self->{PARENT}->write_settings or return $self->poll_return($self->error("$pkgsub: Can't change Device_Control_Block: $^E"));
2625             #Set Read & Write buffers
2626 0 0         $self->{PARENT}->buffers($ComPortReadBuffer, 0) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Buffers"));
2627 0 0         if ($^O eq 'MSWin32') {
2628 0 0         $self->{PARENT}->read_interval($ComReadInterval) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Read_Interval"));
2629             }
2630             # Don't wait for each character
2631 0 0         defined $self->{PARENT}->read_char_time(0) or return $self->poll_return($self->error("$pkgsub: Can't set SerialPort Read_Char_Time"));
2632 0           $self->{BAUDRATE} = $changeBaud->{baudrate};
2633 0           $self->{PARITY} = $changeBaud->{parity};
2634 0           $self->{DATABITS} = $changeBaud->{databits};
2635 0           $self->{STOPBITS} = $changeBaud->{stopbits};
2636 0           $self->{HANDSHAKE} = $changeBaud->{handshake};
2637 0           $self->{SERIALEOF} = 0;
2638 0           return $self->poll_return(1);
2639             }
2640              
2641              
2642             sub debugMsg { # Print a debug message
2643 0     0 1   my $self = shift;
2644 0 0         if (shift() & $self->{debug}) {
2645 0           my $string1 = shift();
2646 0   0       my $stringRef = shift() || \"";#" Ultraedit hack!
2647 0   0       my $string2 = shift() || "";
2648 0           print $string1, $$stringRef, $string2;
2649             }
2650 0           return;
2651             }
2652              
2653              
2654             ########################################## Internal Private Methods ##########################################
2655              
2656             sub _check_query { # Internal method to process Query Device Status escape sequences
2657 0     0     my ($self, $pkgsub, $bufRef) = @_;
2658 0 0         if (length $self->{QUERYBUFFER}) { # If an escape sequence fragment was cashed
2659 0           $$bufRef = join('', $self->{QUERYBUFFER}, $$bufRef); # prepend it to new output
2660 0           $self->{QUERYBUFFER} = '';
2661             }
2662 0 0         if ($$bufRef =~ /(\e(?:\[.?)?)$/){ # If output stream ends with \e, or \e[ or \e[.
2663             # We could be looking at an escape sequence fragment; we check if it partially matches $VT100_QueryDeviceStatus
2664 0           my $escFrag = $1;
2665 0 0         if ($VT100_QueryDeviceStatus =~ /^\Q$escFrag\E/){ # If it does,
2666 0           $$bufRef =~ s/\Q$escFrag\E$//; # we strip it
2667 0           $self->{QUERYBUFFER} .= $escFrag; # and cache it
2668             }
2669             }
2670 0 0         return unless $$bufRef =~ s/\Q$VT100_QueryDeviceStatus\E//go;
2671             # A Query Device Status escape sequence was found and removed from output buffer
2672 0           $self->_put($pkgsub, \$VT100_ReportDeviceOk); # Send a Report Device OK escape sequence
2673 0           return;
2674             }
2675              
2676              
2677             sub _newlineTranslation { # Modified _interpret_cr() method from Net::Telnet; converts CR LF back into newlines upon reading data stream
2678 0     0     my ($self, $bufRef) = @_;
2679 0           my $pos = 0;
2680 0           my $nextchar;
2681              
2682 0 0         if (length $self->{PUSHBACKCR}) { # If an ending CR character was cashed
2683 0           $$bufRef = join('', $self->{PUSHBACKCR}, $$bufRef); # prepend it to new output
2684 0           $self->{PUSHBACKCR} = '';
2685             }
2686 0           while (($pos = index($$bufRef, "\015", $pos)) > -1) {
2687 0           $nextchar = substr($$bufRef, $pos + 1, 1);
2688 0 0         if ($nextchar eq "\012") { # Convert CR LF to newline
    0          
2689 0           substr($$bufRef, $pos, 2) = "\n";
2690             }
2691             elsif (!length($nextchar)) { # Save CR in alt buffer for possible CR LF on next read
2692 0           $self->{PUSHBACKCR} .= "\015";
2693 0           chop $$bufRef;
2694             }
2695 0           $pos++;
2696             }
2697 0           return;
2698             }
2699              
2700              
2701             sub _read_buffer { # Internal method to read (and clear) any data cached in object buffer
2702 0     0     my ($self, $returnRef) = @_;
2703 0           my $buffer = $self->{BUFFER};
2704 0           $self->{BUFFER} = '';
2705             # $buffer will always be defined; worst case an empty string
2706 0 0         return $returnRef ? \$buffer : $buffer;
2707             }
2708              
2709              
2710             sub _read_blocking { # Internal read method; data must be read or we timeout
2711 0     0     my ($self, $pkgsub, $timeout, $returnRef) = @_;
2712 0           my ($buffer, $startTime);
2713              
2714 0           until (length $buffer) {
2715 0           $startTime = time; # Record start time
2716 0 0         if ($self->{TYPE} eq 'TELNET') {
    0          
    0          
2717 0           $buffer = $self->{PARENT}->get(Timeout => $timeout);
2718 0 0         return $self->error("$pkgsub: Received eof from connection") if $self->eof;
2719 0 0         return $self->error("$pkgsub: Telnet ".$self->{PARENT}->errmsg) unless defined $buffer;
2720             }
2721             elsif ($self->{TYPE} eq 'SSH') {
2722 0 0         return $self->error("$pkgsub: No SSH channel to read from") unless defined $self->{SSHCHANNEL};
2723 0           $self->{SSHCHANNEL}->read($buffer, $self->{read_block_size});
2724 0 0 0       unless (defined $buffer && length $buffer) {
2725 0 0         return $self->error("$pkgsub: Received eof from connection") if $self->eof;
2726 0           my @poll = { handle => $self->{SSHCHANNEL}, events => ['in'] };
2727 0 0 0       unless ($self->{PARENT}->poll($timeout*1000, \@poll) && $poll[0]->{revents}->{in}) {
2728 0           return $self->error("$pkgsub: SSH read timeout");
2729             }
2730 0           my $inBytes = $self->{SSHCHANNEL}->read($buffer, $self->{read_block_size});
2731 0 0         return $self->error("$pkgsub: SSH channel read error") unless defined $inBytes;
2732             }
2733             }
2734             elsif ($self->{TYPE} eq 'SERIAL') {
2735 0 0         return $self->error("$pkgsub: Received eof from connection") if $self->{SERIALEOF};
2736 0 0         if ($^O eq 'MSWin32') { # Win32::SerialPort
2737 0           my $inBytes;
2738             # Set timeout in millisecs
2739 0     0     local $SIG{__WARN__} = sub {}; # Disable carp from Win32::SerialPort
2740 0 0         $self->{PARENT}->read_const_time($timeout == 0 ? 1 : $timeout * 1000) or do {
    0          
2741 0           $self->{PARENT}->close;
2742 0           $self->{SERIALEOF} = 1;
2743 0           return $self->error("$pkgsub: Unable to read serial port");
2744             };
2745 0           ($inBytes, $buffer) = $self->{PARENT}->read($self->{read_block_size});
2746 0 0         return $self->error("$pkgsub: Serial Port read timeout") unless $inBytes;
2747             }
2748             else { # Device::SerialPort; we handle polling ourselves
2749             # Wait defined millisecs during every read
2750 0 0         $self->{PARENT}->read_const_time($PollTimer) or do {
2751 0           $self->{PARENT}->close;
2752 0           $self->{SERIALEOF} = 1;
2753 0           return $self->error("$pkgsub: Unable to read serial port");
2754             };
2755 0           my $inBytes;
2756 0           my $ticks = 0;
2757 0           my $ticksTimeout = $timeout*$PollTimer/10;
2758 0           do {
2759 0 0         if ($ticks++ > $ticksTimeout) {
2760 0           return $self->error("$pkgsub: Serial port read timeout");
2761             }
2762 0           ($inBytes, $buffer) = $self->{PARENT}->read($self->{read_block_size});
2763             } until $inBytes > 0;
2764             }
2765             }
2766             else {
2767 0           return $self->error("$pkgsub: Invalid connection mode");
2768             }
2769             # Check for Query Device Status escape sequences and process a reply if necessary
2770 0 0         if ($self->{report_query_status}){
2771 0           $self->_check_query($pkgsub, \$buffer);
2772 0 0         unless (length $buffer) { # If buffer was just a Query Device Status escape sequence we now have an empty buffer
2773 0           $timeout -= (time - $startTime); # Re-calculate a reduced timeout value, to perform next read cycle
2774 0 0         return $self->error("$pkgsub: Read timeout with report_query_status active") if $timeout <= 0;
2775             }
2776             }
2777             }
2778             # Perform newline translation if binmode is not enabled
2779 0 0         $self->_newlineTranslation(\$buffer) unless $self->{binmode};
2780              
2781             # Input logging
2782 0 0         _log_print($self->{INPUTLOGFH}, \$buffer) if defined $self->{INPUTLOGFH};
2783 0 0         _log_dump('<', $self->{DUMPLOGFH}, \$buffer) if defined $self->{DUMPLOGFH};
2784              
2785             # $buffer should always be a defined, non-empty string
2786 0 0         return $returnRef ? \$buffer : $buffer;
2787             }
2788              
2789              
2790             sub _read_nonblocking { # Internal read method; if no data available return immediately
2791 0     0     my ($self, $pkgsub, $returnRef) = @_;
2792 0           my $buffer;
2793              
2794 0 0         if ($self->{TYPE} eq 'TELNET') {
    0          
    0          
2795 0           $buffer = $self->{PARENT}->get(Timeout => 0);
2796 0 0         return $self->error("$pkgsub: Received eof from connection") if $self->eof;
2797 0 0         $buffer = '' unless defined $buffer;
2798             }
2799             elsif ($self->{TYPE} eq 'SSH') {
2800 0 0         return $self->error("$pkgsub: No SSH channel to read from") unless defined $self->{SSHCHANNEL};
2801 0           $self->{SSHCHANNEL}->read($buffer, $self->{read_block_size});
2802             # With Net::SSH2 0.58 & libssh2 1.5.0 line below was not necessary, as an emty read would leave $buffer defined and empty
2803             # But with Net::SSH2 0.63 & libssh2 1.7.0 this is no longer the case; now an empty read returns undef as both method return value and $buffer
2804 0 0         $buffer = '' unless defined $buffer;
2805             }
2806             elsif ($self->{TYPE} eq 'SERIAL') {
2807 0 0         return $self->error("$pkgsub: Received eof from connection") if $self->{SERIALEOF};
2808 0           my $inBytes;
2809 0     0     local $SIG{__WARN__} = sub {}; # Disable carp from Win32::SerialPort
2810             # Set timeout to nothing (1ms; Win32::SerialPort does not like 0)
2811 0 0         $self->{PARENT}->read_const_time(1) or do {
2812 0           $self->{PARENT}->close;
2813 0           $self->{SERIALEOF} = 1;
2814 0           return $self->error("$pkgsub: Unable to read serial port");
2815             };
2816 0           ($inBytes, $buffer) = $self->{PARENT}->read($self->{read_block_size});
2817 0 0         return $self->error("$pkgsub: Serial port read error") unless defined $buffer;
2818             }
2819             else {
2820 0           return $self->error("$pkgsub: Invalid connection mode");
2821             }
2822              
2823 0 0         if (length $buffer) {
2824             # Check for Query Device Status escape sequences and process a reply if necessary
2825 0 0         $self->_check_query($pkgsub, \$buffer) if $self->{report_query_status};
2826              
2827             # Perform newline translation if binmode is not enabled
2828 0 0         $self->_newlineTranslation(\$buffer) unless $self->{binmode};
2829              
2830             # Input logging
2831 0 0         _log_print($self->{INPUTLOGFH}, \$buffer) if defined $self->{INPUTLOGFH};
2832 0 0         _log_dump('<', $self->{DUMPLOGFH}, \$buffer) if defined $self->{DUMPLOGFH};
2833             }
2834              
2835             # Pre-pend local buffer if not empty
2836 0 0         $buffer = join('', $self->_read_buffer(0), $buffer) if length $self->{BUFFER};
2837              
2838             # If nothing was read, $buffer should be a defined, empty string
2839 0 0         return $returnRef ? \$buffer : $buffer;
2840             }
2841              
2842              
2843             sub _put { # Internal write method
2844 0     0     my ($self, $pkgsub, $outref) = @_;
2845 0           my $outlog;
2846              
2847 0 0         return $self->error("$pkgsub: No connection to write to") if $self->eof;
2848              
2849             # Output logging to occur before newline conversion
2850 0 0 0       if (defined $self->{OUTPUTLOGFH} || defined $self->{DUMPLOGFH}) {
2851 0           $outlog = $$outref; # So we hold a copy of the buffer, and actually log it after successful transmission
2852             }
2853              
2854             # Convert native newlines to CR LF if not in binmode
2855 0 0         $$outref =~ s/\n/\015\012/g unless $self->{binmode};
2856              
2857 0 0         if ($self->{TYPE} eq 'TELNET') {
    0          
    0          
2858             $self->{PARENT}->put(
2859             String => $$outref,
2860             Telnetmode => $self->{TELNETMODE},
2861 0 0         ) or return $self->error("$pkgsub: Telnet ".$self->{PARENT}->errmsg);
2862             }
2863             elsif ($self->{TYPE} eq 'SSH') {
2864 0 0         return $self->error("$pkgsub: No SSH channel to write to") unless defined $self->{SSHCHANNEL};
2865 0           print {$self->{SSHCHANNEL}} $$outref;
  0            
2866             }
2867             elsif ($self->{TYPE} eq 'SERIAL') {
2868 0           my $countOut = $self->{PARENT}->write($$outref);
2869 0 0         return $self->error("$pkgsub: Serial port write failed") unless $countOut;
2870 0 0         return $self->error("$pkgsub: Serial port write incomplete") if $countOut != length($$outref);
2871             }
2872             else {
2873 0           return $self->error("$pkgsub: Invalid connection mode");
2874             }
2875              
2876             # Output logging
2877 0 0         if (defined $outlog) {
2878 0 0         _log_print($self->{OUTPUTLOGFH}, \$outlog) if defined $self->{OUTPUTLOGFH};
2879 0 0         _log_dump('>', $self->{DUMPLOGFH}, \$outlog) if defined $self->{DUMPLOGFH};
2880             }
2881 0           $self->{WRITEFLAG} = 1;
2882 0           return 1;
2883             }
2884              
2885              
2886             sub _log_print { # Print output to log file (input, output or dump); taken from Net::Telnet
2887 0     0     my ($fh, $dataRef) = @_;
2888              
2889 0           local $\ = '';
2890 0 0 0       if (ref($fh) and ref($fh) ne "GLOB") { # fh is blessed ref
2891 0           $fh->print($$dataRef);
2892             }
2893             else { # fh isn't blessed ref
2894 0           print $fh $$dataRef;
2895             }
2896 0           return 1;
2897             }
2898              
2899              
2900             sub _log_dump { # Dump log procedure; copied and modified directly from Net::Telnet for use with SSH/Serial access
2901 0     0     my ($direction, $fh, $dataRef) = @_;
2902 0           my ($hexvals, $line);
2903 0           my ($addr, $offset) = (0, 0);
2904 0           my $len = length($$dataRef);
2905              
2906             # Print data in dump format.
2907 0           while ($len > 0) { # Convert up to the next 16 chars to hex, padding w/ spaces.
2908 0 0         if ($len >= 16) {
2909 0           $line = substr($$dataRef, $offset, 16);
2910             }
2911             else {
2912 0           $line = substr($$dataRef, $offset, $len);
2913             }
2914 0           $hexvals = unpack("H*", $line);
2915 0           $hexvals .= ' ' x (32 - length $hexvals);
2916              
2917             # Place in 16 columns, each containing two hex digits.
2918 0           $hexvals = sprintf("%s %s %s %s " x 4, unpack("a2" x 16, $hexvals));
2919              
2920             # For the ASCII column, change unprintable chars to a period.
2921 0           $line =~ s/[\000-\037,\177-\237]/./g;
2922              
2923             # Print the line in dump format.
2924 0           _log_print($fh, \sprintf("%s 0x%5.5lx: %s%s\n", $direction, $addr, $hexvals, $line));
2925              
2926 0           $addr += 16;
2927 0           $offset += 16;
2928 0           $len -= 16;
2929             }
2930 0 0         _log_print($fh, \"\n") if $$dataRef;#" Ultraedit hack!
2931 0           return 1;
2932             }
2933              
2934              
2935             sub _error_format { # Format the error message
2936 0     0     my ($msgFormat, $errmsg) = @_;
2937              
2938 0 0         return ucfirst $errmsg if $msgFormat =~ /^\s*verbose\s*$/i;
2939 0           $errmsg =~ s/\s+\/\/\s+.*$//;
2940 0 0 0       return ucfirst $errmsg if $msgFormat =~ /^\s*default\s*$/i || $msgFormat !~ /^\s*terse\s*$/i;
2941 0           $errmsg =~ s/^(?:[^:]+::)+[^:]+:\s+//;
2942 0           return ucfirst $errmsg; # terse
2943             }
2944              
2945              
2946             sub _error { # Internal method to perfom error mode action
2947 0     0     my ($fileName, $lineNumber, $mode, $errmsg, $msgFormat) = @_;
2948              
2949 0           $errmsg = _error_format($msgFormat, $errmsg);
2950              
2951 0 0         if (defined $mode) {
2952 0 0         if (ref($mode)) {
2953 0           callCodeRef($mode, $errmsg);
2954 0           return;
2955             }
2956 0 0         return if $mode eq 'return';
2957 0 0         croak "\n$errmsg" if $mode eq 'croak';
2958 0 0         die "\n$errmsg at $fileName line $lineNumber\n" if $mode eq 'die';
2959             }
2960             # Else (should never happen..)
2961 0           croak "\nInvalid errmode! Defaulting to croak\n$errmsg";
2962             }
2963              
2964              
2965             sub _call_poll_method { # Call object's poll method and optionally alter and then restore its error mode in doing so
2966 0     0     my ($self, $timeCredit, $errmode) = @_;
2967 0           my $errmodecache;
2968              
2969 0 0         unless ($self->{POLLREPORTED}) {
2970 0 0         if (defined $errmode) { # Store object's poll errormode and replace it with new error mode
2971 0           $errmodecache = $self->{POLL}{errmode};
2972 0           $self->{POLL}{errmode} = $errmode;
2973             }
2974 0 0 0       if ($timeCredit > 0 && defined $self->{POLL}{endtime}) { # We are going to increase the object's timeout by a credit amount
2975 0           $self->{POLL}{endtime} = $self->{POLL}{endtime} + $timeCredit;
2976 0           $self->debugMsg(1," - Timeout Credit of : ", \$timeCredit, " seconds\n");
2977             }
2978 0 0         $self->debugMsg(1," - Timeout Remaining : ", \($self->{POLL}{endtime} - time), " seconds\n") if defined $self->{POLL}{endtime};
2979             }
2980              
2981             # Call object's poll method
2982 0           my $ok = $self->{POLL}{coderef}->($self);
2983              
2984 0 0         unless ($self->{POLLREPORTED}) {
2985 0 0         $self->debugMsg(1," - Error: ", \$self->errmsg, "\n") unless defined $ok;
2986             # Restore original object poll error mode if necessary
2987 0 0         $self->{POLL}{errmode} = $errmodecache if defined $errmode;
2988             }
2989 0           return $ok;
2990             }
2991              
2992              
2993             sub _setup_telnet_option { # Sets up specified telnet option
2994 0     0     my ($self, $telobj, $option) = @_;
2995              
2996 0           $self->{PARENT}->option_accept(Do => $option);
2997 0           my $telcmd = "\377\373" . pack("C", $option); # will command
2998 0           $telobj->{unsent_opts} .= $telcmd;
2999 0 0 0       Net::Telnet::_log_option($telobj->{opt_log}, "SENT", "Will", $option) if defined &Net::Telnet::_log_option && $telobj->{opt_log};
3000 0           $self->debugMsg(1,"Telnet Option ", \$Net::Telnet::Telopts[$option], " Accept-Do + Send-Will\n");
3001 0           return;
3002             }
3003              
3004              
3005             sub _handle_telnet_options { # Sets up telnet options if we need them
3006 0     0     my $self = shift;
3007 0           my $telobj = *{$self->{PARENT}}->{net_telnet};
  0            
3008              
3009 0 0         _setup_telnet_option($self, $telobj, &TELOPT_TTYPE) if defined $self->{terminal_type}; # Only if a terminal type set for object
3010 0 0         _setup_telnet_option($self, $telobj, &TELOPT_NAWS) if @{$self->{window_size}}; # Only if a window size set for object
  0            
3011              
3012             # Send WILL for options now
3013 0 0 0       Net::Telnet::_flush_opts($self->{PARENT}) if defined &Net::Telnet::_flush_opts && length $telobj->{unsent_opts};
3014 0           return;
3015             }
3016              
3017             sub _telnet_opt_callback { # This is the callback setup for dealing with Telnet option negotiation
3018 0     0     my ($telslf, $option, $is_remote, $is_enabled, $was_enabled, $opt_bufpos) = @_;
3019 0           my $telobj = *$telslf->{net_telnet};
3020 0           my $self = $telobj->{$Package}; # Retrieve our object that we planted within the Net::Telnet one
3021              
3022 0 0 0       if ($option == &TELOPT_NAWS && @{$self->{window_size}}) {
  0            
3023 0           my $telcmd = pack("C9", &TELNET_IAC, &TELNET_SB, &TELOPT_NAWS, 0, $self->{window_size}->[0], 0, $self->{window_size}->[1], &TELNET_IAC, &TELNET_SE);
3024             # We activated option_accept for TELOPT_NAWS, so Net::Telnet queues a WILL response; but we already sent a Will in _setup_telnet_option
3025 0           my $telrmv = pack("C3", &TELNET_IAC, &TELNET_WILL, &TELOPT_NAWS);
3026 0           $telobj->{unsent_opts} =~ s/$telrmv/$telcmd/; # So replace WILL response queued by Net::Telnet with our SB response
3027 0 0 0       if (defined &Net::Telnet::_log_option && $telobj->{opt_log}) { # Net::Telnet already added a SENT WILL in the option log, so rectify
3028 0           Net::Telnet::_log_option($telobj->{opt_log}, "Not-SENT", "WILL", $option) ;
3029 0           Net::Telnet::_log_option($telobj->{opt_log}, "Instead-SENT(".join(' x ', @{$self->{window_size}}).")", "SB", $option);
  0            
3030             }
3031 0           $self->debugMsg(1,"Telnet Option Callback TELOPT_NAWS; sending sub-option negotiation ", \join(' x ', @{$self->{window_size}}), "\n");
  0            
3032             }
3033 0           return 1;
3034             }
3035              
3036              
3037             sub _telnet_subopt_callback { # This is the callback setup for dealing with Telnet sub-option negotiation
3038 0     0     my ($telslf, $option, $parameters) = @_;
3039 0           my $telobj = *$telslf->{net_telnet};
3040 0           my $self = $telobj->{$Package}; # Retrieve our object that we planted within the Net::Telnet one
3041              
3042             # Integrate with Net::Telnet's option_log
3043 0 0 0       Net::Telnet::_log_option($telobj->{opt_log}, "RCVD", "SB", $option) if defined &Net::Telnet::_log_option && $telobj->{opt_log};
3044              
3045             # Terminal type
3046 0 0 0       if ($option == &TELOPT_TTYPE && defined $self->{terminal_type}) {
3047 0           my $telcmd = pack("C4 A* C2", &TELNET_IAC, &TELNET_SB, &TELOPT_TTYPE, 0, $self->{terminal_type}, &TELNET_IAC, &TELNET_SE);
3048 0           $telobj->{unsent_opts} .= $telcmd;
3049 0 0 0       Net::Telnet::_log_option($telobj->{opt_log}, "SENT($self->{terminal_type})", "SB", $option) if defined &Net::Telnet::_log_option && $telobj->{opt_log};
3050 0           $self->debugMsg(1,"Telnet SubOption Callback TELOPT_TTYPE; sending ", \$self->{terminal_type}, "\n");
3051             }
3052             # Window Size
3053 0 0 0       if ($option == &TELOPT_NAWS && @{$self->{window_size}}) {
  0            
3054 0           my $telcmd = pack("C9", &TELNET_IAC, &TELNET_SB, &TELOPT_NAWS, 0, $self->{window_size}->[0], 0, $self->{window_size}->[1], &TELNET_IAC, &TELNET_SE);
3055 0           $telobj->{unsent_opts} .= $telcmd;
3056 0 0 0       Net::Telnet::_log_option($telobj->{opt_log}, "SENT(".join(' x ', @{$self->{window_size}}).")", "SB", $option) if defined &Net::Telnet::_log_option && $telobj->{opt_log};
  0            
3057 0           $self->debugMsg(1,"Telnet SubOption Callback TELOPT_NAWS; sending ", \join(' x ', @{$self->{window_size}}), "\n");
  0            
3058             }
3059 0           return 1;
3060             }
3061              
3062              
3063             1;
3064             __END__;