I am trying to customize a script and need to get a POST value from a form using perl.
I have no background of perl but this is a fairly simple thing so I guess it should not be hard.
This is the php version of the code I would like to have in PERL:
<?php
$download = ($_POST['dl']) ? '1' : '0';
?>
I know this may not be at all related to the PERL version but it could help I guess clarifying what exactly I am looking to do.
Well, in that case please have a look at this simple code: This would help you:
#!/usr/bin/perl
use strict;
use warnings;
use CGI;
use CGI::Carp qw(fatalsToBrowser);
sub output_top($);
sub output_end($);
sub display_results($);
sub output_form($);
my $q = new CGI;
print $q->header();
# Output stylesheet, heading etc
output_top($q);
if ($q->param()) {
# Parameters are defined, therefore the form has been submitted
display_results($q);
} else {
# We're here for the first time, display the form
output_form($q);
}
# Output footer and end html
output_end($q);
exit 0;
# Outputs the start html tag, stylesheet and heading
sub output_top($) {
my ($q) = #_;
print $q->start_html(
-title => 'A Questionaire',
-bgcolor => 'white');
}
# Outputs a footer line and end html tags
sub output_end($) {
my ($q) = #_;
print $q->div("My Web Form");
print $q->end_html;
}
# Displays the results of the form
sub display_results($) {
my ($q) = #_;
my $username = $q->param('user_name');
}
# Outputs a web form
sub output_form($) {
my ($q) = #_;
print $q->start_form(
-name => 'main',
-method => 'POST',
);
print $q->start_table;
print $q->Tr(
$q->td('Name:'),
$q->td(
$q->textfield(-name => "user_name", -size => 50)
)
);
print $q->Tr(
$q->td($q->submit(-value => 'Submit')),
$q->td(' ')
);
print $q->end_table;
print $q->end_form;
}
Style advice: you almost never need to assign 0 or 1 to a variable. Simply evaluate the value itself in bool context.
In CGI.pm (CGI), the param method merges POST and GET parameters, so we need to inspect the request method separately:
#!/usr/bin/env perl
use strict;
use warnings FATAL => 'all';
use CGI qw();
my $c = CGI->new;
print $c->header('text/plain');
if ('POST' eq $c->request_method && $c->param('dl')) {
# yes, parameter exists
} else {
# no
}
print 'Do not taunt happy fun CGI.';
With Plack::Request (PSGI), you have different methods for POST (body_parameters) and GET (query_parameters) in addition to the mixed interface (parameters):
#!/usr/bin/env plackup
use strict;
use warnings FATAL => 'all';
use Plack::Request qw();
my $app = sub {
my ($env) = #_;
my $req = Plack::Request->new($env);
if ($req->body_parameters->get_all('dl')) {
# yes
} else {
# no
}
return [200, [Content_Type => 'text/plain'], ['Do not taunt happy fun Plack.']];
};
Here's a good place to start: The Fool's Guide to CGI.pm,
the Perl module for CGI scripting.
This will show you "...how to get the POST value (from a submitted form) and assign it to a variable."
Hope this helps!
The above examples are bit complicated. The below code reads POST values into a variable. You can extract Key Value from that. If its GET then its better to use CGI module.
#!/usr/bin/perl
my $FormData = '';
read(STDIN, $FormData, $ENV{'CONTENT_LENGTH'});
## Variable $FormData holds all POST values passed
use CGI;
my $cgi = new CGI;
print $cgi->header();
print "$FormData";
Related
I have a doubt I've been trying to solve myself using CPAN modules documentation, but I'm a bit new and I'm confused with some terminology and sections within the different modules.
I'm trying to create the object in the code below, and get the absolute URL for relative links extracted from a website.
#!/usr/bin/perl
use strict;
use warnings;
use LWP::UserAgent;
use Digest::MD5 qw(md5_hex);
use URI;
my $url = $ARGV[0];
if ($url !~ m{^https?://[^\W]+-?\.com/?}i) {
exit(0);
}
my $ua = LWP::UserAgent->new;
$ua->timeout( 10 );
my $response = $ua->get( $url );
my $content = $response->decoded_content();
my $links = URI->new($content);
my $abs = $links->abs('http:', $content);
my $abs_links = $links->abs($abs);
while ($content =~ m{<a[^>]\s*href\s*=\s*"?([^"\s>]+)}gis) {
$abs_links = $1;
print "$abs_links\n";
print "Digest for the above URL is " . md5_hex($abs_links) . "\n";
}
The problem is when I try to add that part outside the While loop (the 3-line block preceding the loop), it does not work, whereas if I add the same part in the While loop, it will work fine. This one just gets the relative URLs from a given website, but instead of printing "Http://..." it prints "//...".
The script that works fine for me is the following:
#!/usr/bin/perl
use strict;
use warnings;
use LWP::UserAgent;
use Digest::MD5 qw(md5_hex);
use URI::URL;
my $url = $ARGV[0]; ## Url passed in command
if ($url !~ m{^https?://[\w]+-?[\w]+\.com/?}i) {
exit(0); ## Program stops if not valid URL
}
my $ua = LWP::UserAgent->new;
$ua->timeout( 10 );
my $response = $ua->get( $url ); ## Get response, not content
my $content = $response->decoded_content(); ## Now let's get the content
while ($content =~ m{<a[^>]\s*href\s*=\s*"?([^"\s>]+)}gis) { ## All links
my $links = $1;
my $abs = new URI::URL "$links";
my $abs_url = $abs->abs('http:', $links);
print "$abs_url\n";
print "Digest for the above URL is " . md5_hex($abs_url) . "\n";
}
Any ideas? Much appreciated.
I don't understand your code. There are a few weird bits:
[^\W] is the same as \w
The regex allows an optional - before and an optional / after .com, i.e. http://bitwise.complement.biz matches but http://cool-beans.com doesn't.
URI->new($content) makes no sense: $content is random HTML, not a URI.
$links->abs('http:', $content) makes no sense: $content is simply ignored, and $links->abs('http:') tries to make $links an absolute URL relative to 'http:', but 'http:' is not a valid URL.
Here's what I think you're trying to do:
#!/usr/bin/perl
use strict;
use warnings;
use LWP::UserAgent;
use HTML::LinkExtor;
use Digest::MD5 qw(md5_hex);
#ARGV == 1 or die "Usage: $0 URL\n";
my $url = $ARGV[0];
my $ua = LWP::UserAgent->new(timeout => 10);
my $response = $ua->get($url);
$response->is_success or die "$0: " . $response->request->uri . ": " . $response->status_line . "\n";
my $content = $response->decoded_content;
my $base = $response->base;
my #links;
my $p = HTML::LinkExtor->new(
sub {
my ($tag, %attrs) = #_;
if ($tag eq 'a' && $attrs{href}) {
push #links, "$attrs{href}"; # stringify
}
},
$base,
);
$p->parse($content);
$p->eof;
for my $link (#links) {
print "$link\n";
print "Digest for the above URL is " . md5_hex($link) . "\n";
}
I don't try to validate the URL passed in $ARGV[0]. Leave it to LWP::UserAgent. (If you don't like this, just add the check back in.)
I make sure $ua->get($url) was successful before proceeding.
I get the base URL for absolutifying relative links from $response->base.
I use HTML::LinkExtor for parsing the content, extracting links, and making them absolute.
I think your biggest mistake is trying to parse links out of HTML using a regular expression. You would be far better advised to use a CPAN module for this. I'd recommend WWW::Mechanize, which would make your code look something like this:
#!/usr/bin/perl
use strict;
use warnings;
use feature 'say';
use WWW::Mechanize;
use Digest::MD5 qw(md5_hex);
use URI;
my $url = $ARGV[0];
if ($url !~ m{^https?://[^\W]+-?\.com/?}i) {
exit(0);
}
my $ua = WWW::Mechanize->new;
$ua->timeout( 10 );
$ua->get( $url );
foreach ($ua->links) {
say $_->url;
say "Digest for the above URL is " . md5_hex($_->url) . "\n";
}
That looks a lot simpler to me.
I am trying to gather data from a website. Some anti-patterns make looking finding the right form objects difficult but I have this solved. I am using a post method to get around some javascript acting as a wrapper to submit the form. My problem seems to be in getting the results from the mechanize->post method.
Here's a shortened version of my code.
use strict;
use warnings;
use HTML::Tree;
use LWP::Simple;
use WWW::Mechanize;
use HTTP::Request::Common;
use Data::Dumper;
$| = 1;
my $site_url = "http://someURL";
my $mech = WWW::Mechanize->new( autocheck => 1 );
foreach my $number (#numbers)
{
my $content = get($site_url);
$mech->get ($site_url);
my $tree = HTML::Tree->new();
$tree->parse($content);
my ($title) = $tree->look_down( '_tag' , 'a' );
my $atag = "";
my $atag1 = "";
foreach $atag ( $tree->look_down( _tag => q{a}, 'class' => 'button', 'title' => 'SEARCH' ) )
{
print "Tag is ", $atag->attr('id'), "\n";
$atag1 = Dumper $atag->attr('id');
}
# Enter permit number in "Number" search field
my #forms = $mech->forms;
my #fields = ();
foreach my $form (#forms)
{
#fields = $form->param;
}
my ($name, $fnumber) = $fields[2];
print "field name and number is $name\n";
$mech->field( $name, $number, $fnumber );
print "field $name populated with search data $number\n" if $mech->success();
$mech->post($site_url ,
[
'$atag1' => $number,
'internal.wdk.wdkCommand' => $atag1,
]) ;
print $mech->content; # I think this is where the problem is.
}
The data I get from my final print statement is the data from teh original URL not the page the POST command should take me to. What have I done wrong?
Many Thanks
Update
I don't have Firefox installed so I'm avoiding WWW::Mechanize::Firefox intentionally.
Turns out I was excluding some required hidden fields from my POST command.
I am getting www:Facebook:api in perl and CPAN
error while using the Use of uninitialized value within %field in hash element at /usr/share/perl5/WWW/Facebook/API/Auth.pm line 62.
i defined all keys
#!/usr/bin/perl -w
use strict;
use warnings;
use CGI;
use WWW::Facebook::API;
use WWW::Facebook::API::Auth;
use HTTP::Request;
use LWP;
my $TMP = $ENV{HOME}.'/tmp';
my $facebook_api = '--------';
my $facebook_secret = '-------';
my $facebook_clientid = '--------';
my $gmail_user = '-------';
my $gmail_password = '--------';
my $client = WWW::Facebook::API->new(
desktop => 1,
api_version => '1.0',
api_key => $facebook_api,
secret => $facebook_secret,
throw_errors => 1,
);
$client->app_id($facebook_clientid);
local $SIG{INT} = sub {
print "Logging out of Facebookn";
my $r = $client->auth->logout;
exit(1);
};
my $token = $client->auth->create_token;
print "$token \n";
$client->auth->get_session($token);
print "$client \n";
WWW::Facebook::API doesn't look like it's been updated for a while. Line 62 of that file is:
$self->base->{ $field{$key} } = $resp->{$key};
The undefined value is the $field{$key} part. The %fieldhash is a hard-coded mapping between the names of Facebook API's known fields (i.e. the fields in the data Facebook returns to you) and the names which the module wants them to be called. It seems that Facebook has added some additional fields to its data, and the module has not been updated to deal with them.
Ultimately, this is just a warning; you can just ignore it if you like. If you want your script's output to be a bit tidier, you could change that line to:
$self->base->{ $field{$key} } = $resp->{$key} if defined $field{$key};
#!/usr/bin/env perl
use warnings;
use 5.012;
use utf8;
use WWW::Mechanize::Cached;
use Some::Module qw(some_method);
my $url = '...';
my $result = some_method( $url );
The some_method() uses itself get() form LWP::Simple.
How could I overwrite the get() with my my_get() in this script?
sub my_get {
my $url;
my $mech = WWW::Mechanize::Cached->new();
$mech->get( $url );
my $content = $mech->content( format => 'text' );
return $content;
}
sub WWW::Mechanize::Cached::get {
# your code
}
OR, if the get method is actually, as you imply in the question, is inherited from LWP::Simple -
sub LWP::Simple::get {
# your code
}
I'm using the AnyEvent::Twitter::Stream module to grab tweets. Ultimately I'm trying to print the tweets to a file but I'm unable (I think) to get the tweet as a JSON object. My code is as follows:
#!/Applications/XAMPP/xamppfiles/bin/perl
use AnyEvent::Twitter::Stream;
my $done = AnyEvent->condvar;
BEGIN {
use Exporter;
our #ISA = qw(Exporter);
our #EXPORT = qw{
&init
};
}
sub print_tweet {
my $tweet = shift;
print $tweet;
}
# receive updates from #following_ids
my $listener = AnyEvent::Twitter::Stream->new(
username => XXXXXX
password => XXXXXX
method => 'sample', # "firehose" for everything, "sample" for sample timeline
decode_json => 1,
on_tweet => sub {
my $tweet = shift;
print_tweet($tweet);
},
on_keepalive => sub {
warn "ping\n";
},
on_delete => sub {
my ($tweet_id, $user_id) = #_; # callback executed when twitter send a delete notification
},
timeout => 45,
);
$done->recv;
Yet when I print out the tweet in the print_tweet subroutine all I get is:
HASH(0x8f0ad0)HASH(0x8f0640)HASH(0x875990)HASH(0x8f0ab0)HASH(0x8e0d80)HASH(0x8f06e0)HASH(0x8f08f0)HASH(0x93ef30)HASH(0x876190)HASH(0x93ee60)HASH(0x8f0610)HASH(0x8f0b00)HASH(0x8e13e0)HASH(0x93ee20)HASH(0x8f0a20)HASH(0x8e1970)HASH(0x8f0900)
I've even tried to print out the tweet assuming it is a hash as follows:
sub print_tweet {
my ($jsonref, $tweet) = #_;
my $tweet = shift;
print %tweet;
}
Yet that produced nothing. It appears that AnyEvent::Twitter::Stream is returning $tweet as an object based on their sample code of:
on_tweet => sub {
my $tweet = shift;
warn "$tweet->{user}{screen_name}: $tweet->{text}\n";
},
And I know I can print out individual objects, but can I get teh raw JSON object? I must be missing something or my 'noob'ness is greater than I thought...
UPDATE
I was able to ALMOST get it by changing print_tweet to the following:
sub print_tweet {
my $tweet = shift;
my $json_output = to_json($tweet);
print $json_output;
}
It prints out MOST of the JSON object but complains about wide characters, which I believe is an issue with the output being utf8 format? I'm unsure how to solve this issue though....
Looks like it's returning a hashref. If you're not sure, you could try doing something like this.
use Data::Dumper;
...
print Dumper $tweet;
That should give you an idea of what's being passed, then you can grab what you want - probably something like this:
print "$tweet->{user}{screen_name}: $tweet->{text}\n";
In print_tweet, you're declaring $tweet twice. First, you assign it the second element of the #_ array, then you redeclare it and assign it the first element of #_, because shift operated on #_ by default.
Of course, if you had use warnings turned on, you would have seen
"my" variable $tweet masks earlier declaration in same scope
That's why you should always use strict; use warnings; at the top of your code.
The strings of output that you're seeing are hash references, the result of printing what's in the first argument to print_tweet (what you initially assign to $json_ref). If you want to print out the value of $tweet, get rid of the line where you clobber it with shift.
Figured it out. Need to use the JSON module and encode. When encoding you MUST use the {utf8 => 1} option to account for the utf8 characters you get form Twitter. Final code is here:
#!/Applications/XAMPP/xamppfiles/bin/perl
use JSON;
use utf8;
use AnyEvent::Twitter::Stream;
my $done = AnyEvent->condvar;
BEGIN {
use Exporter;
our #ISA = qw(Exporter);
our #EXPORT = qw{
&init
};
}
sub print_tweet {
my $tweet = shift;
my $json_output = to_json($tweet, {utf8 => 1});
print $json_output;
print "\n";
}
# receive updates from #following_ids
my $listener = AnyEvent::Twitter::Stream->new(
username => XXXXXXXX
password => XXXXXXXX
method => 'sample', # "firehose" for everything, "sample" for sample timeline
on_tweet => sub {
my $tweet = shift;
print_tweet($tweet);
},
on_keepalive => sub {
warn "ping\n";
},
on_delete => sub {
my ($tweet_id, $user_id) = #_; # callback executed when twitter send a delete notification
},
timeout => 45,
);
$done->recv;
Thanks to the help you guys gave, the DataDumper at least let me verify the format, it just didn't produce the final result.