File Coverage

blib/lib/Control/CLI.pm
Criterion Covered Total %
statement 81 1587 5.1
branch 44 1260 3.4
condition 4 282 1.4
subroutine 17 121 14.0
pod 93 93 100.0
total 239 3343 7.1


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