log4perl run from within another package not firing messages sent through email - perl

I'm seeing behavior that I can't explain when using log4perl to send a message by email.
So the following test script works just fine and an email is sent without problems:
#!/usr/bin/perl
use strict;
use warnings;
use Log::Log4perl qw(:easy);
use Log::Dispatch;
my $appender_email = Log::Log4perl::Appender->new(
"Log::Dispatch::Email::SSMTP",
threshold => "INFO",
to => 'myemail#mail.com',
subject => 'Perl script message'
);
my $email_logger = get_logger();
$email_logger->level($INFO);
$email_logger->add_appender($appender_email);
$email_logger->info('hi');
The Log::Dispatch::Email::SSMTP is a module I wrote to send emails using the ssmtp command.
The weirdness begins when this same exact code is moved to another package in another file in the same directory as my original script. When I do that and use that package from within my original script, no email gets sent and there are no errors thrown.
However, if I change:
Log::Dispatch::Email::SSMTP
to
Log::Log4perl::Appender::Screen
It prints out "hi" to the screen just fine when I run my script.
So if log4perl works when sending the message to the screen, why doesn't it work when trying to send an email? And why does the same code fire an email from within the original script and not from a package? Again, there are no errors getting thrown or any kind of indication that something went wrong. And I have verified that my module gets loaded with print statements. So my module's code is definitely getting loaded but the email is still not firing.
UPDATE
Here is the code when it's not working per request in comments.
maillog.pl
#!/usr/bin/perl
BEGIN { unshift #INC, "/home/steve/perl/perl-lib" }
use strict;
use warnings;
use Testy;
print 'start' . "\n";
Here is the Testy.pm package:
package Testy;
BEGIN { unshift #INC, "/home/steve/perl/perl-lib" }
use strict;
use warnings;
use Log::Log4perl qw(:easy);
use Log::Dispatch;
print 'end' . "\n";
my $appender_email = Log::Log4perl::Appender->new(
"Log::Dispatch::Email::SSMTP",
#"Log::Log4perl::Appender::Screen",
threshold => "INFO",
to => 'myemail#mail.com',
subject => 'Perl script message'
);
my $email_logger = get_logger();
$email_logger->level($INFO);
$email_logger->add_appender($appender_email);
$email_logger->info('hi');
1;
And here is my SSMTP module located in /home/steve/perl/perl-lib/Log/Dispatch/Email/SSMTP:
package Log::Dispatch::Email::SSMTP;
use strict;
use warnings;
use Log::Dispatch::Email;
use Data::Dumper;
use base qw( Log::Dispatch::Email );
print "hi, i'm here!\n";
sub send_email {
my $self = shift;
my %p = #_;
my $to = escape ( join ',', #{$self->{to}} );
my $subject = $self->{subject};
my $message = $p{message};
$message =~ s/'/'\\''/g;
print $to . "\n";
print $subject . "\n";
print $message . "\n";
print "I'm working!";
system("echo 'To: $to\nFrom: \'Me\' <myemail\#gmail.com>\nSubject:$subject\n\n$message' | /usr/sbin/ssmtp $to");
}
sub escape {
my $address = shift;
$address =~ s/#/\\#/g;
return $address;
}
1;
When I run ./maillog.pl no email is sent when using the code in the Testy package (the same code works when in maillog.pl file. However, if I uncomment Log::Dispatch::Email::SSMTP and replace with Log::Log4perl::Appender::Screen it works.
UPDATE #2
If I change Log::Log4perl::Appender::Screen to Log::Dispatch::Screen it works as well. So maybe come kind of bug in Log::Dispatch::Email?

Found the problem with some help from the FAQ at click here
Apparently, there is some buffering going on so emails do not get sent out immediately until some threshold for the number of messages generated is reached. Though it's still a mystery to me as to why emails are sent immediately when the code is in the main package.
So here is the code that works with the buffered property set to 0:
my $appender_email = Log::Log4perl::Appender->new(
"Log::Dispatch::Email::SSMTP",
threshold => "INFO",
to => 'me#mymail.com',
buffered => 0,
subject => 'Perl script message'
);

Related

Perl failing to create cgi session

I have the code as shown below. A BEGIN which loads the session or, if none is yet created, it creates one. But it doesn't do it all the time. It's a login script; If I enter the PIN and it's wrong, the script displays the login form again, which is submitted to this same script. Up to 3 attempts permitted but, it will fail to load the session, usually on attempt 2. Inconsistent so, please can anyone see what might be wrong and why is the session sometimes not loading.
I do have warnings enabled and I have shown that in the code.
I used to start the script with 'print $session->header' but, having changed to 'print $cgi->header;' I can see clearly that the session is undefined, when the script fails. I should add that, if I refresh the failed page perhaps as many as 5 times, the session does eventually reload with all data intact.
#!/usr/bin/perl
#use CGI::Carp qw/warningsToBrowser fatalsToBrowser/;
use strict;
use warnings 'all';
use CGI qw(:all);
use CGI::Session;
use Crypt::PasswdMD5;
use DBI;
use Data::Dumper;
my $cgi = CGI->new;
my $session;
my $sessions_dir_location;
my $session_id;
BEGIN{
unshift #INC, "/var/www/vhosts/example.com/subDomain.example.com/cgi-bin/library";
my $document_root = $ENV{'DOCUMENT_ROOT'};
$document_root =~ s/\///;
my ( $var
, $www
, $vhosts
, $domain
) = split ('/', $document_root, 5);
$sessions_dir_location = '/' . $var . '/' . $www . '/' . $vhosts . '/' . $domain;
$session = CGI::Session->load() or die CGI::Session->errstr();
if ( $session->is_expired ) {
print $session->header(),
$cgi->start_html(),
$cgi->p("Your session timed out! Refresh the screen to start new session!"),
$cgi->end_html();
exit(0);
}
if ( $session->is_empty ) {
$session = new CGI::Session(undef, undef,
{Directory=>"$sessions_dir_location/sessions_storage/"}) or die CGI::Session->errstr;
}
#add the library dir to #INC;
use lib do {
use Cwd 'realpath';
my ($dir) = __FILE__ =~ m{^(.*)/};
realpath("$dir/library");
};
use feature 'say';
use FindBin '$RealBin';
use lib $RealBin;
use lib "$RealBin/library";
}
my $self = $cgi->url;
my %login = $cgi->Vars;
print $cgi->header;
# capture and display warnings
local $SIG{__WARN__} = sub {
my $message = shift;
print $cgi->header;
print qq($message);
};
print qq(<pre>);
print Dumper \%login;
print qq(</pre>);
print qq(<pre>session);
print Dumper \$session; #undef
print qq(</pre>);
#next is line 141
my $session_stored_user_name = $session->param("entered_user_name");
Error message is this:
Can't call method "param" on an undefined value at /var/www/vhosts/example.com/subDomain.example.com/cgi-bin/dashboard-login/login-with-pin.pl line 141, <DAT> line 45.
Please, also, what or where is <DAT> line 45?

HTML::TableExtract an HTTPS site

I've created a perl script to use HTML::TableExtract to scrape data from tables on a site.
It works great to dump out table data for unsecured sites (i.e. HTTP site), but when I try HTTPS sites, it doesn't work (the tables_report line just prints blank.. it should print a bunch of table data).
However, if I take the content of that HTTPS page, and save it to an html file and then post it on an unsecured HTTP site (and change my content to point to this HTTP page), this script works as expected.
Anyone know how I can get this to work over HTTPS?
#!/usr/bin/perl
use lib qw( ..);
use HTML::TableExtract;
use LWP::Simple;
use Data::Dumper;
# DOESN'T work:
my $content = get("https://datatables.net/");
# DOES work:
# my $content = get("http://www.w3schools.com/html/html_tables.asp");
my $te = HTML::TableExtract->new();
$te->parse($content);
print $te->tables_report(show_content=>1);
print "\n";
print "End\n";
The sites mentioned above for $content are just examples.. these aren't really the sites I'm extracting, but they work just like the site I'm really trying to scrape.
One option I guess is for me to use perl to download the page locally first and extract from there, but I'd rather not, if there's an easier way to do this (anyone that helps, please don't spend any crazy amount of time coming up with a complicated solution!).
The problem is related to the user agent that LWP::Simple uses, which is stopped at that site. Use LWP::UserAgent and set an allowed user agent, like this:
use strict;
use warnings;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
my $url = 'https://datatables.net/';
$ua->agent("Mozilla/5.0"); # set user agent
my $res = $ua->get($url); # send request
# check the outcome
if ($res->is_success) {
# ok -> I simply print the content in this example, you should parse it
print $res->decoded_content;
}
else {
# ko
print "Error: ", $res->status_line, "\n";
}
This is because datatables.net is blocking LWP::Simple requests. You can confirm this by using below code:
#!/usr/bin/perl
use strict;
use warnings;
use LWP::Simple;
print is_success(getprint("https://datatables.net/"));
Output:
$ perl test.pl
403 Forbidden <URL:https://datatables.net/>
You could try using LWP::RobotUA. Below code works fine for me.
#!/usr/bin/perl
use strict;
use warnings;
use LWP::RobotUA;
use HTML::TableExtract;
my $ua = LWP::RobotUA->new( 'bot_chankey/1.1', 'chankeypathak#stackoverflow.com' );
$ua->delay(5/60); # 5 second delay between requests
my $response = $ua->get('https://datatables.net/');
if ( $response->is_success ) {
my $te = HTML::TableExtract->new();
$te->parse($response->content);
print $te->tables_report(show_content=>1);
}
else {
die $response->status_line;
}
In the end, a combination of Miguel and Chankey's responses provided my solution. Miguel's made up most of my code, so I selected that as the answer, but here is my "final" code (got a lot more to do, but this is all I couldn't figure out.. the rest should be no problem).
I couldn't quite get either mentioned by Miguel/Chankey to work, but they got me 99% of the way.. then I just had to figure out how to get around the error "certificate verify failed". I found that answer with Miguel's method right away, so in the end, I mostly used his code, but both responses were great!
#!/usr/bin/perl
use lib qw( ..);
use strict;
use warnings;
use LWP::UserAgent;
use HTML::TableExtract;
use LWP::RobotUA;
use Data::Dumper;
my $ua = LWP::UserAgent->new(
ssl_opts => { SSL_verify_mode => 'SSL_VERIFY_PEER' },
);
my $url = 'https://WebsiteIUsedWasSomethingElse.com';
$ua->agent("Mozilla/5.0"); # set user agent
my $res = $ua->get($url); # send request
# check the outcome
if ($res->is_success)
{
my $te = HTML::TableExtract->new();
$te->parse($res->content);
print $te->tables_report(show_content=>1);
}
else {
# ko
print "Error: ", $res->status_line, "\n";
}
my $url = "https://ohsesfire01.summit.network/reports/slices";
my $user = 'xxxxxx';
my $pass = 'xxxxxx';
my $ua = new LWP::UserAgent;
my $request = new HTTP::Request GET=> $url;
# authenticate
$request->authorization_basic($user, $pass);
my $page = $ua->request($request);

Perl print line over Prompt

My script asks for download URLs and sends them to the download queue. The progress of the download should be printed back.
I don't find a way to keep the prompt on bottom and do the status over it.
I tried a search on CPAN, but I found no module for it.
#!/usr/bin/perl
use 5.14.0;
use strict;
use warnings;
use Term::UI;
use Term::ReadLine;
use threads;
use Thread::Queue;
sub rndStr{ join'', #_[ map{ rand #_ } 1 .. shift ] }
my $q = Thread::Queue->new(); # A new empty queue
my $thr = threads->create(
sub {
while (defined(my $item = $q->dequeue())) {
say "Downloading: ".$item;
sleep 1;
#$q->enqueue(1..10) if $item eq '10';
$q->enqueue(rndStr rand (15)+5, 'a'..'z', 0..9);
}
}
);
$q->enqueue(rndStr 10, 'a'..'z', 0..9);
my $url;
my $term = Term::ReadLine->new('brand');
while ($url ne 'end'){
$url = $term->get_reply(
prompt => 'URL to download',
default => 'end' );
$q->enqueue($url);
}
say "Finishing remaining downloads";
$q->enqueue(undef);
$thr->join();
The basic just of what you are trying to do is use ANSI codes to move the cursor around. Something such as ncurses (windows version) will allow you do this.
Alternatively you can do it yourself with raw ASCII/ANSI codes (as explained by these two links)
http://ascii-table.com/ansi-escape-sequences-vt-100.php
http://www.tldp.org/HOWTO/Bash-Prompt-HOWTO/x361.html
Or lastly you could use a Perl Module Win32::Console::ANSI which is designed to help you do this.
As this is a perl question I would suggest looking at Win32::Console::ANSI.
say adds a newline in the output; use print instead. Add a carriage return to write over previous output:
print "Downloading: ".$item."\r";

mojolicious script works three times, then crashes

The following script should demonstrate a problem I'm facing using Mojolicious on OpenBSD5.2 using mod_perl.
The script works fine 4 times being called as CGI under mod_perl. Additional runs of the script result in Mojolicious not returning the asynchronous posts. The subs that are usually called when data is arriving just don't seem to be called anymore. Running the script from command line works fine since perl is then completely started from scratch and everything is reinitialized, which is not the case under mod_perl. Stopping and starting Apache reinitializes mod_perl so that the script can be run another 4 times.
I only tested this on OpenBSD5.2 using Mojolicious in the version that's provided in OpenBSDs ports tree (2.76). This is kinda old I think but that's what OpenBSD comes with.
Am I doing something completely wrong here? Or is it possible that Mojolicious has some circular reference or something which causes this issue?
I have no influence on the platform (OpenBSD) being used. So please don't suggest to "use Linux and install latest Mojolicious version". However if you are sure that running a later version of Mojolicous will solve the problem, I might get the permission to install that (though I don't yet know how to do that).
Thanks in advance!
T.
Here's the script:
#!/usr/bin/perl
use diagnostics;
use warnings;
use strict;
use feature qw(switch);
use CGI qw/:param/;
use CGI qw/:url/;
use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
use Mojo::IOLoop;
use Mojo::JSON;
use Mojo::UserAgent;
my ($activeconnections, $md5, $cgi);
my $ua = Mojo::UserAgent->new;
$ua->max_redirects(0)->connect_timeout(3)->request_timeout(6); # Timeout 6 seconds of which 3 may be connecting
my $delay = Mojo::IOLoop->delay();
sub online{
my $url = "http://www.backgroundtask.eu/Systeemtaken/Search.php";
$delay->begin;
$activeconnections++;
my $response_bt = $ua->post_form($url, { 'ex' => $md5 }, sub {
my ($ua, $tx) = #_;
my $content=$tx->res->body;
$content =~ m/(http:\/\/www\.backgroundtask\.eu\/Systeemtaken\/taakinfo\/.*$md5\/)/;
if ($1){
print "getting $1\n";
my $response_bt2 = $ua->get($1, sub {
$delay->end();
$activeconnections--;
print "got result, ActiveConnections: $activeconnections\n";
($ua, $tx) = #_;
my $filename = $tx->res->dom->find('table.view')->[0]->find('tr.even')->[2]->td->[1]->all_text;
print "fn = " . $filename . "\n";
}
)
} else {
print "query did not return a result\n";
$activeconnections--;
$delay->end;
}
});
}
$cgi = new CGI;
print $cgi->header(-cache_control=>"no-cache, no-store, must-revalidate") . "\n";
$md5 = lc($cgi->param("md5") || ""); # read param
$md5 =~ s/[^a-f0-9]*//g if (length($md5) == 32); # custom input filter for md5 values only
if (length $md5 != 32) {
$md5=lc($ARGV[0]);
$md5=~ s/[^a-f0-9]*//g;
die "invalid MD5 $md5\n" if (length $md5 ne 32);
}
online;
if ($activeconnections) {
print "waiting..., activeconnections: $activeconnections\n" for $delay->wait;
}
print "all pending requests completed, activeconnections is " . $activeconnections . "\n";
print "script done.\n md5 was $md5\n";
exit 0;
Well I hate to say it, but there's a lot wrong here. The most glaring is your use of ... for $delay->wait which doesn't make much sense. Also you are comparing numbers with ne rather than !=. Not my-ing the arguments in the deeper callback seems problematic for async style code.
Then there are some code smells, like regexing for urls and closing over the $md5 variable unnecessarily.
Lastly, why use CGI.pm when Mojolicious can operate under CGI just fine? When you do that, the IOLoop is already running, so some things get easier. And yes I understand that you are using the system provided Mojolicious, however I feel I should mention that the current version is 3.93 :-)
Anyway, here is an example, which strips out a lot of things but still should do pretty much the same thing as the example. Of course I can't test it without a valid md5 for the site (and I also can't get rid of the url regex without sample data).
#!/usr/bin/perl
use Mojolicious::Lite;
use Mojo::UserAgent;
my $ua = Mojo::UserAgent->new;
$ua->max_redirects(0)->connect_timeout(3)->request_timeout(6); # Timeout 6 seconds of which 3 may be connecting
any '/' => sub {
my $self = shift;
$self->res->headers->cache_control("no-cache, no-store, must-revalidate");
my $md5 = lc($self->param("md5") || ""); # read param
$md5 =~ s/[^a-f0-9]*//g if (length($md5) == 32); # custom input filter for md5 values only
if (length $md5 != 32) {
$md5=lc($ARGV[0]);
$md5=~ s/[^a-f0-9]*//g;
die "invalid MD5 $md5\n" if (length $md5 != 32);
}
$self->render_later; # wait for ua
my $url = "http://www.backgroundtask.eu/Systeemtaken/Search.php";
$ua->post_form($url, { 'ex' => $md5 }, sub {
my ($ua, $tx) = #_;
my $content=$tx->res->body;
$content =~ m{(http://www\.backgroundtask\.eu/Systeemtaken/taakinfo/.*$md5/)};
return $self->render( text => 'Failed' ) unless $1;
$ua->get($1, sub {
my ($ua, $tx) = #_;
my $filename = $tx->res->dom->find('table.view')->[0]->find('tr.even')->[2]->td->[1]->all_text;
$self->render( text => "md5 was $md5, filename was $filename" );
});
});
};
app->start;

First use of $query in Perl IPN sample code causes a "not defined" error

After much research in books and articles about Perl, I have been unable to integrate the Perl IPN sample code into the Perl script for my website. Much of trouble seems to be coming from how certain variables are introduced and used. For example, the first active line of the sample is:
read (STDIN, $query, $ENV{'CONTENT_LENGTH'});
When this line is compiled, $query is flagged as being undefined so I tried preceding that line with:
my $query = "";
This caused an uninitialized error. I'm not sure if the context of my script, which is about a dozen other lines of code, is causing the problem or if I'm not understanding Perl variables. Though I've made money coding in about a dozen languages, this is my first Perl script so that's certainly possible.
I start my script with these lines and I'm not sure if they are contributing to the problem:
#!/usr/bin/perl
# This is the Buck A View package.
package BuckAViewMovie;
use strict;
use warnings;
use diagnostics;
use LWP::UserAgent;
print "Content-type: text/html;\n\n";
I would appreciate any guidance on how to solve these integration problems.
Yes, the PayPal IPN Perl sample script doesn't properly declare its variables, and therefore won't compile under use strict. Here's a cleaned-up version that ought to work:
#!/usr/bin/perl
use strict;
use warnings;
use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
use CGI ();
use LWP::UserAgent;
use constant PAYPAL_URL => 'https://www.paypal.com/cgi-bin/webscr';
# read post from PayPal system and add 'cmd'
my $q = CGI->new();
$q->param( cmd => '_notify-validate' );
# post back to PayPal system to validate
my $ua = LWP::UserAgent->new();
my $res = $ua->post( PAYPAL_URL, scalar $q->Vars );
# assign posted variables to local variables
my $item_name = $q->param('item_name');
my $item_number = $q->param('item_number');
my $payment_status = $q->param('payment_status');
my $payment_amount = $q->param('mc_gross');
my $payment_currency = $q->param('mc_currency');
my $txn_id = $q->param('txn_id');
my $receiver_email = $q->param('receiver_email');
my $payer_email = $q->param('payer_email');
if ($res->is_error) {
# HTTP error
}
elsif ($res->content eq 'VERIFIED') {
# check that $payment_status is 'Completed'
# check that $txn_id has not been previously processed
# check that $receiver_email is your Primary PayPal email
# check that $payment_amount/$payment_currency are correct
# process payment
}
elsif ($res->content eq 'INVALID') {
# log for manual investigation
}
else {
# error
}
# print result page
print "Content-type: text/html\n\n";
warningsToBrowser( 1 );
# ...
Or you could just use Business::PayPal::IPN like Sinan Ünür suggests.
Instead of trying to use PayPal's sample code, you could use Business::PayPal::IPN.
Some time ago, I started writing a replacement Business::PayPal::IPN::Modern, but I never finished it and the code is awful. Plus it doesn't even work in the PayPal sandbox.