Program Listings

Listings 7-1 to 7-5 contain the complete and uninterrupted code listings for the applications in this chapter. The templates for all of these pages are located on this book's companion Web site under the code for this chapter.

Listing 7-1: MySQL tables

start example
# MySQL dump 8.16 # # Host: localhost    Database: auction #-------------------------------------------------------- # Server version    3.23.47 # # Table structure for table ‘auction' # CREATE TABLE auction (   auction_id int(11) NOT NULL auto_increment,   name varchar(50) default NULL,   start_bidding datetime default NULL,   stop_bidding datetime default NULL,   PRIMARY KEY  (auction_id) ) TYPE=MyISAM; # # Table structure for table ‘bids' # CREATE TABLE bids (   bid_id int(11) NOT NULL auto_increment,   item_id int(11) default NULL,   amount double default NULL,   bidtime timestamp(14) NOT NULL,   first_name varchar(40) default NULL,   last_name varchar(40) default NULL,   phone varchar(20) default NULL,   PRIMARY KEY  (bid_id) ) TYPE=MyISAM; # # Table structure for table ‘donor' # CREATE TABLE donor (   donor_id int(11) NOT NULL auto_increment,   name varchar(50) default NULL,   address1 varchar(50) default NULL,   address2 varchar(50) default NULL,   city varchar(50) default NULL,   state char(2) default NULL,   zip varchar(10) default NULL,   phone varchar(20) default NULL,   contact varchar(50) default NULL,   PRIMARY KEY  (donor_id) ) TYPE=MyISAM; # # Table structure for table ‘item' # CREATE TABLE item (   item_id int(11) NOT NULL auto_increment,   name varchar(50) default NULL,   description varchar(255) default NULL,   image_url varchar(200) default NULL,   donor_id int(11) default NULL,   value double default NULL,   min_bid double default NULL,   min_incr double default NULL,   auction_id int(11) default NULL,   PRIMARY KEY  (item_id) ) TYPE=MyISAM;
end example

Listing 7-2: index.cgi

start example
01: #!/usr/bin/perl -wT 02: # index.cgi 03: # Chapter 7 04: use strict; 05: use CGI qw(:standard); 06: use DBI; 07: use lib qw(.); 08: use SmallAuction; 09: $ENV{PATH} = ‘'; 10: my $tmpl   = "templates"; 11: my $a_id = 1;  # Auction id number. 12: my $dbh = DBI->connect("dbi:mysql:auction", "bookuser",         "testpass")  13:     or die("Error! $!\nAborting"); 14: my %item = (); 15: print header; 16: $item{item_list}    = Drop_Down_Item_List($dbh, $a_id,                    "name"); 17: $item{auction_name} = Page_Header($dbh, $tmpl, $a_id); 18: Print_Page($tmpl, "index.tmpl", \%item); 19: $dbh->disconnect;
end example

Listing 7-3: view_all.cgi

start example
01: #!/usr/bin/perl -T 02: # view_all.cgi 03: use strict; 04: use CGI qw(:standard); 05: use DBI; 06: use lib qw(.); 07: use SmallAuction; 08: $ENV{PATH} = ‘'; 09: my $a_id = 1;   # Auction id number. 10: my $begin_at       = param(‘begin_at') || 0; 11: my $num_to_display = 10; 12: my %item = (); 13: my $tmpl = "templates"; 14: my $dbh = DBI->connect("dbi:mysql:auction", "bookuser",          "testpass")  15:     or die("Error! $!\nAborting"); 16: $item{item_list}      = Drop_Down_Item_List($dbh, $a_id,         "name"); 17: my ($sth_item, $sth_bids) = Get_Item_Table($dbh, "name",         $begin_at, $num_to_display); 18: my ($name, $item_id, $descr, $min_bid, $min_incr); 19: $sth_item->bind_columns(\($name, $item_id, $descr,         $min_bid, $min_incr)); 20: print header; 21: my $auction_name = Page_Header($dbh, $tmpl, $a_id); 22: Print_Page($tmpl, "view_all.tmpl", \%item); 23: my %hi_bid; 24: while(my($amount, $item, $fname, $lname) =         $sth_bids->fetchrow_array){ 25:     $hi_bid{$item}->{name}   = "$fname $lname"; 26:     $hi_bid{$item}->{amount} = "$amount"; 27: } 28: my $color = "e0e0e0"; 29: my $count = 0; 30: while($sth_item->fetch){ 31:     my $hi_bid; 32:     $count++; 33:     $color = ($color eq "e0e0e0") ?  "ffffff" :              "e0e0e0"; 34:     if(length($descr) > 40){ 35:         $descr  = substr($descr, 0, 37); 36:         $descr .= "..."; 37:     } 38:     $name = qq(<a           href="/cgi-bin/chapter6/view_item.cgi?item=$item_id" 39:                >$name</a>); 40:     $min_bid  = sprintf("%0.2f", $min_bid); 41:     $min_incr = sprintf("%0.2f", $min_incr); 42:     $hi_bid   = sprintf("%0.2f",              $hi_bid{$item_id}->{amount}); 43:     print qq( 44:       <tr bgcolor="#$color"> 45:        <td align="left"> 46:         <font >$name</font> 47:        </td> 48:        <td align="center"> 49:         <font >$item_id</font> 50:        </td> 51:        <td align="left"> 52:         <font >$descr</font> 53:        </td> 54:        <td align="center"> 55:         <font >\$$hi_bid</font> 56:        </td> 57:        <td align="center"> 58:         <font >\$$min_bid</font> 59:        </td> 60:        <td align="center"> 61:         <font >\$$min_incr</font> 62:        </td> 63:        <td align="center"> 64:      <font >$hi_bid{$item_id}->{name}</font> 65:        </td> 66:       </tr> 67:     ); 68: } 69: my ($prev, $next, $prev_link, $next_link); 70: $prev = ($begin_at - $num_to_display); 71: $prev_link =             qq(&lt; View Prev $num_to_display items); 72:     $prev_link = qq(<b><a href="?begin_at=$prev" 73:         >&lt; View Prev $num_to_display items</a></b>) unless ($prev < 0); 74: if($count == $num_to_display) { 75:     $next = ($begin_at + $num_to_display); 76:     $next_link = qq(<b><a href="?begin_at=$next" 77:         >View Next $num_to_display items &gt;</a></b>); 78: }  79: else { 80:    $next_link = qq(View Next $num_to_display items &gt;); 81: } 82: print qq( 83:      </table> 84:     </td> 85:    </tr>     86:    <tr> 87:     <td colspan="2" align="center"> 88:      <font > 89:        $prev_link 90:        &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 91:        $next_link 92:      </font> 93:     </td> 94:    </tr> 95: ); 96: Print_Page($tmpl, "footer.tmpl", \%item); 97: $dbh->disconnect;
end example

Listing 7-4: view_item.cgi

start example
01: #!/usr/bin/perl -wT 02: # view_item.cgi 03: use strict; 04: use CGI qw(:standard); 05: use DBI; 06: use lib qw(.); 07: use SmallAuction; 08: my %item = (); 09: my @err  = (); 10: $item{button}  = param(‘bid_button'); 11: $item{$_}      = param($_) 12:     for( qw(item phone fname lname amount minimum) ); 13: $ENV{PATH} = ‘'; 14: my $a_id   = 1;   ### Auction ID 15: my $tmpl   = "templates";  16: my $count  = 0; 17: my $dbh = DBI->connect("dbi:mysql:auction", "bookuser",          "testpass")  18:     or die("Error! $!\nAborting"); 19: my @money = qw(min_bid min_incr value hi_bid needed          minimum amount); 20: @item{qw(name item_id desc min_bid min_incr value donor hi_bid)} = Get_Item_Details($dbh, $item{item}); 21: if($item{hi_bid} > 0) { 22:     $item{needed} = $item{hi_bid} + $item{min_incr}; 23: } 24: else { 25:     $item{needed} = $item{min_bid}; 26: } 27: for my $val (@money) { 28:     $item{$val} = sprintf("%0.2f", $item{$val}); 29: } 30: print header; 31: my $auction_name  = Page_Header($dbh, $tmpl, $a_id); 32: my $empty_form    = 1; 33: $item{item_list}  = Drop_Down_Item_List($dbh, $a_id,          "name"); 34: if($item{button} eq ‘Submit Bid'){ 35:     my $rval = Is_Bidding_Open($dbh, $a_id); 36:     unless($rval) { 37:         Print_Page($tmpl, "closed.tmpl", \%item); 38:         Print_Page($tmpl, "footer.tmpl", \%item); 39:     exit; 40:     } 41:     @err          = Check_Data(); 42:     $item{errors} = join(‘<br />', @err); 43:     $empty_form   = 0; 44: } 45: if(@err or $empty_form){ 46:     Print_Page($tmpl, "view_item.tmpl", \%item); 47: } 48: else { 49:     Submit_Bid($dbh, \%item); 50:     Print_Page($tmpl, "confirmation.tmpl", \%item); 51: } 52: Print_Page($tmpl, "footer.tmpl", \%item); 53: $dbh->disconnect; 54: sub Check_Data { 55:     my @err = (); 56:     my %bid = ( 57:         phone  => { value    => $item{phone}, 58:                     required => 1, 59:                 filter   => ‘PHONE', 60:                 error => ‘Error with the phone number.', 61:                   }, 62:         amount => { value    => $item{amount}, 63:                     required => 1, 64:                     filter   => ‘CURRENCY', 65:                     error    => ‘Error with the amount.', 66:                     error2   => ‘Bid too low.', 67:                   }, 68:         fname  => { value    => $item{fname}, 69:                     required => 1, 70:                     filter   => ‘TEXT', 71:                    error => ‘Error with the First Name.', 72:                   }, 73:         lname  => { value    => $item{lname}, 74:                     required => 1, 75:                     filter   => ‘TEXT', 76:                     error => ‘Error with the Last Name.', 77:                   }, 78:     ); 79:     while(my($k,$v) = each %bid) { 80:         if($v->{filter} eq ‘TEXT') { 81:         push @err, $v->{error}  82:             unless($v->{value} =~ /^[\w \.\']+$/); 83:     } 84:         elsif($v->{filter} eq ‘CURRENCY') { 85:         push @err, $v->{error}  86:             unless($v->{value} =~ /^\$?[\d\.\,]+$/); 87:         push @err, $v->{error2}  88:             if($item{needed} > $item{amount}); 89:     } 90:         elsif($v->{filter} eq ‘PHONE') { 91:         push @err, $v->{error}  92:            unless($v->{value} =~ /^[\d \.\-\(\)]{1,20}$/); 93:     } 94:     } 95:     return(@err); 96: }
end example

Listing 7-5: SmallAuction.pm

start example
01: package SmallAuction; 02: use strict; 03: use Date::Manip qw(UnixDate Date_Cmp); 04: use vars qw(@ISA @EXPORT); 05: use Exporter; 06: @ISA = qw(Exporter); 07: @EXPORT = qw(Page_Header Drop_Down_Item_List Print_Page 08:              Is_Bidding_Open Get_Item_Details Submit_Bid 09:              Get_Item_Table); 10: sub Print_Page { 11:     my $tmpl = shift; 12:     my $page = shift; 13:     my $item = shift; 14:     open(TMPL, "$tmpl/$page")              or die("ERROR: $!\nAborting"); 15:         while(<TMPL>) { 16:             s/%%(\w+)%%/$item->{$1}/g; 17:             print; 18:         } 19:     close(TMPL); 20:     return; 21: } 22: sub Page_Header { 23:     my $dbh  = shift; 24:     my $tmpl = shift; 25:     my $a_id = shift; 26:     my ($start, $stop, %item); 27:     my @format = qw(%A, %B %E at %i:%M%p %Z); 28:     my $sql  = qq(SELECT name, start_bidding,              stop_bidding 29:                   FROM auction WHERE auction_id = ?); 30:     my $sth  = $dbh->prepare($sql); 31:     $sth->execute($a_id); 32:     ($item{auction}, $start, $stop) =             $sth->fetchrow_array; 33:     $item{start_date} = UnixDate($start, @format); 34:     $item{stop_date}  = UnixDate($stop, @format); 35:     Print_Page($tmpl, "header.tmpl", \%item); 36:     return($item{auction}); 37: } 38: sub Is_Bidding_Open { 39:     my $dbh  = shift; 40:     my $a_id = shift; 41:     my $sql  = qq(SELECT start_bidding, stop_bidding 42:                   FROM auction WHERE auction_id = ?); 43:     my $sth  = $dbh->prepare($sql); 44:     $sth->execute($a_id); 45:     my ($start, $stop) = $sth->fetchrow_array; 46:     return 0 if Date_Cmp("today", $start) == -1;  47:     return 0 if Date_Cmp($stop, "today") == -1;  48:     return 1; 49: } 50: sub Drop_Down_Item_List { 51:     my $dbh     = shift; 52:     my $auction = shift; 53:     my $sorted  = shift; 54:     my $sql     = qq(SELECT item_id, name FROM item WHERE  55:                      auction_id = ?); 56:      $sql .= " ORDER BY $sorted" if $sorted; 57:     my $sth     = $dbh->prepare($sql); 58:     my $options = undef; 59:     $sth->execute($auction); 60:     while(my $p = $sth->fetch) { 61:         $options .= qq(<option                 value="$p->[0]">$p->[1]</option>\n); 62:     } 63:     return($options); 64: } 65: sub Submit_Bid { 66:     my $dbh     = shift; 67:     my $item    = shift; 68:     my $sql_bid = qq(INSERT INTO bids  69:                      (item_id, amount, first_name,  70:               last_name, phone)  71:                      VALUES (?, ?, ?, ?, ?)); 72:     my $sth_bid = $dbh->prepare($sql_bid); 73:     $sth_bid->execute( @$item{ qw(item amount fname lname              phone)}); 74:     return; 75: } 76: sub Get_Item_Details { 77:     my $dbh     = shift; 78:     my $item_id = shift; 79:     my $sql_item  =  80:         qq(SELECT  81:         a.name, a.item_id, a.description,  82:             a.min_bid, a.min_incr, a.value, b.name 83:        FROM  84:         item AS a, donor AS b 85:       WHERE  86:         a.item_id = ?  87:        AND  88:         a.donor_id = b.donor_id 89:           ); 90:     my $sql_bids  =  91:         qq(SELECT MAX(amount) 92:            FROM bids  93:            WHERE item_id = ?  94:     my $sth_item  = $dbh->prepare($sql_item); 95:     my $sth_bids  = $dbh->prepare($sql_bids); 96:     $sth_item->execute($item_id); 97:     $sth_bids->execute($item_id);      98:     my @data = $sth_item->fetchrow_array; 99:     my $temp = $sth_bids->fetchrow_array; 100:     push @data, $temp; 101:     return(@data); 102: } 103: sub Get_Item_Table{ 104:     my $dbh       = shift; 105:     my $sort      = shift; 106:     my $start_at  = shift; 107:     my $count     = shift; 108:     $start_at = 0 unless $start_at; 109:     $count    = 5 unless $count; 110:     my $sql_item  = qq(SELECT name, item_id,               description,  111:                        min_bid, min_incr FROM item  112:                ORDER BY $sort LIMIT $start_at,                            $count); 113:     my $sth_item  = $dbh->prepare($sql_item); 114:     $dbh->do("CREATE TEMPORARY TABLE tmp(amount double,               item_id int)"); 115:     $dbh->do("LOCK TABLES bids, item read"); 116:     $dbh->do("INSERT INTO tmp SELECT MAX(amount),  117:               item_id FROM bids GROUP BY item_id"); 118:     my $sql_bids = qq(SELECT bids.amount, bids.item_id,                        first_name,  119:                  last_name FROM bids, tmp WHERE  120:               bids.amount=tmp.amount AND 121:               bids.item_id=tmp.item_id); 122:     my $sth_bids  = $dbh->prepare($sql_bids); 123:     $sth_item->execute; 124:     $sth_bids->execute; 125:     $dbh->do("DROP TABLE tmp"); 126:     $dbh->do("UNLOCK TABLES"); 127:     return($sth_item, $sth_bids); 128: } 129: 1;
end example



Perl Database Programming
Perl Database Programming
ISBN: 0764549561
EAN: 2147483647
Year: 2001
Pages: 175

Similar book on Amazon

flylib.com © 2008-2017.
If you may any questions please contact us: flylib@qtcs.net