Issue in Json RPC with mod_perl - json

I am having an issue with Json RPC and mod_perl. I am trying to return a value from a cgi script which is running in Apache through mod_perl. But in the return value, following apache headers are automatically added and therefore I am not able to access the return value from my client script.
Status: 200
Content-Type: application/json; charset=UTF-8
In my Apache configuration file I have following directives.
LoadModule perl_module modules/mod_perl.so
PerlSwitches -w
PerlSwitches -T
Alias /perl /var/www/html/perl
<Directory /var/www/html/perl>
SetHandler perl-script
PerlResponseHandler ModPerl::Registry
Options +ExecCGI
</Directory>
My cgi script is pasted below.
#!/usr/bin/perl
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use JSON::RPC::Server::CGI;
use strict;
use Data::Dumper;
my $server = JSON::RPC::Server::CGI->new;
$server->dispatch('Myapp')->handle();
The Myapp.pm is
#!/usr/bin/perl
package Myapp;
use base qw(JSON::RPC::Procedure); # Perl 5.6 or more than
use strict;
use Data::Dumper;
sub test : Public(u1:str){
my ($s, $obj) = #_;
my $u1 = $obj->{u1};
return $u1;
}
1;
My client side script is
#!/usr/bin/perl
use JSON::RPC::Client;
use Data::Dumper;
my $client = new JSON::RPC::Client;
my $uri = 'http://IP/perl/test.cgi';
$client->prepare($uri, ['test']);
$str= $client->test('testing');
print "$str\n\n";
In normal case the output should be testing . But in my case I am getting the below error.
malformed JSON string, neither array, object, number, string or atom, at character offset 0 (before "Status: 200\r\nConte...") at /usr/local/share/perl5/JSON/RPC/Client.pm line 186
The issue is because some http headers are automatically get added to the return value. Is there any way to suppress these headers?
Note: Kindly don't recommend normal cgi scripts or running perl script as daemon because it is already working and tested from my end. We are using mod_perl for high performance.

Related

500 Can't connect to url with lwp in perl

I'm trying to parse some json data with the fandom wikia API. When I browse to my marvel.fandom.com/api request I get following JSON output: {"batchcomplete":"","query":{"pages":{"45910":{"pageid":45910,"ns":0,"title":"Uncanny X-Men Vol 1 171"}}}}
Nothing to fancy to begin with and running it through a JSON parser online gives following output:
{
"batchcomplete":"",
"query":{
"pages":{
"45910":{
"pageid":45910,
"ns":0,
"title":"Uncanny X-Men Vol 1 171"
}
}
}
}
which seems to be ok as far as I can see
I want to get the pageid for several other requests but I can't seem to get the same output through Perl.
The script:
#!/usr/bin/perl
use strict;
use warnings;
use LWP::Simple;
use JSON;
use Data::Dumper;
my $url = "https://marvel.fandom.com/api.php?action=query&titles=Uncanny%20X-Men%20Vol%201%20171&format=json";
my $json = getprint( $url);
die "Could not get $url!" unless defined $json;
my $decoded_json = decode_json($json);
print Dumper($decoded_json);
but this gives following error:
Could not get https://marvel.fandom.com/api.php?action=query&titles=Uncanny%20X-Men%20Vol%201%20171&format=json! at ./marvelScraper.pl line 11.
When I change the get to getprint for some extra info, I get this:
500 Can't connect to marvel.fandom.com:443
<URL:https://marvel.fandom.com/api.php?action=query&titles=Uncanny%20X-Men%20Vol%201%20171&format=json>
malformed JSON string, neither tag, array, object, number, string or atom, at character offset 0 (before "(end of string)") at ./script.pl line 13.
I tried this on another computer and still get the same errors.
The versions of LWP::Simple and LWP::Protocol::https
/usr/bin/perl -MLWP::Simple -E'say $LWP::Simple::VERSION'
6.15
/usr/bin/perl -MLWP::Protocol::https -E'say $LWP::Protocol::https::VERSION'
6.09
Appearantly it has something to do with the Bash Ubuntu on Windows since on a Ubuntu 18.04 I get (with the same script) following response:
JSON text must be an object or array (but found number, string, true, false or null, use allow_nonref to allow this) at ./test.pl line 13.
{"batchcomplete":"","query":{"pages":{"45910":{"pageid":45910,"ns":0,"title":"Uncanny X-Men Vol 1 171"}}}}
Actually, the very same script works from my Bash Ubuntu on Windows with the get() command instead of the getprint() you gave after editing your question.
orabig#Windows:~/DEV$ ./so.pl
$VAR1 = {
'query' => {
'pages' => {
'45910' => {
'pageid' => 45910,
'ns' => 0,
'title' => 'Uncanny X-Men Vol 1 171'
}
}
},
'batchcomplete' => ''
};
So maybe you have another issue that has nothing to do with Perl or Ubuntu.
Can you try this for example ?
curl -v 'https://marvel.fandom.com/api.php?action=query&titles=Uncanny%20X-Men%20Vol%201%20171&format=json'
Maybe you just hit the site too much, and the 500 error is just a result of some anti-leech protection ?

How do I use encode_json with string in Perl?

Here is my code that I try to open the file to get data and change it to UTF-8, then read each line and store it in variable my $abstract_text and send it back in JSON structure.
my $fh;
if (!open($fh, '<:encoding(UTF-8)',$path))
{
returnApplicationError("Cannot read abstract file: $path ($!)\nERRORCODE|111|\n");
}
printJsonHeader;
my #lines = <$fh>;
my $abstract_text = '';
foreach my $line (#lines)
{
$abstract_text .= $line;
}
my $json = encode_json($abstract_text);
close $fh;
print $json;
By using that code, I get this error;
hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)
error message also point out that the problem is in this line;
my $json = encode_json($abstract_text);
I want to send the data back as a string (which is in UTF-8). Please help.
I assume you're using either JSON or JSON::XS.
Both allow for non-reference data, but not via the procedural encode_json routine.
You'll need to use the object-oriented approach:
use strict; # obligatory
use warnings; # obligatory
use JSON::XS;
my $encoder = JSON::XS->new();
$encoder->allow_nonref();
print $encoder->encode('Hello, world.');
# => "Hello, world."

POST request with REST::Client

I am creating a POST request using REST::Client and keep getting following error:
Response:Not a SCALAR reference at /nethome/perl5/lib/perl5//LWP/Protocol/http.pm line 254, <IFH> line 1.
My code Snippet:
use warnings;
use diagnostics;
use strict;
use JSON::MaybeXS;
use REST::Client;
my $host = 'myurl';
my $hashref = {};
my $jsonEncode=JSON::MaybeXS->new->utf8(1)->pretty(1);
Inside a Subroutine, using while loop
my #fields=split("\t",$_);
my $sample_id=$fields[0];
my $chr=$fields[1];
my $position=$fields[2];
my $alt=$fields[5];
my $hashref =("variant_request"=>{"searchParameters"=>{"sampleIds"=> ["$sample_id"],"genome"=>[{"loci"=>{"chromosome"=>"$chr","position"=>$position,"allele"=>"$alt"}}]}});
push (#meta,\%hashref);
printQuery (#meta,$encoded);
Inside PrintQuery Subroutine:
my $filename =$_[1];
my $hash = $jsonEncode->canonical->encode($_[0]);
$client->POST($hash,{'Content-Type'=>'application/json','Accept'=>'application/json'});
print 'Response:'.$client->responseContent()."\n";
print 'Response Status:'. $client->responseCode()."\n";
Input:
601 1 114872280 rs544699256 A G
So not exactly sure why this worked:
Changed This:
my $client=REST::Client->new(host=>$host);
To:
my $client=REST::Client->new();
Added:
my $url = 'myurl';
And Finally changed:
$client->POST($url,$jsonrequest,{'Content-Type'=>'application/json','Accept'=>'application/json'});

Perl script literally prints http headers instead of understanding them

I couldn't think of better keywords to Google this issue, so I apologize if this is a duplicate.
Here is my logout.pl script that basically erases cookie:
#!/usr/bin/perl -w
use strict;
use warnings;
use CGI;
my $q = new CGI;
print $q->header('text/html');
my $cookie = $q->cookie(
-name => 'CGISESSID',
-value => '',
-expires => '-1d'
);
print $q->header(-cookie=>$cookie);
print $q->redirect('welcome.pl');
exit;
When I run this script in a browser, it prints the following:
Set-Cookie: CGISESSID=; path=/; expires=Mon, 17-Feb-2014 09:05:42 GMT Date: Tue, 18 Feb 2014 09:05:42 GMT Content-Type: text/html; charset=ISO-8859-1 Status: 302 Found Location: welcome.pl
What I want, however, is for the browser to delete the cookie and redirect to welcome.pl.
When you print $q->header, that prints all the headers, including the blank line which signals the end of headers, making anything after it content. You need to only print $q->header once, no more.
There is actually one more problem you might not figure out on your own. The “clear” cookie you’re trying to send to expire the session must be sent with the redirect. The -w switch is not usually what you want, just the use warnings you have too. Also, redirect URLs RFC:MUST be absolute. "welcome.pl" will in most likelihood work but it’s not a good practice and I had relative URIs bite very badly in a modperl app once. So, amended–
#!/usr/bin/env perl
use strict;
use warnings;
use CGI;
use URI;
my $q = CGI->new;
my $cookie = $q->cookie(
-name => 'CGISESSID',
-value => '',
-expires => '-1d'
);
my $welcome = URI->new_abs("welcome.pl", $q->url);
print $q->redirect( -uri => $welcome,
-cookie => $cookie,
-status => 302 );
exit;
You should use $q->header only once in your script and that should be before using anything printable on page

Perl regular expression for html

I need to extract the IMDB id(example:for the movie 300 it is tt0416449) for a movie specified by the variable URL. I have looked at the page source for this page and come up with the following regex
use LWP::Simple;
$url = "http://www.imdb.com/search/title?title=$FORM{'title'}";
if (is_success( $content = LWP::Simple::get($url) ) ) {
print "$url is alive!\n";
} else {
print "No movies found";
}
$code = "";
if ($content=~/<td class="number">1\.</td><td class="image"><a href="\/title\/tt[\d]{1,7}"/s) {
$code = $1;
}
I am getting an internal server error at this line
$content=~/<td class="number">1\.</td><td class="image"><a href="\/title\/tt[\d]{1,7}"/s
I am very new to perl, and would be grateful if anyone could point out my mistake(s).
Use an HTML parser. Regular expressions cannot parse HTML.
Anyway, the reason for the error is probably that you forgot to escape a forward slash in your regex. It should look like this:
/<td class="number">1\.<\/td><td class="image"><a href="\/title\/tt[\d]{1,7}"/s
A very nice interface for this type of work is provided by some tools of the Mojolicious distribution.
Long version
The combination of its UserAgent, DOM and URL classes can work in a very robust way:
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use Mojo::UserAgent;
use Mojo::URL;
# preparations
my $ua = Mojo::UserAgent->new;
my $url = "http://www.imdb.com/search/title?title=Casino%20Royale";
# try to load the page
my $tx = $ua->get($url);
# error handling
die join ', ' => $tx->error unless $tx->success;
# extract the url
my $movie_link = $tx->res->dom('a[href^=/title]')->first;
my $movie_url = Mojo::URL->new($movie_link->attrs('href'));
say $movie_url->path->parts->[-1];
Output:
tt0381061
Short version
The funny one liner helper module ojo helps to build a very short version:
$ perl -Mojo -E 'say g("imdb.com/search/title?title=Casino%20Royale")->dom("a[href^=/title]")->first->attrs("href") =~ m|([^/]+)/?$|'
Output:
tt0381061
I agree XML is anti-line-editing thus anti-unix but, there is AWK.
If awk can do, perl can surely do. I can produce a list:
curl -s 'http://www.imdb.com/find?q=300&s=all' | awk -vRS='<a|</a>' -vFS='>|"' -vID=$1 '
$NF ~ ID && /title/ { printf "%s\t", $NF; match($2, "/tt[0-9]+/"); print substr($2, RSTART+1, RLENGTH-2)}
' | uniq
Pass search string to "ID".
Basically it's all about how you choose your tokenizer in awk, I use the <a> tag. Should be easier in perl.