This tutorial contains a collection of CGI scripts that illustrate the four basic types of CGI scripting: dynamic documents, document filtering, and URL redirection. It also shows a few tricks that you might not have run into -- or even thought were possible with CGI.
Script 1.1: vegetables1.pl
#!/usr/bin/perl
# Script: vegetables1.pl
use CGI::Pretty ':standard';
print header,
start_html('Vegetables'),
h1('Eat Your Vegetables'),
ol(
li('peas'),
li('broccoli'),
li('cabbage'),
li('peppers',
ul(
li('red'),
li('yellow'),
li('green')
)
),
li('kolrabi'),
li('radishes')
),
hr,
end_html;
Script 1.2: vegetables2.pl
#!/usr/bin/perl
# Script: vegetables2.pl
use CGI ':standard';
print header,
start_html('Vegetables'),
h1('Eat Your Vegetables'),
ol(
li(['peas',
'broccoli',
'cabbage',
'peppers' .
ul(['red','yellow','green']),
'kolrabi',
'radishes'
),
hr,
end_html;
Or how about this one?
Script 1.3: vegetables3.pl
#!/usr/bin/perl
# Script: vegetables3.pl use CGI::Pretty qw/:standard :html3/;
print header,
start_html('Vegetables'),
h1('Vegetables are for the Strong'),
table({-border=>undef},
caption(strong('When Should You Eat Your Vegetables?')),
Tr({-align=>CENTER,-valign=>TOP},
[
th(['','Breakfast','Lunch','Dinner']),
th('Tomatoes').td(['no','yes','yes']),
th('Broccoli').td(['no','no','yes']),
th('Onions').td(['yes','yes','yes'])
]
)
),
end_html;
Script 1.4: customizable.pl
#!/usr/bin/perl
# script: customizable.pl
use CGI::Pretty qw/:standard/;
$color = param('color') || 'white';
print header,
start_html({-bgcolor=>$color},'Customizable Page'),
h1('Customizable Page'),
"Set this page's background color to:",br,
start_form,
radio_group(-name=>'color',
-value=>['white','red','green','black',
'blue','silver','cyan'],
-cols=>2),
submit(-name=>'Set Background'),
end_form,
p,
hr,
end_html;
=head1 Making Stateful Forms
Many real Web applications are more than a single page. Some may span multiple pages and fill-out forms. When the user goes from one page to the next, you've got to save the state of the previous page somewhere. A convenient and cheap place to put state information is in hidden fields in the form itself. Script 2.1 is an example of a loan application with a total of five separate pages. Forward and back buttons allows the user to navigate between pages. The script remembers all the pages and summarizes them up at the end.
Script 2.1: loan.pl
#!/usr/local/bin/perl
# script: loan.pl
use CGI qw/:standard :html3/;
# this defines the contents of the fill out forms
# on each page.
@PAGES = ('Personal Information','References','Assets','Review','Confirmation');
%FIELDS = ('Personal Information' => ['Name','Address','Telephone','Fax'],
'References' => ['Personal Reference 1','Personal Reference 2'],
'Assets' => ['Savings Account','Home','Car']
);
# accumulate the field names into %ALL_FIELDS;
foreach (values %FIELDS) {
grep($ALL_FIELDS{$_}++,@$_);
}
# figure out what page we're on and where we're heading.
$current_page = calculate_page(param('page'),param('go'));
$page_name = $PAGES[$current_page];
print_header();
print_form($current_page) if $FIELDS{$page_name};
print_review($current_page) if $page_name eq 'Review';
print_confirmation($current_page) if $page_name eq 'Confirmation';
print end_html;
# CALCULATE THE CURRENT PAGE
sub calculate_page {
my ($prev,$dir) = @_;
return 0 if $prev eq ''; # start with first page
return $prev + 1 if $dir eq 'Submit Application';
return $prev + 1 if $dir eq 'Next Page';
return $prev - 1 if $dir eq 'Previous Page';
}
# PRINT HTTP AND HTML HEADERS
sub print_header {
print header,
start_html("Your Friendly Family Loan Center"),
h1("Your Friendly Family Loan Center"),
h2($page_name);
}
# PRINT ONE OF THE QUESTIONNAIRE PAGES
sub print_form {
my $current_page = shift;
print "Please fill out the form completely and accurately.",
start_form,
hr;
draw_form(@{$FIELDS{$page_name}});
print hr;
print submit(-name=>'go',-value=>'Previous Page')
if $current_page > 0;
print submit(-name=>'go',-value=>'Next Page'),
hidden(-name=>'page',-value=>$current_page,-override=>1),
end_form;
}
# PRINT THE REVIEW PAGE
sub print_review {
my $current_page = shift;
print "Please review this information carefully before submitting it. ",
start_form;
my (@rows);
foreach $page ('Personal Information','References','Assets') {
push(@rows,th({-align=>LEFT},em($page)));
foreach $field (@{$FIELDS{$page}}) {
push(@rows,
TR(th({-align=>LEFT},$field),
td(param($field)))
);
print hidden(-name=>$field);
}
}
print table({-border=>1},caption($page),@rows),
hidden(-name=>'page',-value=>$current_page,-override=>1),
submit(-name=>'go',-value=>'Previous Page'),
submit(-name=>'go',-value=>'Submit Application'),
end_form;
}
# PRINT THE CONFIRMATION PAGE
sub print_confirmation {
print "Thank you. A loan officer will be contacting you shortly.",
p,
a({-href=>'../source.html'},'Code examples');
}
# CREATE A GENERIC QUESTIONNAIRE
sub draw_form {
my (@fields) = @_;
my (%fields);
grep ($fields{$_}++,@fields);
my (@hidden_fields) = grep(!$fields{$_},keys %ALL_FIELDS);
my (@rows);
foreach (@fields) {
push(@rows,
TR(th({-align=>LEFT},$_),
td(textfield(-name=>$_,-size=>50))
)
);
}
print table(@rows);
foreach (@hidden_fields) {
print hidden(-name=>$_);
}
}
Script 2.2: preferences.pl
#!/usr/local/bin/perl
# file: preferences.pl
use CGI qw(:standard :html3);
# Some constants to use in our form.
@colors=qw/aqua black blue fuschia gray green lime maroon navy olive
purple red silver teal white yellow/;
@sizes=("<default>",1..7);
# recover the "preferences" cookie.
%preferences = cookie('preferences');
# If the user wants to change the background color or her
# name, they will appear among our CGI parameters.
foreach ('text','background','name','size') {
$preferences{$_} = param($_) || $preferences{$_};
}
# Set some defaults
$preferences{'background'} = $preferences{'background'} || 'silver';
$preferences{'text'} = $preferences{'text'} || 'black';
# Refresh the cookie so that it doesn't expire.
$the_cookie = cookie(-name=>'preferences',
-value=>\%preferences,
-path=>'/',
-expires=>'+30d');
print header(-cookie=>$the_cookie);
# Adjust the title to incorporate the user's name, if provided.
$title = $preferences{'name'} ?
"Welcome back, $preferences{name}!" : "Customizable Page";
# Create the HTML page. We use several of the HTML 3.2
# extended tags to control the background color and the
# font size. It's safe to use these features because
# cookies don't work anywhere else anyway.
print start_html(-title=>$title,
-bgcolor=>$preferences{'background'},
-text=>$preferences{'text'}
);
print basefont({-size=>$preferences{size}}) if $preferences{'size'} > 0;
print h1($title);
# Create the form
print hr,
start_form,
"Your first name: ",
textfield(-name=>'name',
-default=>$preferences{'name'},
-size=>30),br,
table(
TR(
td("Preferred"),
td("Page color:"),
td(popup_menu(-name=>'background',
-values=>\@colors,
-default=>$preferences{'background'})
),
),
TR(
td(''),
td("Text color:"),
td(popup_menu(-name=>'text',
-values=>\@colors,
-default=>$preferences{'text'})
)
),
TR(
td(''),
td("Font size:"),
td(popup_menu(-name=>'size',
-values=>\@sizes,
-default=>$preferences{'size'})
)
)
),
submit(-label=>'Set preferences'),
end_form,
hr,
end_html;
Script 3.1 creates a clickable image map of a colored circle inside a square. The script is responsible both for generating the map and making the image (using the GD.pm library). It also creates a fill-out form that lets the user change the size and color of the image!
Script 3.1: circle.pl
#!/usr/local/bin/perl
# script: circle.pl
use GD;
use CGI qw/:standard Map Area/;
use constant RECTSIZE => 100;
use constant CIRCLE_RADIUS => 40;
%COLORS = (
'white' => [255,255,255],
'red' => [255,0,0],
'green' => [0,255,0],
'blue' => [0,0,255],
'black' => [0,0,0],
'bisque'=> [255,228,196],
'papaya whip' => [255,239,213],
'sienna' => [160,82,45]
);
my $draw = param('draw');
my $circle_color = param('color') || 'bisque';
my $mag = param('magnification') || 1;
if ($draw) {
draw_image();
} else {
make_page()
}
sub draw_image {
# create a new image
my $im = new GD::Image(RECTSIZE*$mag,RECTSIZE*$mag);
# allocate some colors
my $white = $im->colorAllocate(@{$COLORS{'white'}});
my $black = $im->colorAllocate(@{$COLORS{'black'}});
my $circlecolor = $im->colorAllocate(@{$COLORS{$circle_color}});
# make the background transparent and interlaced
$im->transparent($white);
$im->interlaced('true');
# Put a black frame around the picture
$im->rectangle(0,0,RECTSIZE*$mag-1,RECTSIZE*$mag-1,$black);
# Draw the circle
$im->arc(RECTSIZE*$mag/2,RECTSIZE*$mag/2,CIRCLE_RADIUS*$mag*2,CIRCLE_RADIUS*$mag*2,0,360,$black);
# And fill it with circlecolor
$im->fill(RECTSIZE*$mag/2,RECTSIZE*$mag/2,$circlecolor);
# Convert the image to GIF and print it
print header('image/gif'),$im->gif;
}
sub make_page {
param(-name=>'draw',-value=>1);
print header(),
start_html(-title=>'Feeling Circular',-bgcolor=>'white'),
h1('A Circle is as a Circle Does'),
img({-src=>self_url(),-alt=>'a circle',
-align=>'LEFT',-usemap=>'#map',
-border=>0});
print em(param('message')) if param('message');
Delete('draw');
print start_form,
"Magnification: ",radio_group(-name=>'magnification',-values=>[1..4]),br,
"Color: ",popup_menu(-name=>'color',-values=>[sort keys %COLORS]),
submit(-value=>'Change'),
end_form;
print Map({-name=>'map'},
Area({-shape=>'CIRCLE',
-href=>param(-name=>'message',-value=>"You clicked in the circle")
? self_url() : '',
-coords=>join(',',RECTSIZE*$mag/2,RECTSIZE*$mag/2,CIRCLE_RADIUS*$mag),
-alt=>'Circle'}),
Area({-shape=>'RECT',
-href=>param(-name=>'message',-value=>"You clicked in the square")
? self_url() : '',
-coords=>join(',',0,0,RECTSIZE*$mag,RECTSIZE*$mag),
-alt=>'Square'}));
print end_html;
}
Script 3.2 creates a GIF89a animation. First it creates a set of
simple GIFs, then uses the I<combine> program (part of the ImageMagick
package) to combine them together into an animation.
I'm not a good animator, so I can't do anything fancy. But you can!
Script 3.2: animate.pl
#!/usr/local/bin/perl # script: animated.pl use GD; use File::Path; use constant START => 80; use constant END => 200; use constant STEP => 10; use constant COMBINE => '/usr/local/bin/convert'; @COMBINE_OPTIONS = (-delay => 5, -loop => 10000); @COLORS = ([240,240,240], [220,220,220], [200,200,200], [180,180,180], [160,160,160], [140,140,140], [150,120,120], [160,100,100], [170,80,80], [180,60,60], [190,40,40], [200,20,20], [210,0,0]); @COLORS = (@COLORS,reverse(@COLORS)); my @FILES = (); my $dir = create_temporary_directory(); my $index = 0; for (my $r = START; $r <= END; $r+=STEP) { draw($r,$index,$dir); $index++; } for (my $r = END; $r > START; $r-=STEP) { draw($r,$index,$dir); $index++; } # emit the GIF89a $| = 1; print "Content-type: image/gif\n\n"; system COMBINE,@COMBINE_OPTIONS,@FILES,"gif:-"; rmtree([$dir],0,1); sub draw{ my ($r,$color_index,$dir) = @_; my $im = new GD::Image(END,END); my $white = $im->colorAllocate(255,255,255); my $black = $im->colorAllocate(0,0,0); my $color = $im->colorAllocate(@{$COLORS[$color_index % @COLORS]}); $im->rectangle(0,0,END,END,$white); $im->arc(END/2,END/2,$r,$r,0,360,$black); $im->fill(END/2,END/2,$color); my $file = sprintf("%s/picture.%02d.gif",$dir,$color_index); open (OUT,">$file") || die "couldn't create $file: $!"; print OUT $im->gif; close OUT; push(@FILES,$file); } sub create_temporary_directory { my $basename = "/usr/tmp/animate$$"; my $counter=0; while ($counter < 100) { my $try = sprintf("$basename.%04d",$counter); next if -e $try; return $try if mkdir $try,0700; } continue { $counter++; } die "Couldn't make a temporary directory"; } =head1 Document Translation
Did you know that you can use a CGI script to translate other documents on the fly? No s**t! Script 4.1 is a script that intercepts all four-letter words in text documents and stars out the naughty bits. The document itself is specified using additional path information. We're a bit over-literal about what a four-letter word is, but what's the fun if you can't be extravagant?
Script 4.1: naughty.pl
#!/usr/local/bin/perl # Script: naughty.pl
use CGI ':standard';
$file = path_translated() ||
die "must be called with additional path info";
open (FILE,$file) || die "Can't open $file: $!\n";
print header('text/plain');
while (<FILE>) {
s/\b(\w)\w{2}(\w)\b/$1**$2/g;
print;
}
close FILE;
4.1 won't work on HTML files because the HTML tags will get starred out too. If you find it a little limiting to work only on plain-text files, script 4.2 uses LWP's HTML parsing functions to modify just the text part of an HTML document without touching the tags. The script's a little awkward because we have to guess the type of file from the extension, and redirect when we're dealing with a non-HTML file. We can do better with mod_perl.
Script 4.2: naughty2.pl
#!/usr/local/bin/perl
# Script: naughty2.pl
package HTML::Parser::FixNaughty;
require HTML::Parser;
@ISA = 'HTML::Parser';
sub start {
my ($self,$tag,$attr,$attrseq,$origtext) = @_;
print $origtext;
}
sub end {
my ($self,$tag) = @_;
print "</$tag>";
}
sub text {
my ($self,$text) = @_;
$text =~ s/\b(\w)\w{2}(\w)\b/$1**$2/g;
print $text;
}
package main;
use CGI qw/header path_info redirect path_translated/;
$file = path_translated() ||
die "must be called with additional path info";
$file .= "index.html" if $file=~m!/$!;
unless ($file=~/\.html?$/) {
print redirect(path_info());
exit 0;
}
$parser = new HTML::Parser::FixNaughty;
print header();
$parser->parse_file($file);
A cleaner way to do this is to make naughty2.pl an Apache HANDLER. We can make it handle all the HTML documents on our site by adding something like this to access.conf:
<Location />
... blah blah blah other stuff
Action text/html /cgi-bin/naughty2.pl
</Location>
Now, whenever an HTML document is requested, it gets passed through the CGI script. With this in place, there's no need to check the file type and redirect. Cool!
/cgi-bin/random_pict/banners/egregious_advertising
Script 4.3 random_pict.pl
#!/usr/local/bin/perl # script: random_pict.pl
use CGI qw/:standard/;
$PICTURE_PATH = path_translated();
$PICTURE_URL = path_info();
chdir $PICTURE_PATH
or die "Couldn't chdir to pictures directory: $!";
@pictures = <*.{jpg,gif}>;
$lucky_one = $pictures[rand(@pictures)];
die "Failed to pick a picture" unless $lucky_one;
print redirect("$PICTURE_URL/$lucky_one");
binmode() before they
try this at home!
Script 5.1 upload.pl
#!/usr/local/bin/perl
#script: upload.pl
use CGI qw/:standard/;
print header,
start_html('file upload'),
h1('file upload');
print_form() unless param;
print_results() if param;
print end_html;
sub print_form {
print start_multipart_form(),
filefield(-name=>'upload',-size=>60),br,
submit(-label=>'Upload File'),
end_form;
}
sub print_results {
my $length;
my $file = param('upload');
if (!$file) {
print "No file uploaded.";
return;
}
print h2('File name'),$file;
print h2('File MIME type'),
uploadInfo($file)->{'Content-Type'};
while (<$file>) {
$length += length($_);
}
print h2('File length'),$length;
}
Full information on using DBI can be found in its manual pages and in Advanced Perl Programming by Sriram Srinivasan. Here's just enough background info to get you started.
Before you can work with the DBI interface, you must select and install a relational database. If you have access to a Unix system and do not already have such a database installed, a good one to start with is MySQL, a popular database management system that you can freely download from http://www.tcx.se/.
In relational databases, all information is organized in tables. Each row of the table is a data record, and each column is a field of the record. For example, here is one way to represent a catalog of kitchen products:
+----------+-----------------------+---------------+------+-----+ | catalog | name | description | price|image| +----------+-----------------------+---------------+------+-----+ |64-135517 |Handcrafted Salad Bowls|Each of our... | 39.00| - | |64-1201565|Warning Blender |With its two...|199.00| - | |64-2743953|French Pepper Mills |Made by a sm...| 32.00| - | +----------+-----------------------+---------------+------+-----+
catalog gives the catalog number for the item and is the primary key for the table. name gives a brief descriptive name for the item, description a long text description (truncated in the table above), and price the item's price. image holds the binary data from a JPG picture of the catalog item, and isn't shown in the table for obvious reasons.
In SQL databases each table column has a defined data type and a maximum field length. Available data types include integers, floating point numbers, character strings, date/time types, and sometimes more esoteric types. Unfortunately the data types supported by database management systems vary considerably, limiting the portability of applications among different vendors' products. We use MySQL data types and functions in these examples. You may have to make some modifications in order to support another database system.
The most basic way to communicate with a SQL database is via a text monitor, a small terminal-like application in which you type SQL queries to the database and view the results. To create the definition for the table shown above, you could issue the SQL CREATE command:
mysql> CREATE TABLE ProductList
(
catalog char(10) primary key,
name char(50) not null,
price numeric(8,2) not null,
description text not null,
image mediumblob
);
This declares a table named ``ProductList'' using the MySQL syntax. The catalog column is declared to be a string of at most ten characters, and it is also declared to be the primary key for the table. This ensures that a given catalog number is unique, and speeds up table lookups considerably. Appropriate data types are assigned to name, price, and description, and the directive ``not null'' is applied as well. The image column is a ``mediumblob'', meaning ``binary large object, of medium size'' (less than 1.6 MB).
We can load some sample data into the database using a SQL INSERT statement:
mysql> INSERT INTO ProductList (catalog,name,price,description)
VALUES ('64-10000','Smelling Salts',18.00,'Ach-choo!');
We can now perform some queries over the database using the SQL SELECT statement.
To see the catalog and name fields:
mysql> SELECT catalog,name FROM ProductList; +------------+--------------------------------------------+ | catalog | name | +------------+--------------------------------------------+ | 64-2059954 | Chef's Choice Professional Knife Sharpener | | 64-137877 | Fini Aceto Balsamico | | 64-1201565 | Waring Commercial Blender | | 64-135517 | Handcrafted Salad Bowls | | 64-2743953 | French Salt & Pepper Mills | | 64-10000 | Smelling Salts | +------------+--------------------------------------------+ 6 rows in set (0.00 sec)
The part of the query following the SELECT command chooses which columns to display. The FROM keyword names the table to select the data from.
If we wished to look at all the columns, we could just specify ``*'' for the column list.
An optional WHERE clause allows you to filter the records so that only records matching a set of criteria are displayed. For example, this query shows only items that cost more than $50.00:
mysql> SELECT catalog,name,price FROM ProductList WHERE price>50.00; +------------+--------------------------------------------+--------+ | catalog | name | price | +------------+--------------------------------------------+--------+ | 64-2059954 | Chef's Choice Professional Knife Sharpener | 129.00 | | 64-1201565 | Waring Commercial Blender | 199.00 | +------------+--------------------------------------------+--------+ 2 rows in set (0.05 sec)
The INSERT statement can only be used to create a new record (or row) of the table. If you were to try to execute the insertion statement shown above a second time, the attempt would fail because any given catalog number can only occur once in the table. This feature guarantees the uniqueness of catalog numbers. To change the values in an existing record, you could use an UPDATE statement instead. For example, here's now to apply a 20% discount to the price of smelling salts:
mysql> UPDATE ProductList SET price=price-(price*0.20)
WHERE catalog='64-10000';
Query OK, 1 row affected (0.01 sec)
Like the SELECT statement, UPDATE can have a WHERE clause which limits what records it affects. For each selected record, columns are updated according to one or more column=newvalue pairs specified in the SET clause. oA SELECT statement shows that the update worked.
mysql> SELECT catalog,name,price FROM ProductList
WHERE catalog='64-10000';
+----------+----------------+-------+
| catalog | name | price |
+----------+----------------+-------+
| 64-10000 | Smelling Salts | 14.40 |
+----------+----------------+-------+
1 row in set (0.00 sec)
The DELETE statement can be used to delete all records that satisfy the criteria set out in the WHERE clause. This query the Smelling Salts entry:
mysql> DELETE FROM ProductList WHERE name='Smelling Salts'; Query OK, 1 row affected (0.01 sec)
If you forget to include a WHERE clause in UPDATE and DELETE statements, every record in the table will be updated or removed. This is generally to be avoided.
To open a database, you call DBI->connect() with the ``data source name'', a string that tells the database driver where the database is located. If the database requires a username and password for access, you can pass that information in the connect() call as well. The format of the data source name is DBMS-specific. For a MySQL database, it looks like this:
"dbi:mysql:$database:$hostname:$port"
All MySQL data sources begin with ``dbi:mysql''. They are followed by the name of the database, and, optionally, by the name and port of the remote host on which the DBMS is running. If the hostname and port are omitted, the driver defaults to using a standard port on the local host. To connect to a database named ``perl_conference'' on the local host using the username ``chef'' and the password ``grok'', you'd make this call:
$dbh = DBI->connect('dbi:mysql:www', 'chef', 'grok');
If successful, connect() returns a database handle, $dbh, which is used for subsequent communication with the database. The
connect() method also accepts an optional fourth argument which consists of a hash
reference of parameter name/value pairs. These control a variety of
database options, such as whether to automatically commit all changes made
to the database. The only option that we'll use in the examples to follow
is PrintError, which when set to false, suppresses the printing of unwanted database
warnings to the server error log.
The database handle has several methods, the most important of which are do(), prepare() and errstr(). do() is used to execute SQL statements which do not return a list of records, such as INSERT, DELETE, UPDATE or CREATE. If the operation is successful, do() returns a count of the number of rows modified. For example, the following query applies a 20% discount to all records in ProductList and returns the number of rows affected.
$count = $dbh->do('UPDATE ProductList SET SET price=price-(price*0.20)');
die $dbh->errstr unless defined $count;
If the database encountered an error while processing the statement (for example, the SQL contained a syntax error), it will return undef. The errstr() method can be used to retrieve an informative error message from the driver.
SELECT queries can return a potentially large number of records, often more than will fit into memory at once. For this reason, the results from SELECT queries are returned in the form of statement handle objects. You then call the statement handle's fetchrow_array() method repeatedly to retrieve each row of the result.
Here's an example of retrieving the catalog and name fields from each session in the ProductList table:
$sth = $dbh->prepare('SELECT catalog,name FROM ProductList')
|| die $dbh->errstr;
$sth->execute() || die $sth->errstr;
while (my ($catalog,$name) = $sth->fetchrow_array) {
print "catno => $catalog, name => $name\n";
}
$sth->finish;
The example starts with a call to the database handle's prepare()
method with the text of the SQL SELECT statement. prepare() parses the SQL and checks it for syntactic correctness, but does not
actually execute it. The query is returned as a statement handler which we
store into the variable $sth. If some error occurred while preparing the statement, prepare() returns undef, in which case we return the
errstr() error text.
Next we call the statement handler's execute() method. This performs the query and returns the number of rows retrieved or undef if an error occurred. In the case of a syntactically correct query that happens to return no rows (because the table is empty or no records satisfied the criteria in the WHERE clause), execute() returns the the value ``0E0'' which Perl regards as true in a logical context, but as zero in a numeric one.
Now we enter a loop in which we call the statement handler's fetchrow_array() method. Each time it's called the methods returns the requested columns in the form of an array in the same order as the columns named in the SELECT clause. When there are no more rows left, fetchrow_array() returns an empty list.
DBI actually offers a family of fetch functions. fetch() is like fetchrow_array(), but it returns an array reference, making it more memory efficient and somewhat faster. Another function, fetchrow_hashref() turns the current row into a hash of the column names and their values, and returns the hash's reference to the caller. This allows us to make the example above more readable at the cost of making it somewhat less efficient:
$sth = $dbh->prepare('SELECT catalog,name FROM ProductList')
|| die $dbh->errstr;
$sth->execute() || die $sth->errstr;
while (my $r = $sth->fetchrow_hashref) {
print "catno => $r->{catalog}, name => $r->{name}\n";
}
$sth->finish;
When you are finished with a statement handler you should call its finish() method in order to free up the resources it uses.
The last thing you need to know about statement handlers is that many DBI drivers allow you to put placeholders, indicated by the ``?'' character, inside SQL statements. prepare() compiles the statement and returns a statement handler as before, but when you later call execute() you pass in the values to be substituted into the placeolders. This allows you to treat statement handlers much as you would a subroutine by calling it repeatedly with different runtime arguments. For example, we can create a statement handler for returning the entire row of a catalog record with this bit of code:
$sth = $dbh->prepare('SELECT * FROM ProductList WHERE catalog=?');
Now we can fetch information on item ``64-1201565'', by calling the statement handler's execute() method this way:
$sth->execute('64-1201565');
The same statement handler can later be used to fetch information from other named sessions. You should still call finish() at the end of each series of fetches, even though you are going to reuse the statement handler. Failure to do so can lead to memory leaks.
When you are completely finished with a database handle, you should call its disconnect() method in order to sever the connection and clean up.
# Contents of the catalog
CREATE TABLE ProductList (
catalog char(10) primary key,
name char(50) not null,
price numeric(8,2) not null,
description text not null,
image mediumblob );
# How many of each item in stock?
CREATE TABLE StockList (
catalog char(10) primary key,
quantity int default 0 not null );
# List of session numbers for shopping cart. Each user
# has his own unique session number.
CREATE TABLE Session (
session_id int default 0 auto_increment primary key,
created timestamp );
# List of items in the shopping cart for a given session ID.
CREATE TABLE ShoppingCart (
session_id int not null,
catalog char(10) not null,
count int default 0,
key(session_id),key(catalog)
);
# shipping/billing information for the user
CREATE TABLE CustInfo (
order_id int auto_increment primary key,
created timestamp,
name char(50) not null,
address1 char(50) not null,
address2 char(50),
city char(15) not null,
state char(2) not null,
country char(15) not null,
zip char(9) not null,
telephone char(20) not null,
ccno char(20) not null,
expires char(10) not null );
# for a given order number, listing of the items ordered
CREATE TABLE OrderInfo (
order_id int not null,
catalog char(10) not null,
quantity int not null,
key(order_id),key(catalog)
);
The module works by creating a Catalog object, which knows how to list the items in the catalog and return information on a given item.
package Catalog;
# modules/Catalog.pm
# Fetch items from the catalog and display them.
use strict;
use Carp;
use DBI;
use CGI qw(:standard);
# create new catalog object
sub new {
my $class = shift;
my $db = shift || croak "Please provide a DBI handle";
return bless {'db' => $db},$class;
}
# return database handle (used internally)
sub db { return $_[0]->{'db'}; }
# Return list of catalog numbers. In an array context, returns
# list of catalog numbers only. In scalar context, returns a hash
# ref in which the keys are catalog numbers, and values are the
# brief descriptions ('names') of the items.
sub list {
my $self = shift;
my $db = $self->db || croak ('No database handle');
my $sth = $db->prepare('SELECT catalog,name FROM ProductList')
|| croak("Prepare:",$db->errstr);
$sth->execute || return;
my %items;
while (my($catalog,$name) = $sth->fetchrow_array) {
$items{$catalog} = $name;
}
return keys %items if wantarray;
return \%items;
}
# Get the information for an entry in the catalog.
# If successful, returns a hashref in which the keys are the column names.
# Returns the length of the image in a key named 'image'. This can be used
# to determine if there is an image to display.
# The key "in_stock" returns the number of items currently in stock.
sub info {
my $self = shift;
my $catno = shift || croak ("Provide a catalog number");
my $db = $self->db || croak ('No database handle');
my $sth = $db->prepare(<<END);
SELECT name,ProductList.catalog,price,description,length(image) as image,quantity as in_stock
FROM ProductList,StockList
WHERE ProductList.catalog=?
AND ProductList.catalog=StockList.catalog
END
$sth->execute($catno);
my $info = $sth->fetchrow_hashref;
$sth->finish;
return $info;
}
# Return the image data for an entry in the catalog.
sub image {
my $self = shift;
my $catno = shift || croak ("Provide a catalog number");
my $db = $self->db || croak ('No database handle');
my $sth = $db->prepare('SELECT image FROM ProductList WHERE catalog=?');
$sth->execute($catno) || return;
my ($image) = $sth->fetchrow_array;
$sth->finish;
return $image;
}
1;
__END__
After allocating a session ID, Session.pm returns a Session object to the caller. This object is used to fetch all session-specific data (in this case, the contents of the shopping cart).
The technique of storing state information in the URL is called URL rewriting. In order for the technique to work across CGI scripts, all URLs generated by the CGI scripts must be passed through the Session object's rewrite_url() method, so that the object can tack on the appropriate session ID.
The Session.pm module is actually an abstract superclass. A bunch of important methods, such as communicating with the database and fetching state information, are left to subclasses to implement.
package Session;
# modules/Session.pm
# This utility module is an interface to a Session object based on URL rewriting.
# The session ID is stored in the "additional path info" of the URL. All URLs must
# be passed through rewrite_url() in order to maintain the state.
# manage database sessions with URL rewriting
use strict;
use CGI 'path_info','url';
use Carp;
# return a new session object, possibly retrieving
# id from the additional path info. May do a redirection
# if a new ID needs to be created. Therefore this method
# should be called before header() or other output. If it
# returns undef, you should immediately exit, not die.
sub new {
my $class = shift;
my $self = bless {},$class;
$self->initialize(@_); # class-specific initialization
my $id = $self->retrieve_id;
unless ($id && $self->verify_id($id)) {
$id = $self->new_id;
$self->do_redirect($id);
return;
}
$self->{'id'} = $id;
return $self;
}
# erase the ID from the underlying storage
sub erase {
my $self = shift;
return $self->erase_id;
}
# return the ID
sub id { return $_[0]->{'id'}; }
# fetch data from the store as a hash reference
sub fetch {
my $self = shift;
return $self->fetch_data();
}
# place a hash reference into storage
sub store {
my $self = shift;
my $data = shift;
return $self->store_data($data);
}
# retrieve ID from path info
sub retrieve_id {
my $self = shift;
my ($id) = path_info() =~ m!^/(\d+)!;
return $id;
}
# Please pass all self-referencing URLs through this method
# in order to preserve the session ID.
sub rewrite_url {
my ($self,$url) = @_;
my $id = $self->id; # retrieve ID
return $url unless defined $id;
my ($main,$query) = split('\?',$url);
$main = "../$main" if $main !~ m[^(http:|/)] && path_info();
return "$main/$id?$query" if $query;
return "$main/$id" unless $query;
}
# do_redirect() is called when a new session ID needs to be generated
sub do_redirect {
my ($self,$id) = @_;
$self->{'id'} = $id;
my $url = $self->rewrite_url(url(-full=>1,-query=>1)); # CGI::url()
print CGI::redirect($url); # CGI::redirect()
}
# Class-specific initialization. Probably want to override.
sub initialize { return bless {},shift; }
# the remainder is to be implemented by subclasses
sub new_id { croak "new_id() must be implemented by subclass"; }
sub verify_id { croak "verify_id() must be implemented by subclass"; }
sub erase_id { croak "erase_id() must be implemented by subclass"; }
sub fetch_data { croak "fetch_data() must be implemented by subclass"; }
sub store_data { croak "store_data() must be implemented by subclass"; }
1;
__END__
ShoppingCart also implements methods for querying the stock list, to find out how many items are currently in stock (and not obligated to other user's shopping carts), and placing an order.
package ShoppingCart;
# modules/ShoppingCart.pm
# This subclass of Session.pm handles the business logic side of the
# shopping cart application.
use strict;
use Session;
use Carp;
use DBI;
use CGI qw(p li ol strong cite);
use vars '@ISA';
@ISA = 'Session';
# called at initialization time to process any command-line arguments
sub initialize {
my $self = shift;
my $db = shift || croak "Need a database handle";
$self->{'db'} = $db;
}
# This gets called to create a new (blank) shopping cart session.
# It inserts a new record into the Session table, and returns the
# newly-created session_id
sub new_id {
my $self = shift;
return unless my $db = $self->{'db'};
return unless $db->do('INSERT INTO Session VALUES (NULL,NULL)');
return $db->func('_InsertID');
}
# verify_id() does a select on the Session table to verify that the
# given ID is in the table.
sub verify_id {
my ($self,$id) = @_;
return unless $id;
return unless my $db = $self->{'db'};
return $db->do("SELECT 1 FROM Session WHERE session_id=$id") > 0;
}
# verify_catalog() does a select on the ProductList table to confirm
# that a catalog number is valid
sub verify_catalog {
my ($self,$catalog) = @_;
return unless my $db = $self->{'db'};
return $db->do("SELECT 1 FROM ProductList WHERE catalog='$catalog'") > 0;
}
# erase_id() removes the id from the Session table and the ShoppingCart
# returns the number of rows affected by deletion -- only for interest's sake
sub erase_id {
my $self = shift;
return unless my $db = $self->{'db'};
return unless my $id = $self->id;
my $rows = $db->do("DELETE FROM Session WHERE session_id=$id");
$rows += $db->do("DELETE FROM ShoppingCart WHERE session_id=$id");
return $rows;
}
# return the contents of the shopping cart as a hash
sub fetch_data {
my $self = shift;
return unless my $db = $self->{'db'};
return unless my $id = $self->id;
my $sth = $db->prepare(<<END) || croak $db->errstr;
SELECT catalog,count FROM ShoppingCart
WHERE session_id=$id
END
$sth->execute || croak $db->errstr;
my %cart;
while (my ($catalog,$count) = $sth->fetchrow_array) {
$cart{$catalog} = $count;
}
return \%cart;
}
# store/update the contents of the shopping cart from a hash
sub store_data {
my $self = shift;
my $data = shift;
return unless my $db = $self->{'db'};
return unless my $id = $self->id;
$db->do('LOCK TABLES ShoppingCart WRITE, ProductList READ');
# The select is needed to determine whether to do an
# update or an insert
my $select = $db->prepare(<<END) || croak $db->errstr;
SELECT 1 FROM ShoppingCart WHERE catalog=? AND session_id=?
END
# the update statement assumes that the catalog item
# is already in the shopping cart, and the user is changing
# the quantity.
my $update = $db->prepare(<<END) || croak $db->errstr;
UPDATE ShoppingCart SET count=?
WHERE catalog=? AND session_id=?
END
# the insert statement assumes that a new item is being
# added to the shopping cart
my $insert = $db->prepare(<<END) || croak $db->errstr;
INSERT INTO ShoppingCart (count,catalog,session_id) VALUES (?,?,?)
END
for my $catalog (keys %$data) {
next unless $self->verify_catalog($catalog);
my $count = $data->{$catalog};
if ($select->execute($catalog,$id) > 0) {
$update->execute($count,$catalog,$id) || croak $db->errstr;
} else {
$insert->execute($count,$catalog,$id) || croak $db->errstr;
}
}
$update->finish;
$insert->finish;
$select->finish;
$db->do("DELETE FROM ShoppingCart WHERE session_id=$id AND count<=0");
return 1;
}
# return the number of unobligated items in stock for the given catalog numer.
# sum of the stocklist + all active shopping carts.
sub items_left {
my $self = shift;
my $catalog = shift;
return unless my $db = $self->{'db'};
my $sth = $db->prepare(<<END) || $db->errstr;
SELECT quantity-sum(count)
FROM StockList,ShoppingCart
WHERE StockList.catalog='$catalog'
AND StockList.catalog=ShoppingCart.catalog
END
$sth->execute || return;
my ($count) = $sth->fetchrow_array;
$sth->finish;
return $count;
}
# Enter an order into the order entry system. Also updates the
# stocklist and removes the session. Argument ($data) must be a
# hash ref containining customer shipping and billing information
# (see code for details).
#
# If successful, returns the confirmation number. Otherwise
# returns an HTMLized description of the error.
sub place_order {
my $self = shift;
my $data = shift;
# default error message
$@ = p(strong({-class=>'alert'},'Software error'));
return unless my $db = $self->{'db'};
return unless my $id = $self->id;
return unless ref($data) eq 'HASH';
my @missing;
foreach (qw(name address1 city state country zip telephone ccno expires)) {
push(@missing,cite($_)) unless $data->{$_};
}
if (@missing) {
$@ = p(strong({-class=>'alert'},
'The following field(s) must be filled out',
'to place your order:')) .
ol(li(\@missing));
return;
}
# enter shipping/billing information into the database.
my $custinfo = $db->prepare(<<END) || die 'process_order: ',$db->errstr;
INSERT INTO CustInfo (order_id,name,address1,address2,city,state,
country,zip,telephone,ccno,expires)
VALUES(?,?,?,?,?,?,?,?,?,?,?)
END
my @vars = (undef,@{$data}{qw(name address1 address2 city state
country zip telephone ccno expires)});
unless ($custinfo->execute(@vars)) {
$@ = p(strong({-class=>'alert'},
'Unable to enter customer information into database.',
'Please contact customer service.'));
return;
}
my $orderid = $db->func("_InsertID");
$custinfo->finish;
#enter the order itself into the database
my $result = $db->do(<<END);
INSERT INTO OrderInfo (order_id,catalog,quantity)
SELECT $orderid,catalog,count
FROM ShoppingCart
WHERE session_id=$id
END
unless ($result > 0) {
$@ = p(strong({-class=>'alert'},
'Unable to enter your order into the database.',
'Please contact customer service.'));
return;
}
# Decrement stocklist to reflect the order.
# In the real world, this shouldn't be done until the item is
# shipped, but who cares about reality?
my $update_stock = $db->prepare(<<END) || return;
UPDATE StockList SET quantity=quantity-? WHERE catalog=?
END
my $items = $self->fetch_data;
for my $catalog (keys %$items) {
$update_stock->execute($items->{$catalog},$catalog) || return;
}
$update_stock->finish;
# delete the shopping cart -- it's now empty
$db->do("DELETE FROM ShoppingCart WHERE session_id=$id");
return $orderid;
}
1;
__END__
#!/usr/local/bin/perl
# catalog.cgi
# An online catalog/shopping cart demo. Uses DBI and CGI.pm.
use lib 'modules';
use DBI;
use CGI::Pretty qw/:standard/;
use Catalog;
use ShoppingCart;
use strict;
use constant DB => 'dbi:mysql:perl_conference';
use constant stylesheet => '/stylesheets/catalog.css';
# open database
my $db = DBI->connect(DB,undef,undef,{PrintError=>0}) || die $DBI::errstr;
# CGI parameters:
# -none- display catalog table o' contents (in no particular order)
# "catno" display catalog entry for indicated item
# "catno" "add" add catalog item to shopping cart
# "catno" "delete" delete catalog item from shopping cart
# Basic variables. Note that if we can't get a shopping cart object, we just exit.
# This is because the shopping cart generates an HTTP redirection automatically.
my $cart = ShoppingCart->new($db) || exit 0;
my $catalog = Catalog->new($db) || die "Couldn't create catalog";
my $catno = param('catno') unless param('browse');
my $title = $catno ? "Catalog \#$catno" : 'Kool Kitchen Koncepts';
# process adds/deletes on the shopping cart
process_shopping_cart($catno,$cart) if $catno;
# begin the page
print header(), # start HTTP
start_html(-Style => {src => stylesheet},
-Title => $title);
# display the requested item
if ($catno) {
display_item($catalog,$cart,$catno);
} else { # no item requested, so display table o' contents
display_list($catalog,$cart);
}
# display the shopping cart, if there is one
display_shopping_cart($catalog,$cart);
bottom_boilerplate();
print end_html;
$db->disconnect;
exit 0;
# Display a list of items in the catalog
sub display_list {
my ($catalog,$cart) = @_;
print h1('Our Katalog of Fine Kitchen Kitsch');
my $items = $catalog->list;
my ($count,@rows);
for my $catno (sort {$items->{$a} cmp $items->{$b}} keys %$items) {
my $class = $count++ % 2 ? '' : 'highlight'; # alternate highlight rows
my $url = $cart->rewrite_url(url() . "?catno=$catno");
push(@rows,
td ({-class=>$class},
[$items->{$catno},a({-href=>$url},$catno)])
);
}
print table({-width=>'100%'},
TR(th['Description','Catalog']),TR \@rows);
}
# display a selected catalog item
sub display_item {
my ($catalog,$cart,$catno) = @_;
my $info = $catalog->info($catno) || not_found_error($catno);
my $url = url(-path_info=>1);
print h1($info->{'name'});
print img({-alt=>"[$catno]",
-src=>$cart->rewrite_url("display.cgi?catno=$catno"),-align=>'LEFT'})
if $info->{'image'};
print p($info->{'description'}),
p(strong('Price:'),"\$$info->{price}",
($info->{'in_stock'} > 0 ? em('(In stock)')
: strong({-class=>'alert'},'Out of stock')));
# handle the shopping cart stuff
my $cart_data = $cart->fetch;
print start_form(-action=>url(-path_info=>1)),
hidden(-name=>'catno'),
submit(-name=>'browse',-value=>'Browse Catalog');
print submit(-name=>'delete',-value=>'Delete from Shopping Cart')
if $cart_data->{$catno} > 0;
print submit(-name=>'add', -value=>'Add to Shopping Cart'),
end_form;
}
# display the current shopping cart
sub display_shopping_cart {
my ($catalog,$cart) = @_;
my $url = url(-relative=>1);
my $items = $cart->fetch;
my @rows;
for my $catno (keys %$items) {
my $name = $catalog->info($catno)->{'name'};
my $left = $cart->items_left($catno);
my $backordered = $left >= 0 ? cite('in stock') : strong({-class=>'alert'},abs($left));
push(@rows,td({-align=>'LEFT'},
[ a({-href=>$cart->rewrite_url("$url?catno=$catno")},$catno),
$name,
textfield(-name=>$catno,-value=>$items->{$catno},
-override=>1,-size=>4)]) .
td({-align=>'CENTER'},$backordered));
}
return unless @rows;
print hr,
h2('Your Shopping Cart'),
start_form({-action=>$cart->rewrite_url('order.cgi')}),
table({-border=>undef},
TR(th ['Catalog','Description','Quantity','Backordered']),
TR \@rows),
submit('Place Order'),
end_form;
}
# Process the "add" and "delete" shopping cart buttons
sub process_shopping_cart {
my ($catno,$cart) = @_;
return unless param('add') || param('delete');
my $current = $cart->fetch;
$current->{$catno}++ if param('add');
$current->{$catno}=0 if param('delete');
$cart->store($current);
}
# Error message to display if the requested catalog number does not exist
# (?someone screwing around with our URL?).
sub not_found_error {
my $catno = shift;
print start_html(-style => {src => stylesheet},
-title => 'Unknown Product'),
h1('Unknown Product'),
p("The product with catalog number $catno is not on our current",
"stocklist. Please call our customer service representatives");
bottom_boilerplate();
exit 0;
}
sub bottom_boilerplate {
print hr,'Copyright 1999 ',a({-href=>'/'},'Kool Kitchen Concepts');
}
__END__
#!/usr/local/bin/perl
# display.cgi
# Fetch picture of product from the database
use strict;
use DBI;
use lib 'modules';
use Catalog;
use CGI 'header','param';
use vars '$DB';
use constant DB => 'dbi:mysql:perl_conference';
no_content() unless my $catno = param('catno');
# open database
$DB = DBI->connect(DB,undef,undef,{PrintError=>0}) || die $DBI::errstr;
my $catalog = Catalog->new($DB) || die;
no_content() unless my $image = $catalog->image($catno);
print header(-type => 'image/jpg',
-content_length => length($image));
print $image;
$DB->disconnect;
sub no_content {
print header(-status=>204);
$DB->disconnect if defined $DB;
exit 0;
}
__END__
The script also allows the user to make last minute changes to the list of items in the shopping cart, and recalculates the order amount.
#!/usr/local/bin/perl
# order.cgi
# online order-entry system for catalog demo
use lib './modules';
use strict;
use DBI;
use CGI::Pretty qw/:standard/;
use Catalog;
use ShoppingCart;
use constant DB => 'dbi:mysql:perl_conference';
use constant SHIPPING => '10.50';
use constant stylesheet => '/stylesheets/catalog.css';
# open database
my $db = DBI->connect(DB,undef,undef,{PrintError=>0}) || die $DBI::errstr;
my $cart = ShoppingCart->new($db) || exit 0;
my $catalog = Catalog->new($db) || die "Couldn't create catalog";
# CGI parameters:
# $catalog number of this item
# "confirm" confirm order
# "update" update quantities on order form
# items on the customer/order info form
my %labels = (
'name' => 'Full Name (required)',
'address1' => 'Address line 1 (required)',
'address2' => 'Address line 2',
'city' => 'City (required)',
'state' => 'State/Province (required)',
'country' => 'Country (required)',
'zip' => 'Zip Code (required)',
'telephone' => 'Daytime Phone (required)',
'ccno' => 'Credit Card MC/Visa/Amex (required)',
'expires' => 'Expiration date (required)'
);
# process any last-minute changes to the shopping cart
process_cart($cart);
# If there's nothing to order, then return to catalog main page?
unless (keys %{$cart->fetch}) {
print redirect($cart->rewrite_url('catalog.cgi'));
exit 0;
}
# start the HTML document
print header();
print start_html(-style => {src => stylesheet},
-title => 'Kool Kitchen Koncepts Order Form'),
h1('Order from Kool Kitchen Koncepts'),
p("Our one-klick order form makes ordering kwick and easy!");
# If the "confirm" parameter is present, then try to place the order.
# The ShoppingCart will do all the hard stuff.
my $confirmation;
if (param('confirm')) {
my $order_data = CGI::Vars(); # magic CGI.pm function (recent addition)
$confirmation = $cart->place_order($order_data);
print $@ unless $confirmation; # couldn't confirm so give error message
}
# If there's a confirmation number, then we've placed the order successfully,
# so we print it.
if ($confirmation) {
print_confirmation($confirmation,$cart);
}
# otherwise we display the shopping cart and customer/order info form.
else {
print start_form;
display_shopping_cart($catalog,$cart);
display_order_form();
print end_form;
}
bottom_boilerplate($cart);
$db->disconnect;
exit 0;
# This is called to print the order confirmation number.
sub print_confirmation {
my ($confirmation_id,$cart) = @_;
print h2('Your order has been entered'),
h3("Confirmation \# $confirmation_id"),
p('Please keep this number for your records.');
}
# This is called to display the shopping cart and current totals.
sub display_shopping_cart {
my ($catalog,$cart) = @_;
my $items = $cart->fetch;
my (@rows,$total);
for my $catno (keys %$items) {
my $info = $catalog->info($catno);
my $left = $cart->items_left($catno);
my $backordered = $left >= 0 ? ''
: strong({-class=>'alert'},
abs($left) . ' item(s) backordered');
push(@rows,
td(
[a({-href=>$cart->rewrite_url("catalog.cgi?catno=$catno")},$catno),
$info->{'name'} ] ).
td({-align=>'RIGHT'},
[ textfield(-name=>$catno, -value=>$items->{$catno}, -size=>3),
$info->{'price'},
sprintf('%4.2f',$items->{$catno} * $info->{'price'}),
$backordered ]
));
$total += $items->{$catno} * $info->{'price'};
}
push(@rows,
td({-class=>'highlight',-align=>'RIGHT',-colspan=>4},'Shipping/Handling') .
td({-class=>'highlight',-align=>'RIGHT'},"\$",SHIPPING));
push(@rows,
th({-align=>'RIGHT',-colspan=>4},'Total') .
th({-align=>'RIGHT'},"\$",sprintf('%4.2f',SHIPPING + $total)));
print table({-width=>'100%'},
TR(th(['Catalog','Name','Quantity', 'Price','Total Price','B.O.'])),
TR(\@rows)),
submit('Recalculate');
}
# This is called to display the customer/order information form.
sub display_order_form {
my @rows;
param(-name=>'country',-value=>'USA'); # default
for my $field (qw(name address1 address2 city
state country zip telephone ccno expires)) {
push(@rows,
th({-align=>'RIGHT'},$labels{$field}) .
td(textfield(-name=>$field,-size=>40)));
}
print hr,
h3('Shipping/Payment Information'),
table(TR(\@rows)),
submit(-name=>'confirm',-value=>'Confirm Order'),
hr;
}
# This is called to update the contents of the shopping cart if any
# last-minute changes have been made.
sub process_cart {
my $cart = shift;
my $items = $cart->fetch;
my $changed;
foreach (keys %$items) {
next unless defined param($_);
$items->{$_} = param($_);
$changed++;
}
$cart->store($items) if $changed;
}
sub bottom_boilerplate {
my $cart = shift;
print p(a({-href=>$cart->rewrite_url('catalog.cgi')},'Browse our katalog')),
hr,'Copyright 1999 ',a({-href=>'/'},'Kool Kitchen Concepts');
}
__END__
#!/usr/local/bin/perl # This program loads the DBI ProductList table from an XML file. use ProductParser; use DBI; use File::Basename; use constant DB =>'DBI:mysql:perl_conference'; my $DB = DBI->connect( DB,undef,undef,{PrintError=>0} ) || die "Connect failure: ",$DBI::errstr; unshift @ARGV,'-' unless @ARGV; while (my $file = shift) { my $h = ProductParser->new; $h->parse_file($file); insert_records($DB,$h); } $DB->disconnect; sub insert_records { my $db = shift; my $data = shift; my $insert = $db->prepare(<<END) || die $db->errstr; INSERT INTO ProductList (name,description,price,image,catalog) VALUES (?,?,?,?,?) END my $update = $db->prepare(<<END) || die $db->errstr; UPDATE ProductList SET name=?,description=?,price=?,image=? WHERE catalog=? END ; for my $item ($data->list) { my $picture; if ($item->{'image'} && -e $item->{'image'}) { open (I,$item->{'image'}) || die "open: $!"; local $/ = undef; $picture = <I>; close I; } $item->{'image'} =~ basename($item->{'image'}); $insert->execute($item->{'name'}, $item->{'description'}, $item->{'price'}, $picture, $item->{'catalog'}) || $update->execute($item->{'name'}, $item->{'description'}, $item->{'price'}, $picture, $item->{'catalog'} ) || warn "Can't load $item->{name}: ",$db->errstr,"\n"; } $insert->finish; $update->finish; } __END__
package ProductParser;
use HTML::Parser;
@ISA = 'HTML::Parser';
sub start {
my $self = shift;
my ($tag,$attr,$attrseq,$origtext) = @_;
if ($tag eq 'productlist') {
$self->{'list'} = [];
return;
}
if ($tag eq 'item') {
die "item without a productlist" unless $self->{'list'};
die "no catalog number" unless $attr->{'catalog'};
$self->{'currentitem'} = { catalog => $attr->{'catalog'} };
return;
}
if ($tag eq 'image') {
$self->{'currentitem'}->{'image'} = $attr->{'location'};
return;
}
die "unknown tag" unless $tag =~ /^(price|description|name)$/;
$self->{'current_text'} = '';
}
sub text {
my $self = shift;
my $text = shift;
HTML::Entities::decode($text);
$text =~ s/\n\s+/ /g;
$text =~ s/^\s+//;
$self->{'current_text'} .= $text;
}
sub end {
my $self = shift;
my $tag = shift;
if ($tag eq 'item') {
die "</item> without <item>" unless $self->{'currentitem'};
push @{$self->{'list'}},$self->{'currentitem'};
return;
}
if ($tag =~ /^(price|description|name)$/) {
$self->{'currentitem'}->{$tag} = $self->{'current_text'};
}
}
sub list {
return unless my $l = $_[0]->{'list'};
return @$l;
}
1;
__END__
<productlist>
<item catalog="64-2059954">
<name>Chef's Choice Professional Knife Sharpener</name>
<price>129.00</price>
<description>
This automatic sharpener turns out knives -- both straight-edge
and serrated -- with a razor-sharp edge, and won't destroy the
temper of fine kitchen blades. It's quick and easy to use:
Simply pass the knife once through each slot. In a three-stage
process, blades are sharpened and honed on 100% diamond
abrasive pads, then stropped for a smooth edge. Blades are
aligned at the perfect angle, and you can select the type
of edge, depending on the knife's use. Made in the USA.
</description>
<image location="images/sharpener.jpg"></image>
</item>
<item catalog="64-137877">
<name>Fini Aceto Balsamico</name>
<price>10.50</price>
<description>
This superb balsamic vinegar, made in Modena, Italy, from
sweet, white Trebbiano grapes, grows richer and darker as
it's aged for about two years, all the while being transferred
to smaller and smaller barrels of different aromatic woods
(oak, chestnut, mulberry and juniper). Recipes included.
8.8-oz bottle.
</description>
<image location="images/vinegar.jpg"></image>
</item>
<item catalog="64-1201565">
<name>Waring Commercial Blender</name>
<price>199.00</price>
<description>
Waring's powerful blender is without peer. With its two-speed
motor and newly designed blades, you can puree soups and
to silky-smooth consistency. It liquefies fruit or cooked
vegetables completely, without leqving pulp, and has
superb ice-crushing capabilities. The snug-fittig lid has an
insert so you can add ingredients while blending. To promote
extra-long life, the machine shuts off if blades are blocked;
To restart, simply push the reset button. Made of
stainless steel. 32-oz cap. 13 1/2" high.
</description>
<image location="images/blender.jpg"></image>
</item>
<item catalog="64-135517">
<description>
Each of our bowls is made by hand from a single piece of
beautifully grained hardwood that has been carefully
selected, kiln-dried and formed by skilled woodworkers.
Treated with care and a little oil, they will last for
years.
</description>
<image location="images/blender.jpg"></image>
<name>Handcrafted Salad Bowls</name>
<price>39.00</price>
</item>
<item catalog="64-2743953">
<price>
32.00
</price>
<name>
French Salt & Pepper Mills
</name>
<description>
Made by a small factory near Paris by genuine
French-speaking craftsmen, these beechwood and glass
mills reveal the colorful peppercorns and salt crystals
within. They have adjustable grinding mechanisms and
refill easily from the top. 2 1/2" diam., 6 1/4" high.
Please specify White or Blue.
</description>
<image location="images/grinders.jpg"></image>
</item>
</productlist>
#!/usr/local/bin/perl
use DBI;
use constant DB=>'dbi:mysql:perl_conference';
my $db = DBI->connect( DB,undef,undef,{PrintError=>0} )
|| die "Connect failure: ",$DBI::errstr;
my $insert = $db->prepare(<<END) || die $db->errstr;
INSERT INTO StockList (quantity,catalog)
VALUES (?,?)
END
my $update = $db->prepare(<<END) || die $db->errstr;
UPDATE StockList SET quantity=? WHERE catalog=?
END
;
while (<>) {
chomp;
next unless my ($catalog,$quant) = split /\s+/;
$insert->execute($quant,$catalog) || $update->execute($quant,$catalog)
|| warn "Can't load $catalog: ",$db->errstr,"\n";
}
$db->disconnect;
__END__
64-2059954 12 64-137877 100 64-1201565 4 64-135517 21 64-2743953 2
HTML,BODY {
background-color: #FFFFFF
}
H1,H2,H3,H4,P,I,EM,B,LI,UL,OL,DD,DT,ADDRESS,DL,A,STRONG {
font-family: sans-serif;
background-color: transparent
}
INPUT {
font-family: sans-serif;
background-color: #FFFFFF
}
H1 {
font-size: 18pt;
color: red;
}
H2 {
font-size: 18pt;
}
H3 {
font-size: 14pt;
}
STRONG.alert {
color: red;
}
TH {
font-family: sans-serif;
padding: 0;
margin: 0;
}
TD {
font-family: sans-serif;
padding: 0;
margin: 0;
}
TD.highlight {
font-family: sans-serif;
background-color: rgb(200,255,255);
padding: 0;
margin: 0;
}
Companion Web site at http://www.genome.wi.mit.edu/WWW/
Companion Web site at http://www.w3.org/Security/Faq/
Companion Web site at http://www.wiley.com/compbooks/stein/
Companion Web site at http://www.modperl.com/