download url content of the cgi web page - perl

I have cgi search engine for local flat database search and I would like to add option the user able to export/download the search result. is that possible with cgi?
this is the code.
#!/usr/bin/perl
read(STDIN, $buffer,$ENV{'CONTENT_LENGTH'});
# Split the name-value pairs
#pairs = split(/&/, $buffer);
foreach $pair (#pairs) {
($key, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$formdata{$key}.= "$value";
}
$search = $formdata{'search'};
open(INFO, "/test.txt");
#array=<INFO>;
close (INFO);
print "Content-type:text/html\n\n";
print "<html>\n";
print "<head><title>Search result</title></head>\n";
print "<body>\n";
print "<h4><font color=#990000>This is your search result!</h4>\n";
$search_url = 'https://test.php';
foreach $line (#array) {
if ($line =~ /$search/){
($host,$ip)=split(/\|/,$line);
$records= ++$counter;
#result =($host,$ip);
print "<font color=#7a378b><b><p>";
print "<table border=0 cellpadding=0 cellspacing=0 style=border-collapse: collapse
bordercolor=#111111 width=20% bgcolor=#C0C0C0>";
print "</tr>";
foreach (#result) {
#words = split ;
print "<tr><td width=33% bgcolor=#DCDCDC><b><font color=#000080 size=1 face=Courier New>$words[0]</font></b></td>";
print "<td width=36% bgcolor=#DCDCDC><b><font color=#000080 size=1 face=Courier
New>$words[1]</font></b></td>";
print "</table>";
}
}
}
if ($records== 0) {
print " Sorry! No records found\n";
}


Yes. The conventional way is to output the appropriate content type header, e.g.
Content-type: text/csv
Content-type: text/xml
and optionally to specify a "content disposition" as well. In conforming browsers, this will give the client the option to save the server's output to a local file:
Content-disposition: attachment;filename="myfilename.csv"
(Edit to use friedo's wise suggestion)

Related

Perl code modifie logs

I want to program a perl script to change logs format. I want to remove --- from logs. Then separate the CRLF by |.
basically I want to obtain this result :
INFO|[ACTIVE] ExecuteThread: '0' for queue: 'weblogic.kernel.Default (self-tuning)'|JB173F3N|17/02/15 14:32:03:930|Inbound Message | ID: 5 Response-Code: 200 | Encoding: UTF-8 | Content-Type: application/soap+xml; charset=utf-8 | Headers: {connection=[close], Content-Length=[650], content-type=[application/soap+xml; charset=utf-8], Date=[Tue, 17 Feb 2015 13:32:03 GMT], Server=[Apache], X-Powered-By=[Servlet/2.5 JSP/2.1]} | Payload: <?xml version="1.0" encoding="UTF-8"?> | <soap:Envelope xmlns:soap="http://www.w3.org/2003/05/soap-envelope"><soap:Header/><soap:Body><con:Reponse xmlns:con="http://www.erdfdistribution.fr/linky/types/smc/consultation"><con:IdPRM>19136758109411</con:IdPRM><con:CR><dico:Statut xmlns:dico="http://www.erdfdistribution.fr/linky/types/dico">Rejet</dico:Statut><dico:HorEmission xmlns:dico="http://www.erdfdistribution.fr/linky/types/dico">2015-02-17T14:32:03.887+01:00</dico:HorEmission><dico:Detail xmlns:dico="http://www.erdfdistribution.fr/linky/types/dico"><dico:Code>REJ016</dico:Code></dico:Detail></con:CR></con:Reponse></soap:Body></soap:Envelope>
Instead of this One:
INFO|[ACTIVE] ExecuteThread: '0' for queue: 'weblogic.kernel.Default (self-tuning)'|JB173F3N|17/02/15 14:32:03:930|Inbound Message
----------------------------
ID: 5
Response-Code: 200
Encoding: UTF-8
Content-Type: application/soap+xml; charset=utf-8
Headers: {connection=[close], Content-Length=[650], content-type=[application/soap+xml; charset=utf-8], Date=[Tue, 17 Feb 2015 13:32:03 GMT], Server=[Apache], X-Powered-By=[Servlet/2.5 JSP/2.1]}
Payload: <?xml version="1.0" encoding="UTF-8"?>
<soap:Envelope xmlns:soap="http://www.w3.org/2003/05/soap-envelope"><soap:Header/><soap:Body><con:Reponse xmlns:con="http://www.erdfdistribution.fr/linky/types/smc/consultation"><con:IdPRM>19136758109411</con:IdPRM><con:CR><dico:Statut xmlns:dico="http://www.erdfdistribution.fr/linky/types/dico">Rejet</dico:Statut><dico:HorEmission xmlns:dico="http://www.erdfdistribution.fr/linky/types/dico">2015-02-17T14:32:03.887+01:00</dico:HorEmission><dico:Detail xmlns:dico="http://www.erdfdistribution.fr/linky/types/dico"><dico:Code>REJ016</dico:Code></dico:Detail></con:CR></con:Reponse></soap:Body></soap:Envelope>
--------------------------------------
My code doesnt do this, it makes something like clustering in the same line :(
This is my code :
#!/usr/bin/perl
use strict;
use warnings;
use File::Basename;
use Time::Piece;
my $num_args = $#ARGV + 1;
if ($num_args != 2) {
print "\nUsage: Modif_Log.pl inputDirectory outputDirectory\n";
exit;
}
my $inputDirectory=$ARGV[0];
my $outputDirectory=$ARGV[1];
my #liste = glob($inputDirectory."*.log*");
my $today = localtime->strftime('%d%m');
foreach my $s (#liste){
my $inbound ="";
my $outbound ="";
my $id ="";
my $encoding ="";
my $httpMethod ="";
my $contentType ="";
my $headers ="";
my $payload ="";
my $responseCode ="";
my $theAdress ="";
my $others ="";
open ( FILE, $inputDirectory.basename($s) ) || die "can't open file!";
if (-M $inputDirectory.basename($s) < 1 && $s =~ $today) {
print "Processing ".$s."\n";
my #lines = <FILE>;
close (FILE);
my $outputFileName = basename($s);
$outputFileName =~ s/_[0-9]{6}//;
open(my $outputFile, '>', $outputDirectory.$outputFileName) or die "can't open file!";
foreach my $line (#lines) {
chomp($line);
if ($line =~ /Inbound/i) { $inbound .= $line."|"; }
elsif ($line =~ /Outbound/i) { $outbound .= $line."|"; }
elsif ($line =~ /^ID:/) { $id .= $line."|"; }
elsif ($line =~ /^Encoding :/) { $encoding .= $line."|"; }
elsif ($line =~ /^Http-Method:/) { $httpMethod .= $line."|"; }
elsif ($line =~ /^Content-Type:/) { $contentType .= $line."|"; }
elsif ($line =~ /^Headers:/) { $headers .= $line."|"; }
elsif ($line =~ /^Payload:/) { $payload .= $line."|"; }
elsif ($line =~ /^Response-Code:/) { $responseCode .= $line."|"; }
elsif ($line =~ /^Address:/) { $theAdress .= $line."|"; }
elsif ($line !~ /--/) { $others .= $line."|"; }
else { ; }
}
if ($inbound ne "") { print $outputFile $inbound."\n"; }
if ($outbound ne "") { print $outputFile $outbound."\n"; }
if ($id ne "") { print $outputFile $id."\n"; }
if ($encoding ne "") { print $outputFile $encoding."\n"; }
if ($httpMethod ne "") { print $outputFile $httpMethod."\n"; }
if ($contentType ne "") { print $outputFile $contentType."\n"; }
if ($headers ne "") { print $outputFile $headers."\n"; }
if ($payload ne "") { print $outputFile $payload."\n"; }
if ($responseCode ne "") { print $outputFile $responseCode."\n"; }
if ($theAdress ne "") { print $outputFile $theAdress."\n"; }
if ($others ne "") { print $outputFile $others."\n"; }
close $outputFile;
print "Finished Processing ".$s."\n";
} else {
print $s." is older than one day\n";
}
}
Can you please help me ? Perl is turning me creasy

Remove bunch of if-statements and change your forloop as following:
my $buf = q{};
my $last = q{};
my $sep_count = 0;
my $line_number = 0;
foreach my $line (#lines) {
# remove CRLF, chomp only eliminate LF
$line =~ s/\R+//;
$line_number++;
if ($line =~ /^-+$/) {
# if the line is a separator
$sep_count++;
if ($sep_count & 1) {
# begin sep ($sep_count is an odd number)
$buf = $last;
}
else {
# end sep ($sep_count is an even number)
print {$outputFile} "$buf\n";
}
}
else {
if ($sep_count & 1) {
$buf .= ' | ' . $line;
}
else {
# flush $last except for the first line
print {$outputFile} "$last\n" if $line_number != 1;
}
# keep last line (INFO...) to concat
$last = $line;
}
}
print {$outputFile} "$last\n";

Your list of strings are just values that must appear in a line of the input file for it to be included in the output. There is no need to store lines in different variables according to which criterion it matched
This program appears to do what you need. It builds a regular expression from the list of strings so that they can all be tested in a single match. The lines to be printed are accumulated in array #output and printed to the output file when the whole input file has been processed
Note that I've used rel2abs to append a file name to a directory. It takes account of several cases that simple string concatenation doesn't allow for, as well as making the code clearer
I haven't been able to test this except to make sure that it compiles
#!/usr/bin/perl
use strict;
use warnings;
use File::Basename;
use Time::Piece;
use File::Spec::Functions 'rel2abs';
if ( #ARGV != 2 ) {
die "\nUsage: Modif_Log.pl input_dir output_dir\n";
}
my ( $input_dir, $output_dir ) = #ARGV;
my $today = localtime->strftime('%d%m');
my #liste = glob rel2abs( '*.log*', $input_dir );
my #wanted = (
qr/Inbound/i,
qr/Outbound/i,
qr/^ID:/,
qr/^Response-Code:/,
qr/^Encoding :/,
qr/^Http-Method:/,
qr/^Content-Type:/,
qr/^Headers:/,
qr/^Payload:/,
qr/^Address:/,
);
my $wanted = join '|', #wanted;
$wanted = qr/(?:$wanted)/;
for my $input_file ( #liste ) {
unless ( -M $input_file < 1 and $input_file =~ $today ) {
warn qq{"$input_file" is older than one day\n};
next;
}
warn qq{Processing "$input_file"\n};
open my $in_fh, '<', $input_file die qq{Unable to open "$input_file" for input: $!};
my #output;
while ( <$fh> ) {
next unless /$wanted/;
chomp;
push #output, $_;
}
my $output_file_name = basename($input_file);
$output_file_name =~ s/_[0-9]{6}//;
my $output_file = rel2abs($output_file_name, $output_dir);
open my $out_fh, '>', $output_file
or die qq{Unable to open "$output_file" for output: $!};
print $out_fh join(' | ', #output), "\n";
warn qq{Finished Processing "$input_file"\n};
}

Perl DBI — ignore few columns in output

I've used this code:
while (my $line = <IN>)
{
chomp $line;
if($line =~ /(.*?: )\{(.+)\}/)
{
my $value2 = $2;
my #values2 = split(/,/, $value2);
my $insertKeys;
my $insertValues;
foreach $data(#values2)
{
chomp $data;
my ($key, $value) = split(/:/, $data);
$key =~ s/"//g;
$value =~ s/"/'/g;
$insertKeys .= $key.',';
$insertValues .= $value.',';
}
Input:
"actor_ip":"127.0.0.1" "note":"From Git" "user":"Username for 'https" "user_id":null "actor":"Username for 'https" "actor_id":null "org_id":null "action":"user.failed_login" "created_at":1412256345456789 "data":{"actor_location":{"location":{"lat":null "lon":null}}}
Output:
KEYS: actor_ip,note,user,user_id,actor,actor_id,org_id,action,created_at,data,lon,
VALUES: '127.0.0.1','From Git','Username for 'https',null,'Username for 'https',null,null,'user.failed_login',1412256456789,{'actor_location',null
I want to remove these two key and values from output Please let me know how to regex these below
"user":"Username for 'https"
"data":{"actor_location":{"location":{"lat":null "lon":null}}}

You simply need to exclude the keys you don't want:
if ($key !~ /^(data|user)$/)
{
$insertKeys .= $key.',';
$insertValues .= $value.',';
}
However, a more flexible design might be to insert key/value pairs into a hash:
my %params;
foreach $data(#values2)
{
chomp $data;
my ($key, $value) = split(/:/, $data);
$key =~ s/"//g;
$value =~ s/"/'/g;
$params{$key} = $value;
}
Then it would be easy to do whatever you want with the parameters later.
Also, you don't show your DBI code, but this code suggests you are manually building the whole insert query string. A safer (and better-designed) approach would be a parameterized query.

Split a line on every 16th comma

I am using perl to extract "Yes," or "No," from a large CSV, and output to a file using this code
open my $fin, "leads.csv";
my $str;
for (<$fin>) {
if (/^\s*\d+\.\s*(\w+)/) {
$str .= $1 . ",";
}
}
open (MYFILE, '>>data.txt');
print MYFILE $str;
close (MYFILE);
This is working correctly, and outputting data like this http://pastebin.com/r7Lwwz8p, however I need to break
to a new line after the 16th element so it looks like this on output: http://pastebin.com/xC8Lyk5R
Any tips/tricks greatly appreciated!

The following splits a line by commas, and then regroups them by 16 elements:
use strict;
use warnings;
while (my $line = <DATA>) {
chomp $line;
my #fields = split ',', $line;
while (my #data = splice #fields, 0, 16) {
print join(',', #data), "\n";
}
}
__DATA__
LineA,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,LineB,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,LineC,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,LineD,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,LineE,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,LineF,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,LineG,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,LineH,2,3,4,5,6,7,8,9,10,11,12
Outputs:
LineA,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
LineB,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
LineC,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
LineD,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
LineE,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
LineF,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
LineG,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
LineH,2,3,4,5,6,7,8,9,10,11,12

Use a variable to count the number of yes/no matches that you find, and then use the mod (%) operator to insert a newline into the string.
#!/usr/bin/perl
use strict;
use warnings;
open my $fin, "leads.csv";
my $str;
my $count = 0;
for (<$fin>) {
if (/^\s*\d+\.\s*(\w+)/) {
$str .= $1 . ",";
$count++;
}
$str .= "\n" unless ($count % 16);
}
open (MYFILE, '>>data.txt');
print MYFILE $str;
close (MYFILE);

How convert text into XML using perl?

input text file contain the following:
....
ponies B-pro
were I-pro
used I-pro
A O
report O
of O
indirect B-cd
were O
. O
...
output XML file
<sen>
<base id="pro">
<w id="1">ponies</w>
<w id="2">were</w>
<w id="3">were</w>
</base>A report of
<base id="cd">indirect</base> were
</sen>
i want to make an XML file by reading the text file, B- means the begining of my tag and I- means an include words inside the tag while "O" means outside the base tag which means it only exist in the tag.
i try the following codes:
#!/usr/local/bin/perl -w
open(my $f, "input.txt") or die "Can't";
open(my $o, ">output.xml") or die "Can't";
my $c;
sub read_line {
my $fh = shift;
if ($fh and my $line = <$fh>) {
chomp($line);
my #words = split(/\t/, $line);
my $word = $words[0];
my $group = $words[1];
if($word eq "."){
return;
}
else{
if($group ne 'O'){
my #b = split(/\-/, $group);
if($b[0] eq 'B'){
my $e = "<e id=\"";
$e .= " . $b[1] . "\">";
$e .= $word . "</e>";
return $e;
}
if($b[0] eq 'I'){
my $w = "<w id=\"";
$w .= $c . "\">";
$w .= $word . "</w>";
$c++;
return $w;
}
}
else{
$c = 2;
return $word;
}
}
}
return;
}
sub get_text(){
my $txt = "";
my $r = read_line($f);
while($r){
if($r =~ m/[[:punct:]]/){
chop($txt);
$txt .= " " . $r . " ";
}
else{
$txt .= $r . " ";
}
$r = read_line($f);
}
chop($txt);
return "<sen>" . $txt . ".</sen>";
}
instead im getting as output:
<sen>
<base id="pro"> ponies </base>
<w id="2">were</w>
<w id="3">were</w>
A report of
<base id="cd">indirect</base> were
</sen>
i really need help.
Thanks

Writing XML "by hand" will only get you in trouble. Use a module from CPAN.
In your case, I would first put the data in a proper Perl data structure (maybe a hash containing some arrays, or something similar) and then using a module (i.e. XML::Simple for starters) to output to a file.

As Javs said, you want to use a module rather than do this by hand. For your purposes, since you have mixed content, I recommend XML::LibXML. Here is an example I made to test that you can indeed to mixed content like you've got:
use XML::LibXML;
my $doc = XML::LibXML::Document->new();
my $root = $doc->createElement('html');
$doc->setDocumentElement($root);
my $body = $doc->createElement('body');
$root->appendChild($body);
my $link = $doc->createElement('a');
$link->setAttribute('href', 'http://google.com');
$link->appendText('Google');
$body->appendChild($link);
$body->appendText('Inline Text');
print $doc->toString;

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";
}