How convert text into XML using perl? - 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;

Related

Perl Script to query ebay and report on items that need relisting

Dear all I am trying to get a script working and have no clue where to start with the error being produced
sh: 1: Syntax error: redirection unexpected
My script is below and if anyone can help I would be very grateful
Tony
ebay.pl
#!/usr/bin/perl -w
system("/usr/local/bin/ebaycurl.sh");
open (ITEMS, "/usr/local/data/eBaystuff") or die "stuff $!";
while (<ITEMS>) {
chomp;
next unless /ViewItem\&amp/;
s/Item not relisted/Item_not_relisted/g;
s/Item relisted/Item_relisted/g;
#words = split;
$relist = "";
foreach $word (#words) {
if ($word =~ /ViewItem\&amp/) {
print "\n";
$print_it = 1;
$link = $word;
($junk, $link) = split /f=/, $word;
$link =~ s/&/&/g;
#system("/usr/local/bin/ebaycurlitem.sh $link >/dev/null 2>/dev/null");
system("/usr/local/bin/ebaycurlitem.sh $link");
open (ITEM, "/usr/local/data/eBayitem") or die "item $!";
$relist = "";
while (<ITEM>) {
next unless /Relist/;
$relist = 'relist';
}
#($junk, $itemid) = split /item=/, $link;
#$itemid =~ s/\"//;
print "$relist\t";
next;
}
if (defined $print_it) {
if ($word =~ /\>/) {
$print_it = undef;
($rem, $junk) = split />/, $word;
print "$rem";
} else {
$word =~ s/title=//;
print "$word ";
}
}
if ($word =~ /Item_not_relisted/ and $relist =~ /relist/) {print "\t\t\t\tNOT RELISTED";}
}
print "\n";
}
ebaycurl.sh
#!/bin/bash
$(COOKIE_DIR)="cat /usr/local/etc/ebay_cookie_dir)
(/usr/bin/curl --cookie "COOKIE_DIR"/cookies.txt 'http://k2b-bulk.ebay.co.uk/ws/eBayISAPI.dll?SalesRecordConsole&currentpage=SCSold&ssPageName=STRK:ME:LNLK; -o /usr/local/data/eBaystuff)"
There's a lot wrong with the bash script you posted. I recommend reading up on bash syntax cause it looks like you just threw parentheses and quotes in at random. Rather than explain each correction I'm just gonna post this and hope it's self-explanatory...
#!/bin/bash
COOKIE_DIR=$(cat /usr/local/etc/ebay_cookie_dir)
curl --cookie "$COOKIE_DIR"/cookies.txt -o /usr/local/data/eBaystuff \
'http://k2b-bulk.ebay.co.uk/ws/eBayISAPI.dll?SalesRecordConsole&currentpage=SCSold&ssPageName=STRK:ME:LNLK'

Start time always getting same in Perl for my script

I have made a script to extract the content of log files and to calculate the time difference if the task is complete.
Suppose I have four jobs and each job has thre individual tasks, so far I need the start of each task, and just print it.
Everything is fine except when I try to initialise to make it convenient, by using $j, $l which are used as sort of two-dimensional array.
The problem is at the output where I get the same "Started at" for each job.
The values of $counter and $l should be the root cause.
Can anyone help? I tried my best and am sort of newbie.
sub getdate {
my $line = $_[0];
($hrs, $min) = split(':', $line, 3);
return $hrs, $min;
}
print FILE "<html><head>\n";
print FILE "<title>CGI Test</title>\n";
print FILE "</head>\n";
print FILE "<body>";
print FILE "<font size=\"5\" color=\"#008080\" face=\"Tahoma\"><b><u><br>";
print FILE "PBI Batch for 22/02/2013";
print FILE "</font></b></u><br><br><br>";
my $i = 0;
my $j = 0;
my $l = 0;
my #sample;
#print FILE "<h4>";
foreach $header (<COLLECTION>) {
chomp($header);
($heading, $filepath) = split(',', $header);
#$two[$i]="<font size=\"3\"color=\"#008000\" face=\"Tahoma\"><b><u><br>";
#$two[$i]="<font size=\"3\" color=".$color." face=\"Tahoma\"><b><u><br>";
$two[$i] .= $heading;
#$two[$i] .= "</font></u></b><br>";
#print FILE "<font size=\"3\" color=\"#008000\" face=\"Tahoma\"><b><u><br>";
# print FILE $two[$i];
#print FILE $heading;
#print FILE "</font></u></b><br>";
#print $filepath."\n";
open(MYFILE1, $filepath) or die 'Could nont openfile';
my $counter;
foreach $list (<MYFILE1>) {
chomp($list);
($file, $path) = split(',', $list);
#print FILE $file;
my #secondstart;
my #secondend;
my $secondcounter = 0;
#print FILE "valueofllllllllllllllllllllllllllll".$l;
foreach $counter ($file) {
print FILE "valueofllllllllllllllllllllllllllll" . $l;
$l++;
$sample[$j][$l] = $counter;
print FILE "secCOUNTER " . $secondcounter;
$secondcounter++;
}
print FILE " space";
open(MYFILE, $path) or die 'ERRROR';
my $count = 0;
foreach $line (<MYFILE>) {
my #endtime;
$flag = 'false';
#$counter++;
$count++;
print FILE $count . "========";
if ($count == 1) {
($hrs, $min) = getdate($line);
$starttime[$j][$l] = ($hrs * 60) + $min;
}
else {
($hrs, $min) = split(':', $line, 3);
if ($line =~ m/End of Procedure/) {
$flag = 'true';
$endtime[$j][$l] = $hrs . $min;
$endtime[$j][$l] = ($hrs * 60) + $min;
}
else {
$endtime[$j][$l] = ($hrs * 60) + $min;
}
}
$duration[$j][$l] = $endtime[$j][$l] - $starttime[$j][$l];
}
# print $flag;
#print FILE $file." : ";
#print FILE "value of ".$j."and".$l;
$startstatus[$j][$l] = "Started at" . $starttime[$j][$l];
$durationstatus[$j][$l] = "&nbspDuration is " . $duration[$j][$l] . "m";
# print FILE "Started at".$starttime;
# print FILE "&nbspDuration is ".$duration."m";
# print FILE "<br>";
close(MYFILE);
}
my $valueofl = $l;
#print FILE "vlaeeofl".$valueofl;
print "valueofllllllllllllllllllllllllllll" . $l;
$l = 0;
if ($flag eq 'true') {
$status = 'Completed';
$color = '#008000';
print FILE "<font size=\"3\" color="
. $color
. " face=\"Tahoma\"><b><u><br>"
. $two[$i]
. "</font></u></b><br>";
print FILE $status . "<br>";
while ($l <= $valueofl) {
#print $j."and".$l;
# print "valueofllllllllllllllllllllllllllll".$l;
print FILE $sample[$j][$l] . "&nbsp&nbsp&nbsp&nbsp";
print FILE $startstatus[$j][$l] . "&nbsp&nbsp&nbsp&nbsp";
print FILE $durationstatus[$j][$l] . "<br>";
$l++;
}
# print FILE $startstatus[$j][0];
# print FILE $durationstatus[$j][0];
}
else {
#print "valueofllllllllllllllllllllllllllll".$l;
#print $j."and".$l;
$status = 'In Progress';
$color = 'blue';
print FILE "<font size=\"3\" color="
. $color
. " face=\"Tahoma\"><b><u><br>"
. $two[$i]
. "</font></u></b><br>"
. $status;
}
$i++;
$j++;
}
print FILE "</body>";
print FILE "</html>";
close(FILE);
close(MYFILE1)
This is a shocking piece of Perl. You must always start you program with use strict and use warnings, and declare all variables as close as possible to their first point of use using my. That is the most basic form of debugging, and it is only polite to do this at the very least before asking other people for help.
The problem is likely to lie in your for statement
foreach $counter ($file) { ... }
which will execute the body of the loop just once, with $content set to the value of $file. I can't imagine what you meant it to do.

Reference to a string as a class variable

I'm trying to save a reference to a string in a class variable.
I wish to access this variable by dereferencing it.
For example in the routine getHeaders instead of using:
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;
I would like to use:
my $fileContentsRef = $this->getFileContent;
$$fileContentsRef =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;
For more details you should see the code at the end.
My problem is, that the program doesn't work when I don't work with the copy( i.e when I don't use $fileContentsRef1). What am I doing / getting wrong? Is it possible to reach the goal in the way I described? Could some give me clues how?
open FILE, "a1.bad";
$file_contents .= do { local $/; <FILE> };
close FILE;
my $log = auswerter->new(\$file_contents);
#-----------------------------------------------------------------
# Subs
#-----------------------------------------------------------------
# CONSTRUCTOR
sub new
{
my $fileRef = $_[1];
my $self = {};
bless $self;
$self->initialize();
if($fileRef) { $self->{fileRef} = $fileRef; }
return $self;
}
sub initialize
{
#-----------------------------------------------------------------
# Configuration
#-----------------------------------------------------------------
my $this = shift;
}
sub setFile {
my $this = shift;
$this->{file} = shift;
}
sub getFileContent
{
my $this = shift;
return $this->{fileRef};
}
sub getHeaders
{
print "HEADERS...\n";
my $this = shift;
my #headers = ();
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;
#headers = split ("\n", $1 );
foreach (#headers)
{
$_ =~ s/^(.*?)\s.*/$1/;
}
return \#headers;
}
sub getErrList
{
print "ERR LIST...\n";
my $this = shift;
my #errors = ();
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /Spaltenname.*?(Satz.*)ORA.*?^Tabelle/gsmi;
return \#errors if !$1;
#errors = split ("\n\n", $1 );
foreach (#errors)
{
$_ =~ s/.*Spalte (.*?)\..*/$1/msgi;
}
return \#errors;
}
sub getEntries
{
my $this = shift;
my #entries = ();
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /.*==\n(.*)/gsmi;
#entries = split ("\n", $1 );
return \#entries;
}
sub sqlldrAnalyze
{
my $this = shift;
my $token = shift;
my $errRef =$this->getErrList();
return "" if $#$errRef < 0 ;
my $headersRef = $this->getHeaders();
my $entriesRef = $this->getEntries();
my $i = 0;
my $str = "";
$str = "<html>";
$str .= "<table rules=\"all\">";
$str .= "<tr>";
foreach ( #$headersRef)
{
$str .= "<th>".$_."</th>";
}
$str .= "</tr>";
foreach ( #$entriesRef)
{
my #errOffset = grep { $headersRef->[$_] =~ $errRef->[$i] }0..$#$headersRef ;
my #entries = split($token, $_);
$str .= "<tr>";
foreach (my $j =0; $j <= $#entries;$j++)
{
$str .= "<td nowrap";
$str .= " style=\"background-color: red\"" if $j == $errOffset[0];;
$str .= ">";
$str .= "<b>" if $j == $errOffset[0];
$str .= $entries[$j];
$str .= "</b>" if $j == $errOffset[0];
$str .= "</td>";
}
$str .= "</tr>\n";
$i++;
}
$str .= "</table>";
$str .= "</html>";
return $str;
}
return 1;
When you call your class->new(...) constructor with a filename argument, the new subroutine gets the class name as the first argument, and the filename as the second argument.
In your constructor, you are simply copying the value of $_[1] (the filename) into $self->{FileRef}, but that value is not a reference.
So when you access it, there is no need to use a doubled sigil to dereference the value.
You should run all of your code with the following two lines at the top, which will catch many errors for you (including trying to use strings as references when they are not references):
use strict;
use warnings;
These two lines basically move Perl out of quick one-liner mode, and into a mode more suitable for large development (improved type safety, static variable name checking, and others).
Per the update: If the code you have is working properly when copying the string, but not when dereferencing it directly, it sounds like you may be running into an issue of the string reference preserving the last match position (the g flag).
Try running the following:
my $fileContentsRef = $this->getFileContent;
pos($$fileContentsRef) = 0; # reset the match position
$$fileContentsRef =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;

Simple perl array function doesn't work

This simple Perl script is translating stories from a database into XML, but this one section is giving me problems. The function makeUrl is called for each story, but needs to ensure that duplicate URLs aren't created.
my #headlines = ();
my $hlCount = 1;
.
.
.
sub makeUrl {
my $headline;
open( URLSOUT, '>>/var/mtkoan/harris/urls' );
$url = $_[0];
print URLSOUT "Before: $url\n";
$url =~ s/\x{90}//g;
$url =~ s/\s+$//g;
$url =~ s/^\s+//g;
$url =~ s/\s/_/g;
$url =~ s/\W//g;
push #headlines, $url;
foreach $headline (#headlines) {
if( $headline eq $url ) {
$url .= "_$hlCount";
$hlCount++;
}
}
print URLSOUT "After: $url\n\n";
print URLSOUT "Headline Array Dump:\n";
print URLSOUT "#headlines\n";
close URLSOUT;
}
When the array is printed, only the last value is shown. Push isn't appending to the end of the array, I can't figure it out!
You can check for uniqueness (and remove duplicates from a list) in two main ways:
With a hash:
my %urls;
# construct your URL in the function...
$urls{$url}++;
# get all the (unique) URLs:
my #urls = keys %urls;
With a library call that returns the unique values in a list (see List::MoreUtils):
use List::MoreUtils 'uniq`;
#urls = uniq #urls;

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