#!/usr/bin/perl -w # CIS 89B -- Lab-5.cgi # 04 June 2004 # Timothy Fox use CGI qw(:standard); use CGI::Carp qw(fatalsToBrowser); use CGI::Cookie; use Mail::Sendmail; use DBI; use Cwd; use File::Basename; use strict; use constant PAGE_1 => 1; use constant PAGE_2 => 2; use constant PAGE_3 => 3; use constant PAGE_4 => 4; my @allParams = qw(areas sciences arts philosophy invoice); my $journalName = "lab5log"; my $debug = 1; my %param = cookie('data'); foreach (@allParams) # params with list values { if (param($_)) # newer cgi param() overwrites entry in cookie %param { $param{$_} = join "\02", param($_); # refresh the cookie hash } else # sync in the other direction { param(-name => "$_", -value => [split /\02/, $param{$_}]); } } foreach ('page', 'go') # params with scalar values { if (param($_)) { $param{$_} = param($_); } else { param(-name => "$_", -value => $param{$_}); } } my $go = param("go"); my $page = param("page"); my $exp; ($go eq 'Done') ? ($exp = '-1d' ) : ($exp = '+30d'); if ($debug) { my $report = "After synchronizing, cookie hash is:"; appendJournal([\$report]); dumpHashToJournal(\%param); $report = "Entering dispatch table with go = $go, page = $page"; appendJournal([\$report]); } # Sift the cookie ingredients to make sure obsolete subtopics # do not get written out to the cookie. if (exists $param{'areas'}) { my @areas = param('areas'); # NOTE: from param(), not %param if (!grep {/Science/} @areas) { delete $param{'sciences'} } if (!grep {/Arts/} @areas) { delete $param{'arts'} } if (!grep {/Philosophy/} @areas) { delete $param{'philosophy'} } } my $cookie = cookie(-name => 'data', -value => \%param, -expires => "$exp"); print header(-cookie => $cookie); getUserLogin() if (!param ); checkAccess() if (param("Log in")); receiveUpload() if param("Upload File"); adminMenu() if param("Admin Page"); checkTopicSelection() if ($page == 1 && $go eq 'Next'); pickTopics() if ($page == 2 && $go eq 'Previous'); checkSubtopicSelection() if ($page == 2 && $go eq 'Next'); pickSubtopics() if ($page == 3 && $go eq 'Previous'); checkInvoiceContents() if ($page == 3 && $go eq 'Next'); selectBooks() if ($page == 4 && $go eq 'Previous'); composeEmailAndSend() if ($page == 4 && $go eq 'Send'); showOrder() if ($page == 4 && $go eq 'Retry'); print end_html; # ======================================================= sub getUserLogin { my @rows; push @rows, Tr(td([ b("User name:"), textfield(-name => "user", -rows => 1)])); push @rows, Tr(td({-align => 'RIGHT'}, [ b("Password:"), password_field(-name => "password", -rows => 1) ])); push @rows, Tr(td({-colspan => 2, -align => 'CENTER' }, submit("Log in"))); print start_html(-title => 'Welcome to Lab #5, CIS-089B'), p, start_form, table({-rules => 'none', -cellpadding => 5 }, @rows), end_form; } sub checkAccess { my $authlevel = checkPassword(); if (1 == $authlevel) { pickTopics() } elsif (7 == $authlevel) { adminMenu() } else { my $location = "Fugawi Station"; my $message = "Error in Login - cannot continue."; appendJournal([\$location, \$message]); print start_html(-title => "$location"), br, br, b("$message"), br, end_html; exit; } } sub pickTopics { my $now = time(); print start_html(-title => "Fields : $now"), p, start_form, b("Select the fields that interest you"), p("(pick at least one)"), br, checkbox_group(-name => 'areas', -linebreak => 1, -value => [ 'Science', 'Arts', 'Philosophy' ] ); makeGOButtons(PAGE_1, ['areas']); print end_form; } sub checkTopicSelection { my @list = param('areas'); # filter out possible null fields in list before joining # to ensure a valid test for subtopic selection my $topics = join ", ", map { "\'$_\'" } grep { $_ }(@list); if (length $topics) { pickSubtopics() } else { errorPage() } } sub pickSubtopics { my @areasOfInterest = param('areas'); my $now = time(); print start_html(-title => "Subjects : $now"), br, b("Select one or more subjects"), br, start_form; if (grep {/Science/} @areasOfInterest) { print br, checkbox_group ( -name => 'sciences', -linebreak => 1, -value => ['Chemistry', 'Physics', 'Math', 'Computer Science'] ); } if (grep {/Arts/} @areasOfInterest) { print br, checkbox_group ( -name => 'arts', -linebreak => 1, -value => ['Music', 'Painting', 'Sculpture', 'Literature'] ); } if (grep {/Philosophy/} @areasOfInterest) { print br, checkbox_group ( -name => 'philosophy', -linebreak => 1, -value => ['Existentialism', 'Postmodernism', 'Theology'] ); } makeGOButtons(PAGE_2, [qw (sciences arts philosophy)]); print end_form; } sub checkSubtopicSelection { if (length ${subtopicsINclause()} ) { selectBooks() } else { errorPage() } } sub errorPage { my $page = param('page'); my $go = param('go'); my ($location, $message); if ($page == 1) { $location = "Topic?"; $message = "No topic selected."; } elsif ($page == 2) { $location = "Subtopic?"; $message = "No subtopic selected"; } elsif ($page == 3) { $location = "Book selections?"; $message = "No books chosen."; } else { $location = "How did we end up HERE?"; $message = "Error while page = $page, go = $go"; } $page++; my $now = time(); print start_html(-title => "$location : $now"), br, br, b("Cannot proceed to next page: $message"), br, start_form, hidden(-name => 'page', -value => $page, -override => 1), br, br, "To go back to the previous page, press ", submit(-name => 'go', -value => 'Previous', -override => 1); makeHiddenExcept([]); print br, br, "To abandon this session, press ", submit(-name => 'go', -value => 'Done'), br; print end_form; } sub csvStringFromList { my $rList = shift; # transform the list elements into a CSV record return \(join ",", map {"\"$_\""} @$rList); } sub getCsvDbHeader # not portable - CSV specific { my ($dbPath, $header); $dbPath = cwd(); open (IN, "<", "$dbPath/books") or die "Cannot open prototype\n"; $header = <IN>; close IN; chomp($header); return \$header; } sub subtopicsINclause { my @sciences = param('sciences'); my @arts = param('arts'); my @philosophy = param('philosophy'); # filter out null fields in lists before joining # to ensure a valid IN clause my $subtopics = join ", ", map { "\'$_\'" } grep { $_ }(@arts, @philosophy, @sciences); return \$subtopics; } sub selectBooks { my ($db, $dbPath, $qtopic, $subtopics); $dbPath = cwd(); $db = DBI->connect("DBI:CSV:f_dir=$dbPath") || die "Could not connect data base directory\n" ; $subtopics = ${subtopicsINclause()}; my $now = time(); print start_html(-title => "Book Finder : $now"); my $booklist = "SELECT * from books\n"; $booklist .= " WHERE subtopic IN ($subtopics)"; appendJournal([\"Books selection query = \"$booklist\""]); $qtopic = $db->prepare($booklist); $qtopic->execute() || die "Cannot get book list\n"; my $books = $qtopic->fetchall_arrayref; $db->disconnect() || die "Cannot disconnect\n"; if (@$books) { my ($bookref, $LineItems, @sortedBookLoL); @sortedBookLoL = sort byTopicAndSubtopicAndAuthor @$books; foreach $bookref (@sortedBookLoL) { push @$LineItems, join " | ", @$bookref; } print b("Select from among these titles:"), br; print start_form, scrolling_list( -name => 'invoice', -values => $LineItems, -multiple => 1, -size => 12 ); makeGOButtons(PAGE_3,['invoice']); print end_form; } else { print br, b("Sorry -- We have no books that fit your preferences."), start_form, br, submit(-name => 'go', -value => 'Done'), end_form; } } sub byTopicAndSubtopicAndAuthor # overkill R us (if CSV) { my ($topicA, $subtopicA, $authorA) = @$a[0..2]; my ($topicB, $subtopicB, $authorB) = @$b[0..2]; $topicA cmp $topicB or $subtopicA cmp $subtopicB or $authorA cmp $authorB; } sub checkInvoiceContents { my @list = param('invoice'); # filter out possible null fields in list before joining # to ensure a valid test for invoice contents my $books = join ", ", map { "\'$_\'" } grep { $_ }(@list); if (length $books) { showOrder() } else { errorPage() } } sub showOrder { my ($books) = [param('invoice')]; my ($line, @lines); my $totalCheck = 0; push @lines, th([map {ucfirst(lc($_))} split ",",${getCsvDbHeader()}]); foreach $line (@$books) { my @row = split / \| /, $line; $totalCheck += (@row)[-1]; push @lines, Tr(td(\@row)); } my $now = time(); print start_html(-title => "Check, please ... : $now"); print br, b("These are the items you selected:"), p; print table({-rules => 'all', -cellpadding => 5 }, @lines), br, p(b("Your total cost will be \$", sprintf("%.2f.", $totalCheck))), start_form; makeGOButtons(PAGE_4,[]); getEmailInfo(); print end_form; } sub getEmailInfo { my @rows; push @rows, Tr(td({-colspan => 2}, hr)); push @rows, Tr(td({-colspan => 2}, strong("So that your order can be confirmed,"))); push @rows, Tr(td("Please enter your email address :", textfield(-name => "addy1", -rows => 1))); push @rows, Tr(td({-align => 'RIGHT'}, "Enter your email address again :", textfield(-name => "addy2", -rows => 1))); push @rows, Tr(td({-colspan => 2}, hr)); push @rows, Tr(td({-align => 'RIGHT'}, "To confirm your order, press ", submit(-name => 'go', -value => 'Send', -override => 1))); push @rows, Tr(td({-align => 'RIGHT'}, "Or, leave without ordering, press ", submit(-name => 'go', -value => 'Done', -override => 1))); print table({-rules => 'none', -cellpadding => 5 }, @rows); } sub composeEmailAndSend { my $addy1 = param('addy1'); my $addy2 = param('addy2'); if (goodAddy($addy1) && ($addy1 eq $addy2)) { # compose email based on invoice my $etext = "CONFIRMATION OF ORDER \nDate: (sometime) Order Number: (bogus) \nWe have recorded your order for these items:\n\n"; my @books = param('invoice'); my $total = 0; my ($title, $author, $price); foreach my $line (@books) { my @row = split / \| /, $line; ($title, $author, $price) = (@row)[-3, -4, -1]; $total += $price; $etext .= sprintf("%-30s %-15s %7.2f\n", $title, $author, $price); } $etext .= "-" x 54; $etext .= sprintf("\n%45s %8.2f\n", "for a total cost of" , $total); $etext .= "\nPlease phone 1-800-000-0000 to make final payment and shipping arrangements.\n Clutterdesk Library"; appendJournal([\$etext]); # if $debug, don't REALLY send email. For stand-alone PC host. if (!$debug) { sendmail(To => $addy1, From => 'tpf60927@voyager.deanza.edu', Subject => 'Your order from Clutterdesk.com', Message => $etext) or die "$Mail::Sendmail::error"; } print start_html('Order Sent'), br, br, b("Thank you for ordering from Clutterdesk Library!"), start_form, br, submit(-name => 'go', -value => 'Done', -override => 1), end_form; } else { my $now = time(); print start_html('Dead Letter Office : $now'), start_form, br, br; makeHiddenExcept([]); print hidden(-name => 'addy1', -value => '', -override => 1), hidden(-name => 'addy2', -value => '', -override => 1), hidden(-name => 'page', -value => '4', -override => 1), "Could not validate email address ", submit(-name => 'go', -value => 'Retry', -override => 1), end_form; } } sub goodAddy { my $addy = shift; my $atPos = index($addy, '@'); my $nextDotPos = index($addy,'.', $atPos); my $addyLength = length($addy); if (($addyLength) && ($atPos > 1) && ($nextDotPos > (1 + $atPos)) ) { return 1 } # else return 0; } sub checkPassword { my $password = param("password"); my $user = param("user"); my $level = 0; open (INFILE, "<", "205643") || die "Cannot open user authorization file."; foreach (<INFILE>) { /^($user):($password):(\d)\s*$/; last if ($level = $3); } close (INFILE); return $level; } sub NBSpaces { my ($count) = shift; my $spaces; while ($count) { $spaces .= " " ; $count-- } return $spaces; } sub dumpHashToJournal { my $h = shift; my $dumper; if (ref($h) eq 'HASH') { foreach (sort keys %$h) { $dumper .= sprintf("\n$_ = %s ", $h->{$_}); } $dumper .= "\n"; } appendJournal([\$dumper]); } sub appendJournal { my $rNoteList = shift; # ref to list of string references my $path = cwd(); $path .= "/$journalName"; my ($rNote); my $now = time(); open (JOURNAL, ">>", $path) or die "Can't append to journal file.\n"; print JOURNAL ("$now"); while (@$rNoteList) { $rNote = shift @$rNoteList; print JOURNAL "\t$$rNote"; } print JOURNAL "\n"; close JOURNAL; } sub adminMenu { my $userHelp = "To add or delete records from the server's database, enter the name of the update file in the box below."; my @help; push @help, Tr(td({-colspan => 2 }, tt($userHelp))); push @help, Tr(td({-colspan => 2 }, hr)); push @help, Tr(td({-colspan => 2 }, filefield( {-name => 'upload', -size => 80, -maxlength => 100 }) )); push @help, Tr(td({ -align => 'CENTER'}, [submit("Upload File"), submit("Log out")])); print start_html(-title => "Inventory Maintenance"), br, start_multipart_form(), table({ -rules => 'none', -cellpadding => 5, -width => 600 }, @help), end_form; } sub receiveUpload { my (@lines, $delACK, $delNAK, $addACK, $addNAK, $report); my $file = param("upload"); my $basename = basename($file); # remove any .ext from the filename -- Opera appends a '.' -- WTF? $basename =~ s/^(.+)(\..*)$/$1/; if (open F, ">", "./$basename") { binmode $file; binmode F; while (<$file>) { print F } close F; # verify that the update file is a table that the # database engine recognises. (CSV for now) my ($matched, $rhAllUploadFields) = @{fieldInfoCSV( \$basename, [qw(author title publisher)] )}; my @uploadKeys = keys %$rhAllUploadFields; push @lines, Tr(th("Results of Upload")); push @lines, Tr(td(hr)); # if less than 3 matched, at least one of (author title publisher) # is missing if (3 == $matched) { if (3 == @uploadKeys) # the update file is a list of deletes { ($delACK, $delNAK) = doDeletes(\$basename, \"books"); } else # probably a list of ADDs { ($addACK, $addNAK) = doAdds(\$basename, \"books"); } } else { $report = "The file \"$basename\" contains no upload data."; appendJournal([\$report]); push @lines, Tr(td({ -align => 'CENTER'}, b($report))); } unlink "./$basename" or die "Could not delete upload temp file $basename"; foreach (@$delNAK) { push @lines, Tr(td($_)) } foreach (@$delACK) { push @lines, Tr(td({ -align => 'CENTER'}, $_)) } foreach (@$addNAK) { push @lines, Tr(td($_)) } foreach (@$addACK) { push @lines, Tr(td({ -align => 'CENTER'}, $_)) } push @lines, Tr(td(hr)); push @lines, Tr(td({ -align => 'CENTER'}, submit("Admin Page"))); print start_html(-title => "Upload Results"), br, start_form(), table({ -rules => 'none', -width => 600 }, @lines), end_form; } else # can't open the file! { $report = "Cannot use file \"$basename\" - upload cancelled"; appendJournal([\$report]); push @lines, Tr(td(hr)); push @lines, Tr(th($report)); push @lines, Tr(td(hr)); push @lines, Tr(td({ -align => 'CENTER'}, submit("Admin Page"))); print start_html(-title => "Oops!"), br, start_form(), table({ -rules => 'none', -width => 440 }, @lines), end_form; } } sub doAdds { my ($rdeltas, $rtarget) = @_; my $dbPath = cwd(); my $dbh1 = DBI->connect("DBI:CSV:f_dir=$dbPath") || die "Could not connect dbh1 in doAdds\n" ; my $dbh2= DBI->connect("DBI:CSV:f_dir=$dbPath") || die "Could not connect dbh2 in doAdds\n" ; my $qAddSpecs = $dbh1->prepare("SELECT * from $$rdeltas"); $qAddSpecs->execute(); my (@nakItems, @ackItems, $report, $ackCount); $ackCount = 0; while (my $rh = $qAddSpecs->fetchrow_hashref) { my $description = "[$rh->{'author'}"; $description .= ", $rh->{'title'}"; $description .= ", $rh->{'publisher'}]"; # check for duplicate entry in target. If found, skip. my $q = "SELECT * from $$rtarget WHERE "; $q .= "author = ".$dbh2->quote($rh->{'author'}); $q .= " AND title = ".$dbh2->quote($rh->{'title'}); $q .= " AND publisher = ".$dbh2->quote($rh->{'publisher'}); my $dup = $dbh2->prepare($q); $dup->execute(); my $wrong = $dup->fetchrow_arrayref; if ($wrong) { $report = "Duplicate record for $description skipped."; appendJournal([\$report]); push @nakItems, $report; next; } # prepare insert my @fields = keys %$rh; my @values = map { ($dbh2->quote($rh->{$_})) } @fields; $q = "INSERT INTO $$rtarget (".join (",",@fields).")"; $q .= " VALUES (".join (",",@values).")"; my $qInsert = $dbh2->prepare($q); my $result = $qInsert->execute(); if (1 == $result) { $report = "Record added for $description."; appendJournal([\$report]); $ackCount++; } else { $report = "Error in attempt to insert $description."; appendJournal([\$report]); push @nakItems, $report; } } $dbh2->disconnect; $dbh1->disconnect; $report = "$ackCount records were added."; push @ackItems, ($report); return \(@ackItems, @nakItems); } sub doDeletes { my ($rdeltas, $rtarget) = @_; my $dbPath = cwd(); my $dbh1 = DBI->connect("DBI:CSV:f_dir=$dbPath") || die "Could not connect dbh1 in doDeletes\n" ; my $dbh2= DBI->connect("DBI:CSV:f_dir=$dbPath") || die "Could not connect dbh2 in doDeletes\n" ; my $qDelSpecs = $dbh1->prepare("SELECT author, title, publisher from $$rdeltas"); $qDelSpecs->execute(); my $rDelSpecs = $qDelSpecs->fetchall_arrayref; my (@nakItems, @ackItems, $report, $ackCount); $ackCount = 0; foreach (@$rDelSpecs) { my ($author, $title, $publisher) = @$_; my $description = "[$author"; $description .= ", $title"; $description .= ", $publisher]"; my $q = "DELETE from books "; $q .= "WHERE author = ".$dbh2->quote($author); $q .= " AND title = ".$dbh2->quote($title); $q .= " AND publisher = ".$dbh2->quote($publisher); my $qDelRow = $dbh2->prepare($q); my $result = $qDelRow->execute(); if (0E0 == $result) { $report = "No record deleted for $description"; appendJournal([\$report]); push @nakItems, $report; } elsif (1 == $result) { $report = "Record deleted for $description."; appendJournal([\$report]); $ackCount++; } } $dbh2->disconnect; $dbh1->disconnect; $report = "$ackCount records were deleted."; push @ackItems, ($report); return \(@ackItems, @nakItems); } =fieldInfoCSV inputs: reference to scalar $basename of file to be tested. reference to list of field names to be matched assumptions: $basename exists in the same subdirectory as the script. output: returns reference to a list [$matchesToInputList, $rhTargetFields]. example: my ($matched, $rhAllTargetFields) = @{fieldInfoCSV( \"refbooks", [qw(author title publisher)] )}; =cut sub fieldInfoCSV { my ($rBasename, $rFieldList) = @_; my $dbPath = cwd(); my $db = DBI->connect("DBI:CSV:f_dir=$dbPath") || die "Could not connect data base directory\n" ; my $query = "SELECT * from $$rBasename"; my $doit = $db->prepare($query); if (! $doit->execute()) { $db->disconnect() || die "Cannot disconnect\n"; return [0, {} ]; } my $fields = $doit->fetchrow_hashref; $db->disconnect() || die "Cannot disconnect\n"; my $fieldMatches = 0; foreach (@$rFieldList) { $fieldMatches++ if exists $$fields{$_}; } return [$fieldMatches, $fields]; } sub makeGOButtons { my ($pagenum, $doNotHide) = @_; my $prevPrompt = "To go back to the previous page, press "; my $nextPrompt = "When you have made your selections, press "; if ($pagenum < PAGE_4) { print br, br, $nextPrompt, submit(-name => 'go', -value => 'Next', -override => 1), br; } if ($pagenum > PAGE_1) { print br, $prevPrompt, submit(-name => 'go', -value => 'Previous', -override => 1); } print hidden(-name => 'page', -value => $pagenum, -override => 1); makeHiddenExcept($doNotHide); } sub makeHiddenExcept { my $noHide = shift; # ref to anonymous list my (%omit); foreach (@$noHide) { $omit{$_} = 1 } foreach (grep { !exists $omit{$_}} @allParams) { print hidden{-name => $_ }; } } =history 04 June 2004: Copied from Lab-4.cgi 05 June: Synchronization of cookie %param hash and param() hash debugged. (Lines 22..44) This lets most of the existing (Lab-4.cgi) page generation code work as-is. After page 1 has been submitted ('Next'), restarting the session jumps immediately to the page last displayed in the prior session. 06 June: The residual subtopics problem is back, this time from persistence of subtopic residue in cookie. To correct this, added filtering of %param keys before writing cookie. (Lines 62..68) 07 June: In the errorPage() sub, when the user chooses to abandon the session, the cookie must self-destruct (expire -1d). In the selectBooks() sub, if no books in the database match the user's choices, the cookie also must self-destruct. Reason (for both above): While the cookie remains active in the user's browser, the user cannot get a new login. (Always bounces to 'last page seen'.) 1235: 'Restore to last page seen' doesn't work correctly when I use Opera to connect to voyager/apache. Opera to localhost/xitami works correctly. Connected to voyager, Opera always shows the login page first then, after user logs in, scrolls through the pages up to the page last seen in the previous session. (This looks like a problem specific to Apache, or to the way Apache is configured on voyager.) 2124: Removed dead code from makeGOButtons(). Changed 'mystery constants' 1..4 to 'use constants' PAGE1..PAGE4. Did not incorporate sub makeHiddenExcept() into makeGOButtons() because makeHiddenExcept() is called from two other subroutines. 20 June: Changed lame foreach+regex in csvStringFromList to join..map Changed name of sub makeHidden to makeHiddenExcept so the calling syntax would make better sense. Changed name of sub goButtons to makeGOButtons. =cut