get request in perl and Use of uninitialized value - perl

my $url = "https://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=pubmed&term=journal+of+medical+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]&usehistory=y";
print "\n before url \n";
print $url;
#post the esearch URL
my $output = get($url);
print $output;
I have not used perl ever before.
If I hit this URL in browser, I do get the XML.
However, From what I see in output from script, $output is empty and
print $output;
returns
Use of uninitialized value in print at ./extractEmails.pl line 48.
Please suggest what's wrong and how to fix it
Edit:
As suggested, complete code:
#!/usr/bin/perl -w
# A perlscript written by Joseph Hughes, University of Glasgow
# use this perl script to parse the email addressed from the affiliations in PubMed
use strict;
use LWP::Simple;
my ($query,#queries);
#Query the Journal of Virology from 2014 until the present (use 3000)
$query = 'journal+of+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Journal of General Virology
$query = 'journal+of+general+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Virology
$query = 'virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Archives of Virology
$query = 'archives+of+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Virus Research
$query = 'virus+research[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Antiviral Research
$query = 'antiviral+research[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Viruses
$query = 'viruses[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Journal of Medical Virology
$query = 'journal+of+medical+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
# global variables
push(#queries,$query);
my %emails;
my $emailcnt=0;
my $count=1;
#assemble the esearch URL
foreach my $query (#queries){
my $base = 'https://eutils.ncbi.nlm.nih.gov/entrez/eutils/';
#my $url = $base . "esearch.fcgi?db=pubmed&term=$query&usehistory=y";
my $url = "https://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=pubmed&term=journal+of+medical+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]&usehistory=y";
print "\n before url \n";
print $url;
#post the esearch URL
my $output = get($url);
print "\n before output \n";
print get($url);
print $output;
#parse WebEnv, QueryKey and Count (# records retrieved)
my $web = $1 if ($output =~ /<WebEnv>(\S+)<\/WebEnv>/);
my $key = $1 if ($output =~ /<QueryKey>(\d+)<\/QueryKey>/);
my $count = $1 if ($output =~ /<Count>(\d+)<\/Count>/);
#retrieve data in batches of 500
my $retmax = 500;
for (my $retstart = 0; $retstart < $count; $retstart += $retmax) {
my $efetch_url = $base ."efetch.fcgi?db=pubmed&WebEnv=$web";
$efetch_url .= "&query_key=$key&retmode=xml";
my $efetch_out = get($efetch_url);
my #matches = $efetch_out =~ m(<Affiliation>(.*)</Affiliation>)g;
#print "$_\n" for #matches;
for my $match (#matches){
if ($match=~/\s([a-zA-Z0-9\.\_\-]+\#[a-zA-Z0-9\.\_\-]+)$/){
my $email=$1;
$email=~s/\.$//;
$emails{$email}++;
}
}
}
my $cnt= keys %emails;
print "$query\n$cnt\n";
}
print "Total number of emails: ";
my $cnt= keys %emails;
print "$cnt\n";
my #email = keys %emails;
my #VAR;
push #VAR, [ splice #email, 0, 100 ] while #email;
my $batch=100;
foreach my $VAR (#VAR){
open(OUT, ">Set_$batch\.txt") || die "Can't open file!\n";
print OUT join(",",#$VAR);
close OUT;
$batch=$batch+100;
}

I recommend against using LWP::Simple for any reason because it is impossible to configure it or handle errors usefully. Using LWP::UserAgent which it wraps is nearly as simple anyway (though the error handling is a bit complicated). The below examples would replace the use LWP::Simple; and my $output = get($url); lines.
use strict;
use warnings;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new(timeout => 30);
my $response = $ua->get($url);
unless ($response->is_success) {
# the Client-Warning, Client-Aborted, and X-Died headers each may be set on client/transport errors
die $response->status_line;
}
my $output = $response->decoded_content;
The core HTTP::Tiny is also simple.
use strict;
use warnings;
use HTTP::Tiny;
my $ua = HTTP::Tiny->new;
my $response = $ua->get($url);
unless ($response->{success}) {
die $response->{status} == 599 ? $response->{content} : "$response->{status} $response->{reason}";
}
my $output = $response->{content};
If you really want an LWP::Simple approach that will at least report transport errors, try ojo from Mojolicious:
perl -Mojo -E'say g(shift)->text' http://example.com
In a script rather than a oneliner, you can use Mojo::UserAgent directly, and also handle HTTP errors like above:
use strict;
use warnings;
use Mojo::UserAgent;
my $ua = Mojo::UserAgent->new;
my $response = $ua->get($url)->result;
unless ($response->is_success) {
die $response->code . ' ' . $response->message;
}
my $output = $response->text;

Related

Error Cisco Prime HTTP GET request

I'm trying to make an HTTP GET request with Cisco Prime:
#!/opt/local/bin/perl -w
use strict;
use JSON-support_by_pp;
use LWP 5.64;
use LWP::UserAgent;
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
my $ua = LWP::UserAgent->new;
my $BASE_URL = 'https://Host_name/webacs/api/v1/';
my $UN = "Username";
my $PW = "Password";
sub fetch ($) {
my ( $url ) = #_;
my $req = HTTP::Request->new( GET => $BASE_URL . $url );
$req->authorization_basic( $UN, $PW );
return $ua->request( $req )->content or die( "Cannot read from " . $BASE_URL . $url );
}
my $content = fetch( 'data/AccessPoints.json?.full=true' );
my $json = new JSON;
# these are some nice json options to relax restrictions a bit:
my $json_text =
$json->allow_nonref->utf8->relaxed->escape_slash->loose->allow_singlequote->allow_barekey->decode( $content );
foreach my $ap ( #{ $json_text->{queryResponse}->{'entity'} } ) {
print "------------------------\nAccess Point " . $ap->{'accessPointsDTO'}->{'#id'} . "\n";
print "Model:" . $ap->{'accessPointsDTO'}->{'model'} . "\n";
print "MAC Address:" . $ap->{'accessPointsDTO'}->{'macAddress'} . "\n";
print "Serial Number:" . $ap->{'accessPointsDTO'}->{'serialNumber'} . "\n";
print "Software Version:" . $ap->{'accessPointsDTO'}->{'softwareVersion'} . "\n";
print "Status:" . $ap->{'accessPointsDTO'}->{'status'} . "\n";
print "Location:" . $ap->{'accessPointsDTO'}->{'location'} . "\n";
What do I do wrong? I have already tried with curl in shell and it works:
curl --tlsv1 --user USER:PASSWORD--insecure https://Host_name/webacs/api/v1/data/AccessPoints.json?.full=true
but my Perl script doesn't work.
I have this error:
malformed JSON string, neither array, object, number, string or atom, at character offset 0 (before "Can't connect to 10....") at ersteProbe.pl line 28.
Fix already. Thank you Borodin :)
New question:
I need authentication for Cisco Prime.
Code works already, but authentication doesn't work.
I have with error
500 Can't connect to 10.10.10.10:443 (certificate verify failed) at ersteProbeAuth.pl line 27.
Line 27:
die $res->status_line unless $res->is_success;
I'm rather new in Perl und cann't fix this myself. If you have Idee, I'll be happy :)
#!/opt/local/bin/perl -w
use strict;
use warnings;
use JSON -support_by_pp;
use LWP 5.64;
use LWP::UserAgent;
use MIME::Base64;
use REST::Client;
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
my $ua = LWP::UserAgent->new;
my $BASE_URL = 'https://10.10.10.10/webacs/api/v1/';
my $UN='admin';
my $PW='admin';
# coding with Base 64
my $sys_id='Balalalalalal';
my $encoded_auth = encode_base64("$UN:$PW", '');
sub fetch {
my ($url) = #_;
my $res = $ua->get($BASE_URL . $url,
{'Authorization' => "Basic $encoded_auth",
'Accept' => 'application/json'});
die $res->status_line unless $res->is_success;
my $json = $res->decoded_content;
return $json
}
my $content = fetch('data/AccessPoints.json?.full=true/$sys_id');
my $json = new JSON;
# these are some nice json options to relax restrictions a bit: my$json_text=$json->allow_nonref->utf8->relaxed->escape_slash->loose->allow_singlequote->allow_barekey->decode($content);
foreach my $ap (#{$json_text->{queryResponse}->{'entity'}}){
print "------------------------\nAccess Point ".$ap->{'accessPointsDTO'}->{'#id'}."\n";
print "Model:".$ap->{'accessPointsDTO'}->{'model'}."\n";
print "MAC Address:".$ap->{'accessPointsDTO'}->{'macAddress'}."\n";
print "Serial Number:".$ap->{'accessPointsDTO'}->{'serialNumber'}."\n";
print "Software Version:".$ap->{'accessPointsDTO'}->{'softwareVersion'}."\n";
print "Status:".$ap->{'accessPointsDTO'}->{'status'}."\n";
print "Location:".$ap->{'accessPointsDTO'}->{'location'}."\n";
}
It's hard to tell what's wrong without access to the web page, but almost certainly your request has failed
I suggest you replace your fetch subroutine with this
sub fetch {
my ( $url ) = #_;
my $res = $ua->get( $BASE_URL . $url );
die $res->status_line unless $res->is_success;
my $json = $res->decoded_content;
return $json;
}
Print your raw answer from server in console.
malformed JSON string, neither array, object, number, string or atom, at character offset 0 (before "Can't connect to 10....")
"Can't connect to 10...."
Maybe, your code is not have connect

Perl HTTP::Request and Server Down

I have a perl script that is supposed to use HTTP::Response to grab an XML file and then parse it. The script works great, except when it can't reach the server its trying to get the info from.
I know I have to have an error checking and if an error does exist, use a return to continue on with the loop, I have done with with NET::SNMP and SSH, but I can't seem to get it working for this scenario. I'm about to be pull my hair in frustration. Any help is greatly appreciated.
#! /usr/bin/perl
use LWP::UserAgent;
use HTTP::Request::Common;
use Net::SNMP;
use XML::Simple;
use HTTP::Status;
$ua = LWP::UserAgent->new;
if ( open ( FH, "DeviceList.txt" ) )
{
while ( defined ( my $line = <FH> ) )
{
$line =~ s/\s+$//;
$device = $line;
&checkcon;
}
close FH;
}
else
{
print "DeviceList.txt file not found\n";
}
#exit;
sub checkcon
{
my ($req, $error) = HTTP::Request->new(GET => 'https://'.$device.'/getxml?location=/HelloWorld');
$ua->ssl_opts(SSL_verify_mode => SSL_VERIFY_NONE);
$ua->timeout(10);
$req->authorization_basic('test', 'test');
$test = $ua->request($req)->content;
print $req;
if ($test =~ "parser error") {
print "No Workie\n";
return;
}
#if (!is_success ($req))
#{
#print "No Workie!";
#return;
#}
# create object
my $xml = new XML::Simple;
# read XML file
my $data = $xml->XMLin("$test");
print "Looping";
# access XML data
`echo "$device,$data->{Hello}{World}{content}" >> Test.txt`;
}
exit 0;

Perl resume download from this script

I have this Perl-based download script.
I'd like to know how to make sure that when a user downloads a file with this script, can pause and resume the download (download resumable).
This is the code:
#!/usr/bin/perl
use XFSConfig;
use HCE_MD5;
use CGI::Carp qw(fatalsToBrowser);
my $code = (split('/',$ENV{REQUEST_URI}))[-2];
my $hce = HCE_MD5->new($c->{dl_key},"XFileSharingPRO");
my ($file_id,$file_code,$speed,$ip1,$ip2,$ip3,$ip4,$expire) = unpack("LA12SC4L", $hce->hce_block_decrypt(decode($code)) );
print("Content-type:text/html\n\nLink expired"),exit if time > $expire;
$speed||=500;
my $dx = sprintf("%05d",$file_id/$c->{files_per_folder});
my $ip="$ip1.$ip2.$ip3.$ip4";
$ip=~s/\.0$/.\\d+/;
$ip=~s/\.0\./.\\d+./;
$ip=~s/\.0\./.\\d+./;
$ip=~s/^0\./\\d+./;
print("Content-type:text/html\n\nNo file"),exit unless -f "$c->{upload_dir}/$dx/$file_code";
print("Content-type:text/html\n\nWrong IP"),exit if $ip && $ENV{REMOTE_ADDR}!~/^$ip/;
my $fsize = -s "$c->{upload_dir}/$dx/$file_code";
$|++;
open(my $in_fh,"$c->{upload_dir}/$dx/$file_code") || die"Can't open source file";
# unless($ENV{HTTP_ACCEPT_CHARSET}=~/utf-8/i)
# {
# $fname =~ s/([^A-Za-z0-9\-_.!~*'() ])/ uc sprintf "%%%02x",ord $1 /eg;
# $fname =~ tr/ /+/;
# }
print qq{Content-Type: application/octet-stream\n};
print qq{Content-length: $fsize\n};
#print qq{Content-Disposition: attachment; filename="$fname"\n};
print qq{Content-Disposition: attachment\n};
print qq{Content-Transfer-Encoding: binary\n\n};
$speed = int 1024*$speed/10;
my $buf;
while( read($in_fh, $buf, $speed) )
{
print $buf;
select(undef,undef,undef,0.1);
}
sub decode
{
$_ = shift;
my( $l );
tr|a-z2-7|\0-\37|;
$_=unpack('B*', $_);
s/000(.....)/$1/g;
$l=length;
$_=substr($_, 0, $l & ~7) if $l & 7;
$_=pack('B*', $_);
}
Thanks
To pause and resume downloads you should handle the http range header.
Take a look at http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.35

perl hash declaration error

I am new to perl and can't seem to find why this snippet is giving me a 500 error.
#!/usr/bin/perl
use strict;
use warnings;
use CGI::Carp qw( fatalsToBrowser );
my ($distance, $weight, $total_gas, $mph, $buffer, $pair, #pairs, $value, $form, $name);
our %FORM = ();
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
#pairs = split(/&/, $buffer);
foreach $pair (#pairs) {
($name, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$FORM{$name} = $value;
}
Everything I tried on the %FORM = (); gives me variable declaration errors.
Are you certain that #pairs contains the values you expect (ie that they are name value pairs split with "="? More than likely $name isn't defined and you can't add an undefined key pair to a hash. Why are you using STDIN to read in values from the query string? Try:
my $q = CGI->new;
my #keys = $q->param;
my %FORM;
foreach my $name (#keys)
{
my $value = $q->param($name);
$FORM{$name} = $value;
}
or
my $q = CGI->new;
my %FORM = $q->Vars;
http://perldoc.perl.org/CGI.html
I think you're missing HTTP header. Try adding to put following line before any print:
print "Content-type: text/html\n\n";
Make sure you have enough permissions for script to run. It'll depend on OS you're using.
Also you'd consider using CGI module as mentioned in scrappedcola's answer. This code will work for both POST and GET:
use strict; use warnings;
use CGI;
my $form = CGI->Vars;
print "Content-type: text/html\n\n";
print "name=".$form->{name};

Why do I get a blank page from my Perl CGI script?

The user enters a product code, price and name using a form. The script then either adds it to the database or deletes it from the database. If the user is trying to delete a product that is not in the database they get a error message. Upon successful adding or deleting they also get a message. However, when I test it I just get a blank page. Perl doesnt come up with any warnings, syntax errors or anything; says everything is fine, but I still just get a blank page.
The script:
#!/usr/bin/perl
#c09ex5.cgi - saves data to and removes data from a database
print "Content-type: text/html\n\n";
use CGI qw(:standard);
use SDBM_File;
use Fcntl;
use strict;
#declare variables
my ($code, $name, $price, $button, $codes, $names, $prices);
#assign values to variables
$code = param('Code');
$name = param('Name');
$price = param('Price');
$button = param('Button');
($code, $name, $price) = format_input();
($codes, $names, $prices) = ($code, $name, $price);
if ($button eq "Save") {
add();
}
elsif ($button eq "Delete") {
remove();
}
exit;
sub format_input {
$codes =~ s/^ +//;
$codes =~ s/ +$//;
$codes =~ tr/a-z/A-Z/;
$codes =~ tr/ //d;
$names =~ s/^ +//;
$names =~ s/ +$//;
$names =~ tr/ //d;
$names = uc($names);
$prices =~ s/^ +//;
$prices =~ s/ +$//;
$prices =~ tr/ //d;
$prices =~ tr/$//d;
}
sub add {
#declare variable
my %candles;
#open database, format and add record, close database
tie(%candles, "SDBM_File", "candlelist", O_CREAT|O_RDWR, 0666)
or die "Error opening candlelist. $!, stopped";
format_vars();
$candles{$codes} = "$names,$prices";
untie(%candles);
#create web page
print "<HTML>\n";
print "<HEAD><TITLE>Candles Unlimited</TITLE></HEAD>\n";
print "<BODY>\n";
print "<FONT SIZE=4>Thank you, the following product has been added.<BR>\n";
print "Candle: $codes $names $prices</FONT>\n";
print "</BODY></HTML>\n";
} #end add
sub remove {
#declare variables
my (%candles, $msg);
tie(%candles, "SDBM_File", "candlelist", O_RDWR, 0)
or die "Error opening candlelist. $!, stopped";
format_vars();
#determine if the product is listed
if (exists($candles{$codes})) {
delete($candles{$codes});
$msg = "The candle $codes $names $prices has been removed.";
}
else {
$msg = "The product you entered is not in the database";
}
#close database
untie(%candles);
#create web page
print "<HTML>\n";
print "<HEAD><TITLE>Candles Unlimited</TITLE></HEAD>\n";
print "<BODY>\n";
print "<H1>Candles Unlimited</H1>\n";
print "$msg\n";
print "</BODY></HTML>\n";
}
Running it at the command line with:
perl something.cgi Button=Save
...gives me an error:
Undefined subroutine &main::format_vars called at something.pl line 55.
If I change both references of format_vars() to "format_input()", I get what I think is the proper output.
You're not printing any output aside from the Content-Type header unless add or remove gets called. The problem is just that you forgot to display a form (presumably one containing the buttons) if no button has been clicked.
Edit: Copying your posted code and doing a little cleanup, then calling it at the URL http://localhost/~me/foo.cgi?Code=1;Name=2;Price=3;Button=Save or http://localhost/~me/foo.cgi?Code=1;Name=2;Price=3;Button=Delete, I do get proper HTML output. The cleaned up version of the code used for this is:
#!/usr/bin/perl
use strict;
use warnings;
print "Content-type: text/html\n\n";
use CGI qw(:standard);
use SDBM_File;
use Fcntl;
use strict;
#declare variables
my ($code, $name, $price, $button, $codes, $names, $prices);
#assign values to variables
$code = param('Code');
$name = param('Name');
$price = param('Price');
$button = param('Button');
($code, $name, $price) = format_input();
($codes, $names, $prices) = ($code, $name, $price);
if ($button eq "Save") {
add();
}
elsif ($button eq "Delete") {
remove();
}
exit;
sub format_input {
$codes =~ s/^ +//;
$codes =~ s/ +$//;
$codes =~ tr/a-z/A-Z/;
$codes =~ tr/ //d;
$names =~ s/^ +//;
$names =~ s/ +$//;
$names =~ tr/ //d;
$names = uc($names);
$prices =~ s/^ +//;
$prices =~ s/ +$//;
$prices =~ tr/ //d;
$prices =~ tr/$//d;
}
sub add {
# #declare variable
# my %candles;
#
# #open database, format and add record, close database
# tie(%candles, "SDBM_File", "candlelist", O_CREAT|O_RDWR, 0666)
# or die "Error opening candlelist. $!, stopped";
#
# format_vars();
# $candles{$codes} = "$names,$prices";
# untie(%candles);
#create web page
print "<HTML>\n";
print "<HEAD><TITLE>Candles Unlimited</TITLE></HEAD>\n";
print "<BODY>\n";
print "<FONT SIZE=4>Thank you, the following product has been added.<BR>\n";
print "Candle: $codes $names $prices</FONT>\n";
print "</BODY></HTML>\n";
} #end add
sub remove {
# #declare variables
# my (%candles, $msg);
#
# tie(%candles, "SDBM_File", "candlelist", O_RDWR, 0)
# or die "Error opening candlelist. $!, stopped";
#
# format_vars();
#
# #determine if the product is listed
# if (exists($candles{$codes})) {
# delete($candles{$codes});
# $msg = "The candle $codes $names $prices has been removed.";
# }
# else {
# $msg = "The product you entered is not in the database";
# }
# #close database
# untie(%candles);
#create web page
print "<HTML>\n";
print "<HEAD><TITLE>Candles Unlimited</TITLE></HEAD>\n";
print "<BODY>\n";
print "<H1>Candles Unlimited</H1>\n";
# print "$msg\n";
print "<p>Called remove</p>";
print "</BODY></HTML>\n";
}
Note that, with warnings enabled, this spews a lot of "uninitialized value" warnings because you're getting $code vs $codes, $name vs $names, and $price vs $prices confused with each other in bad ways. (Hint: You assign ($code, $name, $price) = format_input();, but format_input doesn't return three values.)
I suspect that, as suggested in an earlier comment, you're having case-sensitivity issues again/still. My first attempt at testing this failed because I used "button=Save" instead of "Button=Save" in the URL. HTTP request parameter names are generally all-lowercase by convention, and for good reason, as it helps to avoid problems of that sort.
Other random comments:
You can declare your variables at the same time as you first assign them, e.g., my $code = param('Code');. This is generally considered to be the better/preferred practice, as making your declaration as late as possible helps to minimize the variable's scope.
In format_input, it's redundant to both s/^ +//; s/ +$//; and tr/ //d;, as the tr will also remove leading and trailing spaces.
When getting values of your parameters, you should either supply default values for if the parameter is empty/missing or check for empty/missing and display an error to the user.
You should also have a final else clause after the elsif ($button eq "Delete") to display an error if $button is missing or invalid. Yes, I know this script is intended to be called from a specific form, so it should "always" have a valid $button, but it's trivial to bypass the form and submit any set of values (valid or not) to the script directly, so you still need to verify and validate everything on the server side because you don't know where it will actually be coming from or whether the client validated it properly.
This is how I ran the script and it did yield the proper results. Make sure wherever you are hosting the site, it has the proper PERL modules installed.
Note: The hosting service I am using (BlueHost) requires me to call up my Perl Modules via the #!/usr/bin/perlml
#!/usr/bin/perlml
use strict;
use warnings;
print "Content-type: text/html\n\n";
use CGI qw(:standard);
use SDBM_File;
use Fcntl;
use strict;
#declare variables
my ($code, $name, $price, $button, $codes, $names, $prices);
#assign values to variables
$code = param('Code');
$name = param('Name');
$price = param('Price');
$button = param('Button');
($codes, $names, $prices) = format_input();
($codes, $names, $prices) = ($code, $name, $price);
if ($button eq "Save") {
add();
}
elsif ($button eq "Delete") {
remove();
}
exit;
sub format_input {
$codes =~ s/^ +//;
$codes =~ s/ +$//;
$codes =~ tr/a-z/A-Z/;
$codes =~ tr/ //d;
$names =~ s/^ +//;
$names =~ s/ +$//;
$names =~ tr/ //d;
$names = uc($names);
$prices =~ s/^ +//;
$prices =~ s/ +$//;
$prices =~ tr/ //d;
$prices =~ tr/$//d;
}
sub add {
#declare variable
my %candles;
#open database, format and add record, close database
tie(%candles, "SDBM_File", "candlelist", O_CREAT|O_RDWR, 0666)
or die "Error opening candlelist. $!, stopped";
format_input();
$candles{$code} = "$name,$price";
untie(%candles);
#create web page
print "<HTML>\n";
print "<HEAD><TITLE>Candles Unlimited</TITLE></HEAD>\n";
print "<BODY>\n";
print "<FONT SIZE=4>Thank you, the following product has been added.<BR>\n";
print "Candle: $codes, $names, $prices</FONT>\n";
print "</BODY></HTML>\n";
} #end add
sub remove {
#declare variables
my (%candles, $msg);
tie(%candles, "SDBM_File", "candlelist", O_RDWR, 0)
or die "Error opening candlelist. $!, stopped";
format_input();
#determine if the product is listed
if (exists($candles{$code})) {
delete($candles{$code});
$msg = "The candle $code, $name, $price has been removed.";
}
else {
$msg = "The product you entered is not in the database";
}
#close database
untie(%candles);
#create web page
print "<HTML>\n";
print "<HEAD><TITLE>Candles Unlimited</TITLE></HEAD>\n";
print "<BODY>\n";
print "<H1>Candles Unlimited</H1>\n";
print "$msg\n";
print "</BODY></HTML>\n";
}