Program Listings | Perl Database Programming

Listings 6-1 to 6-8 contain the complete and uninterrupted code listings for the applications in this chapter.

Listing 6-1: Web Phonebook Application

01: #!/usr/bin/perl -wT 02: # 03: # program 7-1 04: # Web Phonebook Application 05: #  06: use strict; 07: use DBI; 08: use CGI qw(:standard); 09: use CGI::Carp qw(fatalsToBrowser); 10: print header(); 11: my $action = param(‘form_action'); 12: my $DB_Handle = DBI->connect("DBI:mysql:BibleBook",      "bookuser", "testpass") 13:     or die("Cannot connect: $DBI::errstr\nAborting"); 14: Add_Record() if($action eq ‘addrecord'); 15: Search_DB()  if($action eq ‘search'); 16: sub Search_DB { 17:     my ($sql, $st_handle); 18:     my $search_for = param(‘search'); 19:     my @field      = param(‘field'); 20:     @field = map { "($_ LIKE ‘%$search_for%')" } @field; 21:     $sql  = qq{SELECT * FROM phonebook WHERE (}; 22:     $sql .= join ‘ OR ‘, @field; 23:     $sql .= ")"; 24:     $st_handle =  $DB_Handle->prepare($sql); 25:     $st_handle -> execute(); 26:     Display_Results($st_handle); 27: }  28: sub Display_Results { 29:     my $handle = shift; 30:     my ($fname, $lname, $cow, $phone, $ext, $cell, $pager,              $notes, $count); 31:     my $bgcol = ""; 32:     print<<'    HTML'; 33:      <html><head><title>Search Results</title></head> 34:       <body> 35:        <table align="center" border="1" cellspacing="0"> 36:         <tr bgcolor="#303030"> 37:          <td colspan="6" align="center"> 38:           <font size="5" color="white"> 39:            Search Results 40:           </font> 41:          </td> 42:         </tr>  43:         <tr bgcolor="#c0c0c0"> 44:          <td align="center"><b>Name</b></td> 45:          <td align="center"><b>Co-Worker?</b></td> 46:          <td align="center"><b>Phone</b></td> 47:          <td align="center"><b>Extension</b></td> 48:          <td align="center"><b>Cell</b></td> 49:          <td align="center"><b>Pager</b></td> 50:         </tr>  51:     HTML 52:     $handle->bind_columns(undef,  53:      \($fname, $lname, $cow, $phone, $ext, $cell,             $pager,$notes)); 54:     while($handle->fetch){  55:         $bgcol = ($bgcol eq "ffffff") ? "e0e0e0"                                   : "ffffff"; 56:    print qq(<tr bgcolor="#$bgcol">); 57:     print qq(<td>$fname $lname</td><td          align="center">$cow</td>); 58:     print qq(<td>$phone</td><td>$ext</td><td>$cell</td>); 59:     print qq(<td>$pager</td>); 60:    print qq(</tr>); 61:      $count++; 62:     } 63:     No_Data() unless($count); 64:     print qq(</table></body></html>); 65: } 66: sub No_Data{ 67:    print qq(<tr><td colspan="6" align="center">); 68:    print qq(No matches found, return to); 69:    print qq(<a href="/phonebook/phone.html">main page</a>.); 70:    print qq(</td></tr>); 71: } 72: sub Add_Record { 73:     my $fname    = param(‘firstname'); 74:     my $lname    = param(‘lastname'); 75:     my $phone    = param(‘phone'); 76:     my $ext      = param(‘extension'); 77:     my $cell     = param(‘cell'); 78:     my $pager    = param(‘pager'); 79:     my $coworker = param(‘coworker'); 80:     my $notes    = param(‘notes'); 81:     my $sql; 82:     $sql  = qq{INSERT INTO phonebook (firstname, lastname,}; 83:     $sql .= qq{coworker, phone, extension, cell, pager,                     notes)}; 84:     $sql .= qq{VALUES (?, ?, ?, ?, ?, ?, ?, ?)}; 85:     my $st_handle = $DB_Handle->prepare($sql); 86:    my $rval = $st_handle->execute($fname, $lname, $coworker, 87:         $phone, $ext, $cell, $pager, $notes); 88:     Handle_DB_Error() unless($rval); 89:     Display_Page(); 90: } 91: sub Display_Page { 92:     print<<'    HTML'; 93:     <html><head><title>Record Added!</title></head> 94:      <body> 95:       <center> 96:        <font size="6"> 97:         Record Added! 98:        </font> 99:        <hr /> 100:       <font size="4"> 101:       <a href="/phonebook/phone.html">Back to Main Page</a> 102:        </font><br /> 103:       </center> 104:      </body> 105:     </html> 106:     HTML 107: } 108: sub Handle_DB_Error { 109:     print<<'    HTML'; 110:     <html><head><title>Database Error</title></head> 111:      <body> 112:       <center> 113:        <font size="6"> 114:         Error with database call. 115:        </font> 116:        <hr /> 117:        <font size="4" color="red"> 118:         $DBI::errstr 119:        </font><br /> 120:        <font size="3"> 121:         Please hit your <b>back</b> button to re-enter the              data and try again. 122:        </font> 123:       </center> 124:      </body> 125:     </html> 126:     HTML 127:     exit; 128: }

Listing 6-2: Database tables for Quizzer application

CREATE TABLE questions (   Qid       INT NOT NULL AUTO_INCREMENT,   Qtext     VARCHAR(255) DEFAULT NULL,   TestID    INT DEFAULT NULL,   PRIMARY KEY(Qid)   ); CREATE TABLE answers (   Aid       INT NOT NULL AUTO_INCREMENT,   Qid       INT NOT NULL,   text      VARCHAR(255) DEFAULT NULL,   correct   CHAR(1) default "N",   PRIMARY KEY(Aid)   ); CREATE TABLE test_config (   TestID    INT NOT NULL AUTO_INCREMENT,   NumQs     INT NOT NULL,   Choices   INT NOT NULL,   PRIMARY KEY(TestID)   );

Listing 6-3: add_question.cgi

01: #!/usr/bin/perl -wT 02: # 03: # add_question.cgi 04: # Chapter 7 05: # Online Quizzer 06: # Add question 2 07: # 08: use strict; 09: use CGI qw(:standard); 10: use lib qw(.); 11: use Quizzer; 12: my $test_id = param(‘test_id'); 13: my $Qtext   = param(‘Qtext'); 14: my $correct = param(‘correct'); 15: my @false   = param(‘false'); 16: my $rval; 17: my ($TestID, $NumQs, $Choices, $test_name) =        Get_Test_Config($test_id); 18: if($Qtext ne ‘'){ 19:    $rval = Add_Question($Qtext, $test_id, $correct, @false); 20: }  21: print header(); 22: print <<HTML; 23:  <html><head><title>Add A Question</title></head> 24:   <body> 25:    <form action="add_question.cgi"> 26:     <input type="hidden" name="test_id" value="$test_id"> 27:     <table border="1" align="center"> 28:      <tr bgcolor="#c0c0c0"> 29:       <td colspan="2" align="center"> 30:       <font size="6">Add question to $test_name test.</font> 31:       </td> 32:      </tr>  33:      <tr bgcolor="#e0e0e0"> 34:       <td>&nbsp;</td> 35:       <td align="center"><b>Question/Answer Text</b></td> 36:      </tr> 37:      <tr> 38:       <td bgcolor="#e0e0e0"> 39:        <b>Question:</b> 40:       </td> 41:       <td><input type="text" size="60" name="Qtext"></td> 42:      </tr> 43:      <tr> 44:       <td bgcolor="#e0e0e0"> 45:        <b>Correct Answer:</b> 46:       </td> 47:       <td><input type="text" size="60" name="correct"></td> 48:      </tr> 49: HTML 50: for (1..($Choices - 1)){ 51:     print qq( 52:         <tr> 53:          <td bgcolor="#e0e0e0"> 54:           <b>False Answer:</b> 55:          </td> 56:          <td> 57:           <input type="text" size="60" name="false"> 58:          </td> 59:         </tr> 60:     ); 61: } 62: print <<HTML; 63:     <tr bgcolor="#e0e0e0"> 64:      <td colspan="2" align="center"> 65:       <input type="submit" value="Add Question"> 66:      </td> 67:     </tr> 68: HTML 69: if($rval){ 70:     print qq( 71:  <tr><td colspan="2"> 72:    <b><u>Question Added</u></b><br> 73:    <b>$Qtext</b> 74:     <ul> 75:      <li><font color="green">$correct</font> *Correct answer 76:     ); 77:     foreach my $tmp (@false){ print "<li>$tmp" if($tmp); } 78:     print qq(</ul></td>); 79: } 80: print <<HTML; 81:     </tr> 82:     <tr> 83:      <td colspan="2" align="center"> 84:       <a href="/quizzer/admin.html">Admin Menu</a> 85:      </td> 86:     </tr> 87:    </table> 88:   </form></body></html> 89: HTML

Listing 6-4: create_test.cgi

01: #!/usr/bin/perl -wT 02: # 03: # create_test.cgi 04: # Chapter 7 05: # Online Quizzer 06: # 07: use strict; 08: use DBI; 09: use CGI qw(:standard); 10: my $conn = DBI->connect("DBI:mysql:quizzer", "bookuser", 11:  "testpass") or die("Cannot connect: $DBI::errstr\nAborting"); 12: my $test_name = param(‘test_name'); 13: my $questions = param(‘questions'); 14: my $choices   = param(‘choices'); 15: my $rval = $conn->do("INSERT INTO test_config SET  16:     NumQs=$questions, Choices=$choices,  17:     test_name='$test_name'"); 18: my $val = $conn->{‘mysql_insertid'}; 19: print header(); 20: if($rval) { 21:     print <<"    HTML"; 22:      <html><head><title>Test Added!</title></head> 23:       <body> 24:        <font size="4"> 25:         <center>Test $val Added to Database!<br /> </center> 26:        </font> 27:       </body> 28:      </html> 29:     HTML 30: } 31: else { 32:     print <<"    HTML"; 33:      <html><head><title>Error!</title></head> 34:       <body> 35:        <font size="4"> 36:         <center> 37:          ERROR!!! ($DBI::errstr)<br /> 38:          Something unexpected happened!<br />  39:         </center> 40:        </font> 41:       </body> 42:      </html> 43:     HTML 44: }

Listing 6-5: score_test.cgi

01: #!/usr/bin/perl -wT 02: # 03: # score_test.cgi 04: # Chapter 7 05: # Online Quizzer 06: # Test scoring program 07: # 08: use strict; 09: use lib qw(.); 10: use CGI qw(:standard); 11: use Quizzer; 12: my $cookie  = cookie(‘Quizzer'); 13: my $test_id = param(‘test_id'); 14: my ($TestID, $NumQs, $Choices, $test_name) =        Get_Test_Config($test_id); 15: my ($wrong, $score) = Score_Test($cookie); 16: print header(); 17: print <<HTML; 18:  <html><head><title>Score Test</title></head> 19:   <body> 20:    <form action="take_test.cgi"> 21:     <input type="hidden" name="test_id" value="$test_id"> 22:     <table border="1" align="center"> 23:      <tr bgcolor="#c0c0c0"> 24:       <td align="center" colspan="2"> 25:        <font size="5">Missed Questions:  26:         $test_name</font><br> 27:        Score: $score\% 28:       </td> 29:      </tr>  30:      <tr bgcolor="#e0e0e0"> 31:       <td><b>Question</b></td> 32:       <td><b>Correct Answer</b></td> 33:      </tr> 34: HTML 35: for my $item (@$wrong) { 36:     print qq( 37:         <tr> 38:          <td> 39:       $item->{‘question'} 40:      </td> 41:      <td> 42:       $item->{‘answer'} 43:      </td> 44:     </tr> 45:     ); 46: } 47: print <<HTML; 48:     </tr> 49:     <tr> 50:      <td colspan="2" align="center"> 51:       <a href="/quizzer/index.html">Home Page</a> 52:      </td> 53:     </tr> 54:    </table> 55:   </form></body></html> 56: HTML

Listing 6-6: take_test.cgi

01: #!/usr/bin/perl -wT 02: # 03: # take_test.cgi 04: # Chapter 7 05: # Online Quizzer 06: # Test taker thing 07: # 08: use strict; 09: use lib qw(.); 10: use CGI qw(:standard); 11: use Quizzer; 12: my $cookie  = cookie(‘Quizzer'); 13: my $a_id    = param(‘a_id'); 14: my $test_id = param(‘test_id'); 15: my $q_id    = param(‘q_id'); 16: $test_id    = 2 unless($test_id); 17: my ($TestID, $NumQs, $Choices, $test_name) =         Get_Test_Config($test_id); 18: # check cookies here 19: my $data = "$TestID:$q_id:$a_id"; 20: $data    = $data . "*" . $cookie; 21: $data    = ‘' unless($a_id); 22: my $write_cookie = cookie(  23:     -name    => ‘Quizzer', 24:     -value   => $data, 25: ); 26: my ($Q, $Ans, $taken) = Get_Question($test_id, $data,       $NumQs, $write_cookie); 27: my $Qtext = $Q->{‘Qtext'}; 28: my $Qid   = $Q->{‘Qid'}; 29: $taken++;   30: print header(-cookie => $write_cookie); 31: print <<HTML; 32:  <html><head><title>Question $taken of $NumQs</title></head> 33:   <body> 34:    <form action="take_test.cgi"> 35:     <input type="hidden" name="test_id" value="$test_id"> 36:     <input type="hidden" name="q_id"    value="$Qid"> 37:     <table border="1" align="center"> 38:      <tr bgcolor="#c0c0c0"> 39:       <td align="center"> 40:        <font size="6">Test name: $test_name</font><br> 41:        Question $taken of $NumQs. 42:       </td> 43:      </tr>  44:      <tr> 45:       <td><b>$Qtext</b></td> 46:      </tr> 47: HTML 48: my @k = keys %{$Ans}; 49: fisher_yates_shuffle( \@k ); 50: for my $key (@k){ 51:     print qq( 52:         <tr> 53:          <td> 54:       &nbsp;&nbsp;&nbsp; 55:   <input type="radio" name="a_id" value="$key"> $Ans->{$key} 56:      </td> 57:     </tr> 58:     ); 59: } 60: print <<HTML; 61:     <tr bgcolor="#e0e0e0"> 62:      <td align="center"> 63:       <input type="submit" value="Submit Answer"> 64:      </td> 65:     </tr> 66: HTML 67: print <<HTML; 68:     </tr> 69:     <tr> 70:      <td colspan="2" align="center"> 71:       <a href="/quizzer/index.html">Home Page</a> 72:      </td> 73:     </tr> 74:    </table>  75:   </form></body></html> 76: HTML

Listing 6-7: test_chooser.cgi

01: #!/usr/bin/perl -wT 02: # 03: # test_chooser.cgi 04: # Chapter 7 05: # Online Quizzer 06: # Test Chooser 07: # 08: use strict; 09: use lib qw(.); 10: use Quizzer; 11: use CGI qw(:standard); 12: my $passed = param(‘action'); 13: my $title  = "Choose a Test to Take"; 14: $title     = "Add Question to?"  if($passed eq ‘add'); 15: my $action = "take_test.cgi"; 16: $action    = "add_question.cgi"  if($passed eq ‘add'); 17: my $sth_testlist = Get_Test_List(); 18: print header(); 19: print <<"HTML"; 20:      <html><head><title>Choose A Test</title></head> 21:       <body> 22:        <form action="$action"> 23:         <table border="1" align="center"> 24:      <tr bgcolor="#c0c0c0"> 25:       <td align="center"> 26:        <font size="5">$title</font> 27:       </td> 28:      </tr> 29:      <tr> 30:       <td align="center"><select name="test_id"> 31: HTML 32: while(my $p = $sth_testlist->fetchrow_hashref){ 33:     print "<option value='$p->{TestID}'>$p->{test_name}</option>"; 34: } 35: print <<HTML; 36:            </select> 37:           </td> 38:      </tr> 39:      <tr bgcolor="#e0e0e0"> 40:       <td align="center"> 41:        <input type="submit" value="Choose Test"> 42:       </td> 43:          </tr> 44:         </table> 45:        </form> 46:       </body></html> 47: HTML

Listing 6-8: Quizzer.pm

01: # Quizzer.pm 02: package Quizzer; 03: require Exporter; 04: use DBI; 05: my $conn = DBI->connect("DBI:mysql:quizzer", "bookuser",  06:      "testpass") or die("Cannot connect: $DBI::errstr\nAborting"); 07: our @ISA    = qw(Exporter); 08: our @EXPORT = qw(Add_Question Get_Test_Config Get_Question  09:              Score_Test fisher_yates_shuffle Get_Test_List); 10: sub Get_Test_List { 11:     my $sql = qq(SELECT test_name, TestID  12:         FROM test_config ORDER BY test_name); 13:   $sth_getlist = $conn->prepare($sql); 14:   $sth_getlist->execute() or die("Error! $DBI::errstr\nAborting"); 15:     return($sth_getlist); 16: } 17: sub Score_Test { 18:     my $cookie  = shift; 19:     my @data    = split(/\*/, $cookie); 20:     my $tot_q   = @data; 21:     my @wrong   = (); 22:     my $sth_Ans =  23:       $conn->prepare("SELECT a.Aid, a.Atext, q.Qtext 24:           FROM answers AS a, questions AS q WHERE  25:   ((q.Qid = ?) AND (a.Qid = q.Qid) AND (a.correct = ‘Y'))"); 26:     for(@data){ 27:         my %rec = (); 28:         my ($TestID, $q_id, $a_id) = split(/:/); 29:         $sth_Ans->execute($q_id)                or die("Error! $DBI::errstr\nAborting"); 30:     my $ans = $sth_Ans->fetch; 31:         if($ans->[0] ne $a_id) { 32:             $rec{‘answer'}   = "$ans->[1]"; 33:             $rec{‘question'} = "$ans->[2]"; 34:         push @wrong, \%rec; 35:     } 36:     } 37:     my $tot_w = @wrong; 38:     my $tot_s = sprintf("%2.0f", ((($tot_q-$tot_w)/$tot_q) * 100)); 39:     return(\@wrong, $tot_s); 40: } 41: sub Get_Question { 42:     my $test_id      = shift; 43:     my $cookie       = shift; 44:     my $num_qs       = shift; 45:     my $write_cookie = shift; 46:     my %Question; 47:     my %Answer; 48:     my %Qid; 49:     my @data = split(/\*/, $cookie); 50:     my $sth_Qlist =  51:       $conn->prepare("SELECT Qid FROM questions              WHERE TestID = ?"); 52:     $sth_Qlist->execute($test_id)             or die("Error! $DBI::errstr\nAborting"); 53:     my $Qnum = $sth_Qlist->fetchall_arrayref; 54:     @Questions = map { $_->[0] } @$Qnum; 55:     for(@data){ 56:         my @tmp = split(/:/); 57:         $Qid{$tmp[1]} = 1; 58:     } 59:     my $taken = keys(%Qid); # Count number taken 60:     while(1){ 61:         my $Qcount = @Questions; 62:         No_More_Questions($test_id, $write_cookie)  63:         if(($num_qs == $taken) or ($taken >= $Qcount)); 64:         $Qnum = $Questions[(int(rand($Qcount)))]; 65:         last unless(exists $Qid{$Qnum}); 66:     } 67:     $sql = qq{SELECT q.Qtext, q.Qid, a.Aid, a.Atext  68:               FROM questions AS q, answers AS a  69:               WHERE ((q.Qid = a.Qid) AND (q.Qid = ?))}; 70:     $sth_QA = $conn->prepare($sql); 71:     $sth_QA->execute($Qnum)            or die("Error! $DBI::errstr\nAborting"); 72:     while(my $p = $sth_QA->fetchrow_hashref) { 73:         $Question{‘Qid'}       = $p->{‘Qid'}; 74:         $Question{‘Qtext'}     = $p->{‘Qtext'}; 75:         $Answer  {$p->{‘Aid'}} = $p->{‘Atext'}; 76:     }   77:     return(\%Question, \%Answer, $taken); 78: } 79: sub fisher_yates_shuffle { 80:     my $array = shift; 81:     my $i; 82:     for($i = @$array; --$i;) { 83:         my $j = int rand ($i+1); 84:         next if $i == $j; 85:         @$array[$i,$j] = @$array[$j,$i]; 86:     } 87: }     88: sub No_More_Questions { 89:     my $TestID = shift; 90:     my $cookie = shift; 91:     print CGI::header(-cookie => $cookie); 92:     print qq(No more questions for this test.<br>); 93:     print qq(Click      <a href="/cgi-bin/quizzer/score_test.cgi?test_id=$TestID">); 96:     print qq(here</a> to score test.<br>); 97:     exit; 98: } 99: sub Get_Test_Config { 100:     my $test_id = shift; 101:     my $sql     = qq{SELECT * FROM test_config                WHERE TestID='$test_id'}; 102:     my $sth_cfg = $conn->prepare($sql); 103:     $sth_cfg->execute() or die("Error! $DBI::errstr\nAborting"); 104:     return ($sth_cfg->fetchrow_array()); 105: } 106: sub Add_Question { 107:     my ($Qtext, $test_id, $correct, @false) = @_; 108:     my $sql_Q  = qq{INSERT INTO questions (Qtext, TestID) 109:                    VALUES (‘$Qtext', ‘$test_id')}; 110:     my $sql_F  = qq{INSERT INTO answers (Qid, Atext) 111:                    VALUES (?, ?)};      # Wrong answers. 112:   my $sql_C  = qq{INSERT INTO answers (Qid, Atext, correct) 113:                  VALUES (?, ?, ‘Y')}; # Correct answer. 114:     my $sth_Q  = $conn->prepare($sql_Q); 115:     my $sth_F  = $conn->prepare($sql_F); 116:     my $sth_C  = $conn->prepare($sql_C); 117:     $sth_Q->execute() or die("Error! $DBI::errstr\nAborting"); 118:     my $Qid = $conn->{‘mysql_insertid'};     119:     $sth_C->execute($Qid, $correct)              or die("Error! $DBI::errstr\nAborting");   120:     for my $txt (@false) { 121:         next unless($txt); 122:         $sth_F->execute($Qid, $txt)                 or die("Error! $DBI::errstr\nAborting"); 123:     } 124:     return 1; 125: } 126: 1;