Perl CGI Form reusing previous data - perl

I am building a signup form with Perl (using the CGI module) and a recaptcha. The form works fine and submits the data to a SQL database. However, when I create another user with the form, the data entered into the database is the same as the first user. I am retrieving the form data in my verification page using my $var = $cgi->param('param_name'); Do I need to clear the params, or is it something else. (I tried $cgi->delete_all(); but that didn't seem to do anything)
Form Verification Code: (It is literally a prototype, so security has not been addressed yet)
my $challenge = $q->param('recaptcha_challenge_field');
my $response = $q->param('recaptcha_response_field');
my $username = $q->param('Username');
my $password = $q->param('Password');
my $name = $q->param('Name');
my $email = $q->param('Username');
my $security = $q->param('Security');
my $answer = $q->param('Answer');
my $permissions = 1;
# Verify submission
my $result = $c->check_answer(
"my_private_key", $ENV{'REMOTE_ADDR'},
$challenge, $response
);
if ( $result->{is_valid} ) {
insert_new_user();
print $q->redirect('cgi-bin/admin/text_campaign.pl');
}
else {
# Error
print $q->redirect('login.pl?crc=false');
}
###############################################################################
# Sub Routines #
###############################################################################
sub insert_new_user
{
my $sql = "INSERT INTO users (u_username, u_password, u_realname, u_email, u_security_question, u_security_answer, PRIVILEGES_idPRIVILEGES)
VALUES(?, ?, ?, ?, ?, ?, ?) ";
my $sth=$dbh->prepare($sql);
$sth->execute($username, $password, $name, $email, $security, $answer, $permissions);
$sth->finish();
return;
}

Yes, that's the way it normally works. Look into the -nosticky "pragma" in the documentation
http://perldoc.perl.org/CGI.html#PRAGMAS
or the delete_all() function.
--- EDIT ---
I played a little with a modified form of the sample that is in CGI.pm's documentation. Including it here for ease of reference, and because i changed it a little.
#!/usr/bin/perl
use CGI qw/-nosticky :standard/;
print header;
print start_html("Example CGI.pm Form");
print "<h1> Example CGI.pm Form</h1>\n";
do_work();
print_prompt();
print_tail();
print end_html;
sub print_prompt {
print "<hr>\n";
print start_form;
print "<em>What's your name?</em><br>";
print textfield('name');
print checkbox('Not my real name');
print "<p><em>Where can you find English Sparrows?</em><br>";
print checkbox_group(
-name=>'Sparrow locations',
-values=>[England,France,Spain,Asia,Hoboken],
-linebreak=>'yes',
-defaults=>[England,Asia]);
print "<p><em>How far can they fly?</em><br>",
radio_group(
-name=>'how far',
-values=>['10 ft','1 mile','10 miles','real far'],
-default=>'1 mile');
print "<p><em>What's your favorite color?</em> ";
print popup_menu(-name=>'Color',
-values=>['black','brown','red','yellow'],
-default=>'red');
print hidden('Reference','Monty Python and the Holy Grail');
print "<p><em>What have you got there?</em><br>";
print scrolling_list(
-name=>'possessions',
-values=>['A Coconut','A Grail','An Icon',
'A Sword','A Ticket'],
-size=>5,
-multiple=>'true');
print "<p><em>Any parting comments?</em><br>";
print textarea(-name=>'Comments',
-rows=>10,
-columns=>50);
print "<p>",reset;
print submit('Action','Shout');
print submit('Action','Scream');
print end_form;
print "<hr>\n";
}
sub do_work {
print "<h2>Here are the current settings in this form</h2>";
for my $key (param) {
print "<strong>$key</strong> -> ";
my #values = param($key);
print join(", ",#values),"<br>\n";
}
}
sub print_tail {
print <<END;
<hr>
<address>Lincoln D. Stein</address><br>
Home Page
END
}
Left as is, this script exhibits the behavior we are discussing. The use of -nosticky doesn't seem to have helped.
However, if i add Delete_all after do_work and before print_prompt(), like so:
print header;
print start_html("Example CGI.pm Form");
print "<h1> Example CGI.pm Form</h1>\n";
do_work();
Delete_all();
print_prompt();
print_tail();
print end_html;
Then the defaults are not prepopulated.
I hope this helps.

Related

Perl: Scanning body text for URIs and remove using URI::Find::Simple

I'm trying to scan the article text in a joomla database for URIs that result in a 404. If a 404 is found, remove the anchor and just leave the resulting text.
The code below succeeds in locating the URIs, but I have no idea how to then strip them out of the body text, leaving just the text portion of the link.
The fetch_body() function returns a pointer to the article, where the id, fulltext, and other characteristics can be accessed.
I've also experimented with HTTP::Tiny to download the URL and check the status and it appears to work properly.
Is there an existing module I can use to strip the URL, leaving only the text? Can URI::Find:Simple be used to return the entire HTML (anchor?) surrounding the URI?
I don't know what more information I can provide to help me determine what to do next.
foreach my $ref (fetch_body($dbh)) {
print "checking body: $ref->{'id'} ";
my #uris = URI::Find::Simple::list_uris($ref->{fulltext});
foreach my $uri (#uris) {
print "current uri: $uri\n";
# check uri for status code here ***
my $response = HTTP::Tiny->new->get($url);
if ($response->{success}) {
print "status: $response->{'status'}\n";
} else {
print "Failed: $response->{status} $response->{reasons}\n";
}
}
}
These other two functions just open the database and return a pointer to the article in the joomla database.
sub db_connect() {
my %DB = (
'host' => 'db.example.com',
'db' => 'db5',
'user' => 'joomla',
'pass' => 'joomlapass',
);
return DBI->connect("DBI:mysql:database=$DB{'db'};host=$DB{'host'}",$DB{'user'}, $DB{'pass'});
}
sub fetch_body ($) {
$dbh = shift;
my $sql = "select id, title, alias, urls, \`fulltext\`
FROM xxx_content
WHERE state = 1";
my $sth = $dbh->prepare($sql);
my #rv = ();
$sth->execute();
while (my $ref = $sth->fetchrow_hashref()) {
push #rv, $ref;
}
$sth->finish();
return #rv;
}
You can use something like this:
use strict;
use warnings;
use Mojo::DOM qw( );
sub check_url {
my ($url) = #_;
# Replace with code to check of the URL is reachable.
return $url !~ /non-existant/;
}
# From your database or whatever.
my $html = '
<body>
<p>Google</p>
<p>Bad</p>
</body>
';
my $dom = Mojo::DOM->new($html);
for my $ele ($dom->find('a[href]')->each) {
my $url = $ele->attr('href');
if (!check_url($url)) {
delete $ele->attr->{href};
}
}
$html = "$dom";
print $html; # Do whatever you want with the modified HTML.

print out email on terminal using data::dumper

I am not understanding how to use Data::Dumper even after reading the Perl doc and looking at other scripts in git. I see lots of examples online dealing with hashes, but I didn't think that quite fit with what I need to do.
I am creating a script to send emails to managers or teams regarding terminated employees. I was told to add print Dumper $email to my code so that when --dry_run option is used, we could see on the terminal a printout of what the email would look like. --dry_run would also ensure that the email isn't actually sent. When I run perl <script> --dry_run, nothing happens. Maybe I need to do something along the lines of $d = Data::Dumper->new(?
Here is a snippet of my code:
#!/usr/bin/perl
use strict;
use warnings;
use NIE::Email;
use Data::Dumper;
use List::Util qw(any);
use Getopt::Long;
Getopt::Long::Configure qw(gnu_getopt);
my ($qa, $verbose, $dry_run, $help, $dbh);
GetOptions(
'qa' => \$qa,
'verbose|v' => \$verbose,
'dry_run' => \$dry_run,
'help|h' => \$help
);
#Generate email here
sub mail_func {
print "Prepare email\n" if $verbose;
my $n = shift; #user
my $i = shift; #ips
my $t = shift; #testnets
my $m = shift; #managers (multiple if owner is undef)
my #to_list; # send to field
foreach my $value (values %{$t}) {
if ($value ne 'lab#abc.com') { #don't send this email to lab#
if (any { $value eq $_ } #to_list) { #check not already listed
next;
}
else { push(#to_list, $value); }
}
}
foreach my $key (keys %{$m}) {
if ($key ne 'def') {
if (any { $key eq $_ } #to_list) {
next;
}
else { push(#to_list, $key . '#abc.com'); }
}
}
my #body;
while (my ($key, $value) = each %{$i}) {
my $b = "IP " . $key . " : Testnet " . $value . "\n";
push(#body, $b);
}
my $sub1 = "Ownership needed!";
my $sub2 = "Ownership needed script special case";
my $email;
#Email testnet group (if not lab) as well as manager of term employee
if (#to_list) {
$email = NIE::Email->new(
From => 'do-not-reply#abc.com',
To => join(',', #to_list),
'Reply-to' => 'def#abc.com',
Subject => $sub1,
);
$email->data(
"Good Day, \n\n The below machines need claimed as their previous"
. " owner, $n, is showing up as no longer with the company. \n"
. "Please visit website to change"
. " ownership of these machhines. \n\n"
. "#body \n\n"
. "If you have already requested an ownership change for these"
. " machines, please disregard this message."
. "\n\n Thank you \n -Lab team \n\n"
. "This script is under active development and could contain"
. " bugs, so please speak up if you have doubts or something "
. "looks strange."
. "\n Script name: lab_ownership_needed_email");
if ($dry_run) {print Dumper($email);}
else {$email->send();}
}
Any help in understanding how to use this for my purpose would be greatly appreciated. Thank you.
Reverted to original, re-added in code, re-ran the script, and it works.
The above code is correct as is.
Thanks to simbabque who stated the code looked correct in the first place.

How do I iterate over methods for Perl object

I've created an Object such as
my $hex = Hexagram->new();
and it has various methods:
top
bot
chinese
title
meaning
This object will be created numerous times and each time I need to gather and test information for each of the above methods.
I would like to do something like
foreach my $method ( qw/top bot chinese title meaning/ )
{
&gather_info($hex,$method);
}
and then have something like
sub gather_info {
my ($hex,$method) = #_;
print "What is the $method? ";
my $response = <STDIN>;
chomp $response;
$hex->${method}($reponse);
.... and other actions ....
}
But this doesn't work. Instead, for each method I seem to have to write out the basic code structure again and again which just seems plain wasteful.
I've also tried something where I try to pass a reference to the method call such as in
foreach my $ra ( [\$hex->top, "top"],
[\$hex->bot, "bot"],....)
{
my ($object_method, $name) = #{$ra};
&rgather_info($object_method, $name);
}
where
sub $gather_info {
my ($rhex, $name) = #_;
print "What is the $name?";
my $response = <STDIN>;
chomp $response;
&{$rhex}($response);
.... and other actions ....
}
But this time I get an error about
Not a CODE reference at <program name> line <line number>,....
Any suggestions on how I can do this?
According to perlobj method calls can be made using a string variable.
$object->$method( #args );
So your foreach loop should have worked fine. Or this one, which is much less wordy:
use strict;
use warnings;
my $hex = Hexagram->new();
gather_info( $hex, $_ )
for qw/top bot chinese title meaning/;
sub gather_info {
my ($hex, $method) = #_;
print "What is $method?\n";
my $response = <STDIN>;
chomp $response;
$hex->$method( $response );
}
Make sure you have strict and warnings enabled and try again. Update you post with errors, etc.

Downloading file in cgi perl script

I am unable to download the file in cgi perl. Instead I get the contents printed on the web page itself.This is what I had tried.
Code:
use CGI qw /:standard /;
use CGI;
print "Content-type:text/html\n\n";
my $files_location;
my $ID;
my #fileholder;
$directorypath = "/var/www/cgi-bin/";
$files_location = $directorypath;
$ID = 'file.txt';
#$ID = param('ID');
if ($ID eq '') {
print "You must specify a file to download.";
} else {
open(DLFILE, "<$files_location/$ID") || Error('open', 'file');
#fileholder = <DLFILE>;
close (DLFILE) || Error ('close', 'file');
#these are the html codes that forces the browser to open for download
print "Content-Type:application/x-download\n";
print "Content-Disposition:attachment;filename=$ID\n\n";
print #fileholder;
}
I am getting this:
Content-Type:application/x-download Content-Disposition:attachment;filename=file.txt ih how are u iam hre
file.txt
ih how are u iam hre
On line 4 you've got:
print "Content-type:text/html\n\n";
That double \n signals end-of-headers, content will follow. Get rid of that and try again?
try commenting
print "Content-type:text/html\n\n";
You must move the below line from top to inside if loop:
print "Content-type:text/html\n\n";
To
if ($ID eq '') {
print "Content-type:text/html\n\n";
print "You must specify a file to download.";
}

Perl web scraping

I am a Perl beginner and I am passionate about web scraping using Perl. After spending a couple of hours I wrote the code below for scraping company name, addresses and telephone number from yell.com. The script is working fine and I successfully to collected one record (1/15 from page 1).
I need your valuable suggestion regarding how can I scrape all ten companies in the first page in one go, so that I can move on to others pages of data.
use strict;
use Data::Dumper;
use LWP::Simple; # from CPAN
use JSON qw( decode_json ); # from CPAN
use WWW::Mechanize;
my $mech = WWW::Mechanize->new();
my $header = "company_name|Address|Telphone";
open (CH, ">output.csv");
print CH "$header\n";
my $url = "http://www.yell.com/ucs/UcsSearchAction.do?keywords=Engineering+consulatants&location=United+Kingdom&scrambleSeed=13724563&searchType=&M=&bandedclarifyResults=&ssm=1";
$mech->get($url);
my $con = $mech->content();
my $res = "";
############ for company name ##########
if ( $con =~ /<a data-omniture="LIST:COMPANYNAME" href="\/biz\/ross-davy-associates-grimsby-901271213\/" itemprop="name">(.*?)<\/a>/is ) {
$res = $1;
}
else {
$res = "Not_Match";
}
############### for address #########
my ($add1, $add2, $add3, $add4, $add) = ("", "", "", "", "");
if ( $con =~ /<span itemprop="streetAddress">(.*?)<\/span> <span itemprop="addressLocality">(.*?)<\/span> , <span itemprop="postalCode">(.*?)<\/span> , <span itemprop="addressRegion">(.*?)<\/span>/is ) {
$add1 = $1;
$add2 = $2;
$add3 = $3;
$add4 = $4;
$add = $1.$2.$3.$$;
}
else {
$add = "Not_Match";
}
########### telephone ##########
my $tel="";
if ( $con =~ /<li data-company-item="telephone" class="last"> Tel: <strong>(.*?)<\/strong> <\/li>/is ) {
$tel = $1;
}
else {
$tel = "Not_Match";
}
print "==$res===$add===$tel==\n";
print CH "$res|$add|$tel\n";
These points should help
Always use warnings as well as use strict
Always use the three-parameter form of open, test the success of every open call, and die with a string that includes the built-in variable $! so that you know why the open failed
Never use regular expressions for parsing HTML. There are several modules such as HTML::TreeBuilder::XPath that do the job properly and allow simple access to the contents of the data using XPath
Always make sure that extracting data like this is within the terms of service of the site in question.
With regard to the last point, the majority of sites prohibit any form of automated access and copying of their data. Yell.com is no different. Their conditions of use say this.
You cannot use the website ... using any automated means to monitor or copy the website or its content ...
So what you are doing opens you to the possibility of legal prosecution.