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")
Related
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
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 want to replace existing print STDERR statements in my codebase.
Apparently, I find them not very suitable to eyes, or is it just me. Should I be using warn knowing that It will be caught by $SIG{_WARN_} handler. Or is there any better option. And if yes, why use those options and not print STDERR.
The benefit of print STDERR is that you can see at once what will happen—you print something to STDERR. This may be a debug message, or something.
The warn function is slightly different:
It will trigger the warn handlers, and
it will append the line number, if you don't end with a newline.
You should probably use this for warnings, not for logging data
You might be also interested in the Carp family of functions. carp works like warn, but reports the line number/file from the point of call. cluck will warn with a stack trace.
But nothing prevents you from rolling your own. A functionally equivalent sub to print STDERR would be:
sub debug { print STDERR #_ }
You can now literally s/print STDERR/debug/g your source, except for that one occurence. Also, you will have to declare or import that debug function before you use it if you want to be able to leave out the parens around the arguments.
debug "this ", "is ", "DATA";
Point to consider: calling a sub is slooow, whereas print is a built-in opcode. You can trade beauty for performance, and vice versa.
Creating a debug subroutine to wrap print STDERR would give you a lot of flexibility above and beyond what simple print or warn statements provide, such as the ability to turn debugging messages off or redirect them to different destinations. For example, just off the top of my head:
sub debug {
my ($msg, %param) = #_;
$param{level} //= 1; # default if no level specified
return if $param{level} < $config{log_level};
given ($param{dest}) {
when ('mail') { send_email_to_admin(subject => "Application Error!", body => $msg) }
when ('log') { write_to_logfile($msg) }
default { print STDERR $msg }
}
}
debug('foo'); # goes to STDERR by default
$config{log_level} = 2;
debug('bar'); # message is ignored as unimportant at current logging level
debug('bar', level => 3, dest => mail); # still important; gets emailed to admin
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.
I am writing a Perl module, and I am using carp to throw a non-fatal warning back to the calling program.
The carp warning works fine - I am checking if an input parameter meets a certain condition - if it does not meet the condition, a warning is sent with carp and the module continues on using a default for the parameter instead of the one the calling program passed. The warning is just to notify that a default parameter is being used instead of the passed in parameter.
My problem is with my test script. My test script is sending in a bad parameter to the module, and I am trying to catch the warning message that comes back and make sure I got the correct warning message.
My module looks something like this:
else {
carp "value must be numeric - using default value";
}
and my test script looks like this:
eval {
#call to my module
};
like (
$#,
qr/value must be numeric/,
"Should abort on non-numeric value"
);
When I run the test, I can see the warning (it must be going to STDERR) on the screen, but the contents of the $# variable is '' - blank.
Here is the output from my test script:
t/04bad_method_calls....ok 10/12value must be numeric - using default value at ...
# Failed test 'Should abort on non-numeric value'
# at t/04bad_method_calls.t line 98.
t/04bad_method_calls....NOK 12
# '' doesn't match '(?-xism:value must be numeric)'
# Looks like you failed 1 test of 12.
If I change the carp to a croak, my test script works - it catches the error message (but I only want to warn, not abort).
To be honest, I don't have the best understanding of eval - maybe that is not the best way to catch the warning output from carp. I tried using $SIG{__WARN__}, but that was empty as well.
Is there any way to capture the output from carp? It's not the biggest deal since this is just in my test script, but I'd still like to get my test script to work properly.
Thanks in advance!
From this page, http://perldoc.perl.org/perlvar.html, it looks like you want to set the local $SIG{__WARN__} to a subroutine that will turn warnings into fatal errors for your test script. The example they give is:
local $SIG{__WARN__} = sub { die $_[0] };
eval $proggie;
Another way how to catch warnings and also all STDERR output:
my $stderr = '';
{
local *STDERR;
open STDERR, '>', \$stderr;
do_stuf_here();
}
like( $stderr, qr/my result/, 'test stderr output' );
One can make fancy test function:
sub stderr_test (&$$) {
my ( $code, $pattern, $text ) = #_;
my $result = '';
{
local *STDERR;
open STDERR, '>', \$result;
$code->();
}
if ( UNIVERSAL::isa( $pattern, 'Regexp' ) ) {
like( $result, $pattern, $text );
}
else {
is( $result, $pattern, $text );
}
}
# usage
stderr_test {do_stuf_here} qr/my expected STDERR output/,
'stderr is like';
stderr_test {do_stuf_here} 'my expected STDERR output',
'stderr is exactly';
If you're doing this from a test script, you can use of the Test::* modules that capture output for you. I tend to like Test::Output.