How do you specify timeout in perl get requests? - perl

I'm pretty new to Perl so I might be missing something obvious but; I'm debugging a bug and I've narrowed down the problem to the following piece of code.
my $fetch_urls = [];
for my $input_medium ( #{ $input_media } )
{
$input_medium->{ medium } = MediaWords::DBI::Media::Lookup::find_medium_by_url( $db, $input_medium->{ url } );
if ( $input_medium->{ medium } )
{
$input_medium->{ status } = 'existing';
}
else
{
if ( MediaWords::Util::URL::is_http_url( $input_medium->{ url } ) )
{
push( #{ $fetch_urls }, $input_medium->{ url } );
}
else
{
WARN "URL is not HTTP(s): " . $input_medium->{ url };
}
}
}
the piece of code is supposed to go through all the input_media which are URLs and check if it exists in the system if not it tries to check if the URL is valid using the is_http_url function (at least this is what I think it's doing). What I want to do is add a timeout after which if the URL hasn't responded, I push the message URL was unreachable
Any Ideas/suggestions will be highly appreciated.

Related

Redirect to different thank you pages on specific shipping method selection

I have two different shipping method on my WooCommerce site COD & local pickup, I want to redirect on two different thank you page depending on which shipping method the buyer choose. I tried this but its showing an error after purchase
add_action( 'template_redirect', 'woo_custom_redirect_after_purchase' );
function woo_custom_redirect_after_purchase() {
global $wp;
if ( is_checkout() && !empty( $wp->query_vars['order-received'] )) {
if( $order->has_shipping_method('flat_rate:21') ){
wp_redirect( 'mysite.com/thank-you-1/' );
exit;
}
elseif( $order->has_shipping_method('local_pickup:24') ) {
wp_redirect( 'mysite.com/thank-you-2/' );
exit;
}
}
}
You can use woocommerce_thankyou
add_action( 'woocommerce_thankyou', 'woo_custom_redirect_after_purchase');
function woo_custom_redirect_after_purchase( $order_id ){
$order = wc_get_order( $order_id );
if( $order->has_shipping_method('flat_rate:21') ){
wp_redirect( 'mysite.com/thank-you-1/' );
exit;
}elseif( $order->has_shipping_method('local_pickup:24') ) {
wp_redirect( 'mysite.com/thank-you-2/' );
exit;
}
}

reCAPTCHA V2 with FormMail.cgi (Matt's Script Archive)

I was previously using reCAPTCHA V1 in conjunction with FormMail.cgi from Matt's Script Archive, with the following Perl function to validate the reCAPTCHA response:
sub check_captcha {
my $ua = LWP::UserAgent->new();
my $result=$ua->post(
'http://www.google.com/recaptcha/api/verify',
{
privatekey => 'MyPrivateKey',
remoteip => $ENV{'REMOTE_ADDR'},
challenge => $Form{'recaptcha_challenge_field'},
response => $Form{'recaptcha_response_field'}
}
);
if ( $result->is_success && $result->content =~ /^true/) {
return;
} else {
&error('captcha_failed');
}
}
reCAPTCHA V1 is shutting down at the end of March 2018 and so I need to move to reCAPTCHA V2, however, I'm having trouble validating the response in the CGI script.
Based on the server side documentation, here is what I've tried so far (without success):
sub check_captcha {
my $ua = LWP::UserAgent->new();
my $result=$ua->post(
'https://www.google.com/recaptcha/api/siteverify',
{
secret => 'MyPrivateKey',
remoteip => $ENV{'REMOTE_ADDR'},
response => $Form{'g-recaptcha-response'}
}
);
if ( $result->is_success && $result->content =~ /"success": true/ ) {
return;
} else {
&error('captcha_failed');
}
}
The above always branches to the 'captcha_failed' error.
Thank you in advance for your time reading my question, I appreciate any assistance the community could offer.
Many thanks!
I can't see any obvious problems with your code. But I wonder why you're implementing this yourself when Google::reCAPTCHA exists.
use Google::reCAPTCHA;
my $c = Google::reCAPTCHA->new( secret => 'MyPrivateKey' );
# Verifying the user's response
my $success = $c->siteverify(
response => $Form{'g-recaptcha-response'},
remoteip => $ENV{'REMOTE_ADDR'},
);
if ( $success ) {
# CAPTCHA was valid
}
And why are you using code from Matt's Script Archive?

Return a html page with first request to a Json Rpc Dispatcher server running locally at port 5000

I have Json Rpc Dispatcher Server running in my local host at port 5000 I need to get a html index page when i visit
http://localhost:5000
here is the app.psgi
use JSON::RPC::Dispatcher;
my $rpc = JSON::RPC::Dispatcher->new;
$rpc->register( 'ping', sub { return 'pong' } );
$rpc->register( 'echo', sub { return $_[0] } );
sub add_em {
my #params = #_;
my $sum = 0;
$sum += $_ for #params;
return $sum;
}
$rpc->register( 'sum', \&add_em );
# Want to do some fancy error handling?
sub guess {
my ($guess) = #_;
if ($guess == 10) {
return 'Correct!';
}
elsif ($guess > 10) {
die [ 986, 'Too high.', $guess];
}
else {
die [ 987, 'Too low.', $guess ];
}
}
$rpc->register( 'guess', \&guess );
For now it only returns json with either a GET guess or sum method request.
I need to have a GET request that will return a html page and load some Javascript maybe with the root request
http://localhost:5000/
According to the JSON-RPC 2.0 Specification:
When a rpc call is made, the Server MUST reply with a Response, except for in the case of Notifications. The Response is expressed as a single JSON Object, ...
So its not possible to get a html page from a JSON::RPC Server.

Zend Mail and encodings, content-transfer etc. - Unified?

Is there any class in the Zend Framework that allows me to easily read emails?
The Zend_Mail class does allow me to easy get headers, subject and the content body. But transferring everything to UTF-8 and human-readable format is still a pain.
Or am I doing something wrong? As far as I can tell, Zend Framework does not allow me to easily get UTF-8 strings that I can just use, I still have to do some post-processing. Right?
The key thing is that you need to iterate over the parts within the Message and find the text. Once you have it, then you can use quoted_printable_decode to get the text itself in a useful way.
This is some rough and ready code that reads IMAP email boxes with Zend_Mail:
<?php
$mail = new Zend_Mail_Storage_Imap(array(
'host' => EMAIL_ACCOUNT_HOST,
'user' => EMAIL_ACCOUNT_USERNAME,
'password' => EMAIL_ACCOUNT_PASSWORD,
));
echo (int)$mail->countMessages() . " messages found\n";
foreach ($mail as $message) {
$from = $message->getHeader('from');
$subject = trim($message->subject);
$to = trim($message->to);
$body = getBody($message);
// do something with message here
}
function getBody(Zend_Mail_Message $message)
{
// find body
$part = $message;
$isText = true;
while ($part->isMultipart()) {
$foundPart = false;
$iterator = new RecursiveIteratorIterator($message);
foreach ($iterator as $part) {
// this detection code is a bit rough and ready!
if (!$foundPart) {
if (strtok($part->contentType, ';') == 'text/html') {
$foundPart = $part;
$isText = false;
break;
} else if (strtok($part->contentType, ';') == 'text/plain') {
$foundPart = $part;
$isText = true;
break;
}
}
}
if($foundPart) {
$part = $foundPart;
break;
}
}
$body = quoted_printable_decode($part->getContent());
}

How to get all returned lines with each oracle errror message into one variable using perl

How do i get all of the lines of "$dblink is down" into one $l_msg string?
Ideally I would like to get the error returned by oracle on failure and I cannot see a way to solve this.
my $dblinks = $l_dbh->selectcol_arrayref("select dbname from db_link");
for my $dblink (#$dblinks) {
my $l_results = eval {
my ($l_erg) = $l_dbh->selectrow_array("SELECT dummy||'OK' "
. $l_dbh->quote_identifier($dblink, undef, "dual") );
$l_erg;
};
while (#l_row = $l_results->fetchrow_array) {
$l_erg=$l_row[0];
if ($l_results !~ /XOK/) {
#l_errstr=();
l_msg="$dblink is down with #l_errstr"
# dblink45667 is down with ORA-12154"
} else {
say "$dblink is is up";
}
}
}
How about concatenating them to a variable outside of the loop:
my $dblinks = $l_dbh->selectcol_arrayref("select dbname from db_link");
my $l_msg = '';
for my $dblink (#$dblinks) {
my $l_results = eval {
my ($l_erg) = $l_dbh->selectrow_array("SELECT dummy||'OK' "
. $l_dbh->quote_identifier($dblink, undef, "dual") );
$l_erg;
};
while (#l_row = $l_results->fetchrow_array) {
$l_erg=$l_row[0];
if ($l_results !~ /XOK/) {
#l_errstr=();
l_msg .= "$dblink is down with #l_errstr"
# dblink45667 is down with ORA-12154"
} else {
say "$dblink is is up";
}
}
}