I am using the following lib Net::SSH2
I can connect to my device and get the output OK in most case. Below is the relevant code:
sub logIntoDevice
{
my $self = shift;
my ($ssh2) = #_;
if(! $ssh2->connect($self->deviceIP))
{
say "Failed to connect to device:",$self->deviceIP;
$ssh2->disconnect();
exit 0;
}
if(! $ssh2->auth_password($self->usr, $self->pass))
{
say "Authentication Fail to ",$self->deviceIP;
$ssh2->disconnect();
exit 0;
}
my $channel = $ssh2->channel();
$channel->blocking(0);
$channel->shell();
return $channel;
}
sub sendCmd
{
my $self = shift;
my ($cmd,$channel) = #_;
my #cmdOutput;
print $channel "$cmd\n";
while (<$channel>)
{
chomp $_;
push(#cmdOutput, $_);
}
return #cmdOutput;
}
So below are the cmd i sent to the sub's. They work fine and the output is write to file OK.
$self->writeToFile($fileName,$self->sendCmd("show clock",$channel));
$self->writeToFile($fileName,$self->sendCmd("\n",$channel));
$self->writeToFile($fileName,$self->sendCmd("dir",$channel));
with the exception of when i sent the following cmd:
$self->writeToFile($fileName,$self->sendCmd("sh run",$channel));
the output of the cmd on the device using putty is:
sh run
Building configuration...
Current configuration : 16575 bytes
!
!
!Last configuration change at 16:37:19 CET+1 Sat Mar 15 2014
.....
but in the log file all you see is
sh run
Building configuration...
so the issue is the blank lines after the Building configuration output make the while (<$channel>) think its the end of the output.
My issue is I cant figure a way to loop through the data without using a While loop.
UPDATE
Ok come up with this solution but seems very clunky. must be a better way if doing this
sub sendCmd
{
my $self = shift;
my ($cmd,$channel) = #_;
my #cmdOutput;
my $currPrompt;
#get prompt. i am sure there is a better way!!! just cant figure it out
print $channel "\n";
while (<$channel>)
{
$currPrompt = $_;
}
print $channel "$cmd\n";
while(42)
{
my $inerOutput;
while (<$channel>)
{
chomp $_;
$inerOutput = $_;
push(#cmdOutput, $_);
}
if($inerOutput ne $currPrompt)
{
sleep(7);
}
else
{
last;
}
}
return #cmdOutput;
}
I don't think your issue is blank lines. Most likely, the issue is that you are using non-blocking mode, and it takes time for the device to perform the command. So you are getting an empty line (or an undef) after "Building configuration..." is read because there is no extra output produced yet.
I would use Net::SSH2's poll method with a timeout, which will let you know when there is something to read. If "sh run" takes substantially longer than other commands you are issuing, your sendCmd method needs to be aware of this, and allow more time to pass before it decides no more output is coming its way.
Alternatively, you can (as is the custom when using, for example, Net::Telnet) wait for more output until you see the prompt, whatever the prompt is for the device in question,
and then you will know that the command has finished its execution.
Net::SSH2->poll is deprecated as result of libss2_poll deprecation
Related
I'm attempting to use the Net::MQTT::Simple package from cpan. The following is a modified version of the 'Object oriented' example on the same cpan page:
use Net::MQTT::Simple;
my $mqtt = Net::MQTT::Simple->new("test.mosquitto.org");
#This doesn't actually execute
print "After new";
$mqtt->run(
"test" => sub {
my ($topic, $message) = #_;
die "The building's on fire" if $message > 150;
},
"#" => sub {
my ($topic, $message) = #_;
print "[$topic] $message\n";
},
);
My script never seems to connect or at least the print line never gets executed. No error is reported and the program just hangs. The sever name is correct as I can connect via the mosquitto_sub client.
I feel like I'm missing something obvious. Any ideas/pointers on why this would be hanging?
It actually does execute. You are not seeing the output of it because of buffering.
Either add a newline to print:
print "After new\n";
Or enable autoflush:
$| = 1;
print "After new";
(If you look at the code of Net::MQTT::Simple you'll see that there are no blocking operations in the constructor at all. It's waiting for the messages in $mqtt->run, I guess there are no messages matching the topics you are subscribing to, so it appears to be "stuck")
I'm having a really weird problem with this perl script. The basic point is that sometimes a file write/append doesn't happen. On a run of the program, either all of the writes will happen or none of them will. Here is the subroutine, with some comments:
sub process_svs {
my $F;
open($F, '<', $_[0]);
if($log_dups==1) {
open($dfh, '>>',"./duplicates.txt");
}
while (my $line = <$F>) {
chomp $line;
if($line =~ /somepattern/) {
if (! -e "somefile") {
copy("source","dest") or warn ("couldn't copy");
} elsif($log_dups==1) {
system("touch ./duplicates.txt"); # ghetto workaround
print $dfh "./".$_[0]."_files/".$1.",v already exists\n" or die("Couldn't write duplicate"); # problem line
}
}
}
close $F;
}
The print statements to stdout always work, but if I remove the touch ./duplicates.txt crap, nothing is written to duplicates.txt.
The other "weird" thing, is that earlier in the program, I create a directory with perl mkdir, and if the directory exists when the program is run, I don't need the workaround, the duplicates.txt writing works just fine. If I delete the directory, and let the program mkdir it, it doesn't work. Seems relevant, but I can't figure out how since the directory and the text file are not in the same location, or related in any way, that I can think of.
Additionally, I have run it through the debugger, and can see the write call being executed, but inspecting duplicates.txt immediately after the write shows nothing written.
Any possible reasons for this would be greatly appreciated.
If you want to see a modified, but more complete, version of the script, it is here:
use strict;
use warnings;
use File::Copy;
my $svs = $ARGV[0];
my $rhis_str = system("rhis $svs > ./tmp_history");
my $fh;
my $dfh;
my #versions;
my $all_revs = 0;
my $current_rev = "";
my $log_dups = 0;
sub process_svs {
my $F;
open($F, '<', $_[0]);
if($log_dups==1) {
open($dfh, '>>',"./duplicates.txt");
}
while (my $line = <$F>) {
chomp $line;
if($line =~ /something/) {
if (! -e "something") {
copy("source","dest") or warn ("couldn't copy ");
} elsif($log_dups==1) {
system("touch ./duplicates.txt"); # ghetto workaround
print $dfh "something already exists\n" or die("Couldn't write duplicate");
}
}
}
close $F;
}
for(my $i = 0; $i <= scalar #ARGV; $i++) {
my $arg = $ARGV[$i];
if($arg eq "-a") {
$all_revs = 1;
} elsif($arg eq "-r") {
$all_revs = 0;
$current_rev = $ARGV[$i+1];
} elsif($arg eq "--log-dups") {
$log_dups = 1;
}
}
open($fh, '<','./tmp_history') or die(">>> Failed to open ./tmp_history");;
mkdir "./".$svs."_files";
if($all_revs == 1) {
print ">>> Processing all revisions of ".$svs;
if($log_dups==1) {
print" (and logging duplicates)\n";
}
while(my $line = <$fh>) {
chomp $line;
if ($line =~ /something/) {
push #versions, $1;
}
}
}
system("some_cmd &>/dev/null");
process_svs($svs);
}
You're not checking to see if your files opened. This is a very, very basic mistake and you should fix this immediately. Either add or die $! after each open or, better yet, use autodie and it will take care of catching all IO exceptions for you and give you good, consistent error messages.
Most importantly, this will tell you why it failed to open. $! tells you why it failed. You don't have that in your check on print.
print $dfh "./".$_[0]."_files/".$1.",v already exists\n" or die("Couldn't write duplicate"); # problem line
You're checking if print failed, but you're not including $!. Either add $! like die "Couldn't write to duplicate: $!" or use autodie, remove the or die clause, and let autodie take care of it. I recommend the second.
I suspect you'll find that something else is deleting duplicates.txt between the open and the print.
The second thing that grabs my attention is here.
if($log_dups==1) {
open($dfh, '>>',"./duplicates.txt");
}
You're using a global variable $log_dups to decide whether or not to open the file for writing (and not checking if it succeeded). This should be a variable that gets passed into the function, it's just good programming practice. Later you decide whether to print to $dfh based on that global variable.
if (! -e "something") {
copy("source","dest") or warn ("couldn't copy ");
} elsif($log_dups==1) {
system("touch ./duplicates.txt"); # ghetto workaround
print $dfh "something already exists\n" or die("Couldn't write duplicate");
}
Because $log_dups is global it's possible something else is changing $log_dups between deciding to open duplicates.txt and writing to it. To avoid all these problems, and to make the code simpler, $log_dups should be an argument passed into the function.
Furthermore, the filehandle $dfh is inexplicably a global. Same problem, something else could be closing it. It will also not be automatically closed at the end of the function which might leave writes to duplicates.txt buffered until the program exits. $dfh should be a lexical.
Other problems...
my $rhis_str = system("rhis $svs > ./tmp_history");
$rhis_str will contain the exit status of the rhis program. I don't think that's what you want. You don't use this variable anyway.
There's no need to pass ./file to open, it's safe and easier to read to use just pass file. That it's in the current working directory is implied.
If you fix these basic problems and still have trouble, then edit your question with the revised code and we can look again.
How to end script without using using exit if using Perl FCGI. After searching for days the only solution I found is to jump at label in the main script. below is the code of the main index.fcgi.
$fcgi_requests = 0; # the number of requests this fcgi process handled.
$handling_request = 0;
$exit_requested = 0;
$app_quit_request = 0; # End the application but not the FCGI process
# workaround for known bug in libfcgi
while (($ignore) = each %ENV) { }
$fcgi_request = FCGI::Request();
#$fcgi_request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR, \%ENV, $socket);
sub sig_handler {
my ($callpackage, $callfile, $callline) = caller;
if ($app_quit_request) {
$app_quit_request = 0;
goto ABORTLABEL;
}
$exit_requested = 1;
exit(0) if !$handling_request;
}
$SIG{USR1} = \&sig_handler;
$SIG{TERM} = \&sig_handler;
$SIG{PIPE} = 'IGNORE';
#The goal of fast cgi is to load the program once, and iterate in a loop for every request.
while ($handling_request = ($fcgi_request->Accept() >= 0)) {
process_fcgi_request();
$handling_request = 0;
last if $exit_requested;
#exit if -M $ENV{SCRIPT_FILENAME} < 0; # Autorestart
}
$fcgi_request->Finish();
exit(0);
#=========================================================#
sub process_fcgi_request() {
$fcgi_requests++;
# dispatch current request
my_app();
$fcgi_request->Finish();
}
#=========================================================#
# let it think we are done, used by abort
ABORTLABEL:
$fcgi_request->Finish();
#=========================================================#
The main request is I want to stop the program execution from inside sub insidi modules that may be called by long depth for example inside a login function in a accounts module.
Of course I can not use exit because it will terminate the fcgi process, I tried all error and throw and try modules all use die which also ends the process. Of course I can use the return from each sub but this will require to rewrite the whole program for fcgi.
The normal way to model exceptions in Perl is to call die inside eval BLOCK, which catches the die and so doesn't terminate the process. It'll just terminate the eval and the program continues to run from immediately afterwards. As far as I've seen, the exception-handling modules on CPAN are mostly wrappers around this basic functionality to give it different syntax or make it easier to write catch blocks. Therefore I'm surprised these don't work for you. Did you actually try them or did you just assume die always kills the process? The name is slightly misleading, because it really means 'throw an exception'. Just if you do that outside an eval the interpreter catches it, and its only response is to terminate the process.
eval {
say "Hello world";
die;
say "Not printed";
};
say "Is printed";
You don't want to call exit inside an eval though. Nothing catches that.
I would recommend though rewriting the entire control flow for FCGI. The lifecycle of your code changes significantly, so you have to make a certain amount of modifications to make sure that variable re-use is working properly and you're not leaking memory. Often it's better to do that up front rather than spend days tracking down odd bugs later.
After several questions and deep research, I got this solution. This coding example allows you to return from any nested levels of calls. The module Scope::Upper is XS so it should be fast.
use Scope::Upper qw/unwind CALLER/;
sub level1 {
print "before level 1 \n";
level2();
print "after level 1 \n";
}
sub level2 {
print "before level 2 \n";
level3();
print "after level 2 \n";
}
sub level3 {
print "before level 3 \n";
level4();
print "after level 3 \n";
}
sub level4 {
print "before level 4 \n";
#unwind CALLER 2;
my #frame;
my $i;
#$i++ while #frame = caller($i);# and $frame[0] ne "main";
$i++ while #frame = caller($i);
#print "i=: $i \n";
#unwind CALLER (#frame ? $i : $i - 1);
unwind CALLER $i-1;
print "after level 4 \n";
}
print level1();
If you run this code the output will be:
before level 1
before level 2
before level 3
before level 4
You can return to any up level using:
my intLevel = 2;
unwind CALLER intLevel;
I am using Module::Pluggable to load modules from a given directory:
for my $module ( plugins() ) {
eval "use $module";
if ($#) {
my $error = (split(/\n/, $#))[0];
push #rplugin_errors, $error;
print STDOUT "Failed to load $module: $error\n";
} else {
print STDOUT "Loaded: $module\n";
my $mod = $module->new();
my $module_name = $mod->{name};
$classes{$module_name} = $mod;
}
}
This function can be called via a reload method elsewhere. But if a one of the modules I am trying to "use" throws an errors it's not loaded and the script is somewhat crippled.
I'd like to validate each module in plugins() before executing use. So Ideally I could do something like:
$error = 0;
for my $module ( plugins() ) {
eval TEST $module;
if ($#) {
print STDERR "$module failed. Will not continue";
$error = 1;
last;
}
}
if ($error == 0) {
for my $module ( plugins() ) {
use $module;
}
}
Change
eval TEST $module;
back to
eval "use $module";
Well, importing probably doesn't make sense here (or in your original code), so the following would be better:
eval "require $module";
I think you're overcomplicating this. Your code already includes a clause to test for errors in the use and report on them if any occur. (if ($#)... print STDOUT "Failed to load $module: $error\n";) According to your comment on ikegami's answer, your goal is that "If one fails, we halt and send a message stating the reload could not take place because of a module error." (Yes, I know you said your goal is to validate the modules before loading them. It isn't. Your goal is to halt if there's an error; you've just decided that pre-validation is the way to accomplish that. This is what we call an X-Y Problem.)
You're already detecting and reporting any errors that occur... You want to halt on error... So, when you detect an error, halt after reporting it.
if ($#) {
my $error = (split(/\n/, $#))[0];
push #rplugin_errors, $error;
die "Failed to load $module: $error\n";
} else {
EDIT:
I will try a better explication this time, this is the exact code from my script (sorry for all them coments, they are a result of your sugestions, and apear in the video below).
#use warnings;
#use Data::Dumper;
open(my $tmp_file, ">>", "/tmp/some_bad.log") or die "Can not open log file: $!\n";
#if( $id_client != "")
#allowed_locations = ();
#print $tmp_file "Before the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
if( $id_client )
{
# print $tmp_file "Start the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
# my $q = "select distinct id_location from locations inner join address using (id_db5_address) inner join zona_rural_detaliat using (id_city) where id_client=$id_client";
# my $st = &sql_special_transaction($sql_local_host, $sql_local_database, $sql_local_root, $sql_local_root_password, $q);
# print $tmp_file "Before the while loop: ref(st)='". ref($st) . "\n";
# while((my $id)=$st->fetchrow())
# {
# print $tmp_file "Row the while loop: ". Data::Dumper->Dump([$id]) . "";
# my $id = 12121212;
# push(#allowed_locations, $id);
# }
# print $tmp_file "After the while loop: ref(st)='". ref($st) . "\n";
# my($a) = 1;
#} else {
# my($a) = 0;
}
#print $tmp_file "After the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
close($tmp_file) or die "Can not close file: $!\n";
#&html_error(#allowed_locations);
First off all, somebody said that I should try to run it in command line, the script works fine in command line (no warnings, It was uncommented then), but when triyng to load in via apache in the browser it fails, please see this video where I captured the script behavior, what I tried to show in the video:
I have opened 2 tabs the first doesn't define the variable $id_client, the second defines the variable $id_client that is read from GET: ?id_client=36124 => $id_client = 36124; , both of them include the library in the video "locallib.pl"
When running the script with all the
new code commented the page loads
when uncoment the line that defines
the #allowed_locations = (); the
script fails
leave this definition and uncoment
the if block, and the definition of
my $a; in the if block; Now the script works fine when $id_client is
defined, but fails when $id_client
is not defined
Uncoment the else block and the
definition of my $a; in the else
block. Now the script works fine
with or without $id_client
now comment all the my $a;
definisions and comment the else
block, the script fails
but if I'm using open() to open
a file before the IF, and
close() to close it after the if it does't fail even if the IF block
is empty and event if there is no
else block
I have replicated all the steps when running the script in the command line, and the script worked after each step.
I know it sounds like something that cannot be the behavior of the script, but please watch the video (2 minutes), maybe you will notice something that I'm doing wrong there.
Using perl version:
[root#db]# perl -v
This is perl, v5.8.6 built for i386-linux-thread-mult
Somebody asked if I don't have a test server, answer: NO, my company has a production server that has multiple purposes, not only the web interface, and I cannot risk to update the kernel or the perl version, and cannot risk instaling any debuger, as the company owners say: "If it works, leave it alone", and for them the solution with my ($a); is perfect beacause it works, I'm asking here just for me, to learn more about perl, and to understand what is going wrong and what can I do better next time.
Thank you.
P.S. hope this new approach will restore some of my -1 :)
EDIT:
I had success starting the error logging, and found this in the error log after each step that resulted in a failure I got this messages:
[Thu Jul 15 14:29:19 2010] [error] locallib.pl did not return a true value at /var/www/html/rdsdb4/cgi-bin/clients/quicksearch.cgi line 2.
[Thu Jul 15 14:29:19 2010] [error] Premature end of script headers: quicksearch.cgi
What I found is that this code is at the end of the main code in the locallib.pl after this there are sub definitions, and locallib.pl is a library not a program file, so it's last statement must returns true. , a simple 1; statement at the end of the library ensures that (I put it after sub definitions to ensure that noobody writes code in the main after the 1;) and the problem was fixed.
Don't know why in CLI it had no problem ...
Maybe I will get a lot of down votes now ( be gentle :) ) , but what can I do ...and I hope that some newbies will read this and learn something from my mistake.
Thank you all for your help.
You need to explicitly check for definedness.
If you want to enter the loop when $client is defined,
use if ( defined $client ).
If you want to enter the loop when $client is defined and a valid integer,
use if ( defined $client && $client =~ /^-?\d+$/ ).
I assume it's an integer from the context, if it can be a float, the regex needs to be enhanced - there's a standard Perl library containing pre-canned regexes, including ones to match floats. If you require a non-negative int, drop -? from regex's start.
If you want to enter the loop when $client is defined and a non-zero (and assuming it shouldn't ever be an empty string),
use if ( $client ).
If you want to enter the loop when $client is defined and a valid non-zero int,
use if ( $client && $client =~ /^-?\d+$/ ).
Your #ids is "undef" when if condition is false, which may break the code later on if it relies on #ids being an array. Since you didn't actually specify how the script breaks without an else, this is the most likely cause.
Please see if this version works (use whichever "if" condition from above you need, I picked the last one as it appears to match the closest witrh the original code's intent - only enter for non-zero integers):
UPDATED CODE WITH DEBUGGING
use Data::Dumper;
open(my $tmp_file, ">", "/tmp/some_bad.log") or die "Can not open log file: $!\n";
#ids = (); # Do this first so #ids is always an array, even for non-client!
print $tmp_file "Before the if: ". Data::Dumper->Dump([\#ids, $client]) . "\n";
if ( $client && $client =~ /^-?\d+$/ ) # First expression catches undef and zero
{
print $tmp_file "Start the if: ". Data::Dumper->Dump([\#ids, $client]) . "\n";
my $st = &sql_query("select id from table where client=$client");
print $tmp_file "Before the while loop: ref(st)='". ref($st) . "'\n";
while(my $row = $st->fetchrow())
{
print $tmp_file "Row the while loop: ". Data::Dumper->Dump([row]) . "'\n";
push(#ids, $row->[0]);
}
print $tmp_file "After the while loop: ref(st)='". ref($st) . "'\n";
# No need to undef since both variables are lexically in this block only
}
print $tmp_file "After the if\n";
close($tmp_file) or die "Can not close file: $!\n";
when checking against a string, == and != should be respectively 'eq' or 'ne'
if( $client != "" )
should be
if( $client ne "" )
Otherwise you don't get what you're expecting to get.
Always begin your script with :
use warnings;
use strict;
these will give you usefull informations.
Then you could write :
my #ids;
if (defined $client) {
#ids = (); # not necessary if you run this part only once
my $st = sql_query("select id from table where client=$client");
while( my ($id) = $st->fetchrow ) {
push #ids, $id;
}
} else {
warn '$client not defined';
}
if (#ids) { # Your query returned something
# do stuff with #ids
} else {
warn "client '$client' does not exist in database";
}
Note: this answer was deleted because I consider that this is not a real question. I am undeleting it to save other people repeating this.
Instead of
if( $client != "" )
try
if ($client)
Also, Perl debugging is easier if you
use warnings;
use strict;
What I found is that this code is at the end of the main code in the locallib.pl after this there are sub definitions, and locallib.pl is a library not a program file, so it's last statement must returns true, a simple 1; statement at the end of the library ensures that (put it after sub definitions to ensure that noobody writes code in the main after the 1;) and the problem was fixed.
The conclusion:
I have learned that every time you write a library or modify one, ensure that it's last statment returns true;
Oh my... Try this as an example instead...
# Move the logic into a subroutine
# Forward definition so perl knows func exists
sub getClientIds($);
# Call subroutine to find id's - defined later.
my #ids_from_database = &getClientIds("Joe Smith");
# If sub returned an empty list () then variable will be false.
# Otherwise, print each ID we found.
if (#ids_from_database) {
foreach my $i (#ids_from_database) {
print "Found ID $i \n";
}
} else {
print "Found nothing! \n";
}
# This is the end of the "main" code - now we define the logic.
# Here's the real work
sub getClientIds($) {
my $client = shift #_; # assign first parameter to var $client
my #ids = (); # what we will return
# ensure we weren't called with &getClientIds("") or something...
if (not $client) {
print "I really need you to give me a parameter...\n";
return #ids;
}
# I'm assuming the query is string based, so probably need to put it
# inside \"quotes\"
my $st = &sql_query("select id from table where client=\"$client\"");
# Did sql_query() fail?
if (not $st) {
print "Oops someone made a problem in the SQL...\n";
return #ids;
}
my #result;
# Returns a list, so putting it in a list and then pulling the first element
# in two steps instead of one.
while (#result = $st->fetchrow()) {
push #ids, $result[0];
}
# Always a good idea to clean up once you're done.
$st->finish();
return #ids;
}
To your specific questions:
If you want to test if $client is defined, you want "if ( eval { defined $client; } )", but that's almost certainly NOT what you're looking for! It's far easier to ensure $client has some definition early in the program (e.g. $client = "";). Also note Kaklon's answer about the difference between ne and !=
if (X) { stuff } else { } is not valid perl. You could do: if (X) { stuff } else { 1; } but that's kind of begging the question, because the real issue is the test of the variable, not an else clause.
Sorry, no clue on that - I think the problem's elsewhere.
I also echo Kinopiko in recommending you add "use strict;" at the start of your program. That means that any $variable #that %you use has to be pre-defined as "my $varable; my #that; my %you;" It may seem like more work, but it's less work than trying to deal with undefined versus defined variables in code. It's a good habit to get into.
Note that my variables only live within the squiggliez in which they are defined (there's implicit squiggliez around the whole file:
my $x = 1;
if ($x == 1)
{
my $x = 2;
print "$x \n"; # prints 2. This is NOT the same $x as was set to 1 above.
}
print "$x \n"; # prints 1, because the $x in the squiggliez is gone.