#!/Perl/bin/Perl5.6.1 # Perl CGI program for the email pen-pal example # This receives the reguest to either add a person to the database or search the database # The search involves some rather complicated tests on the data and are done # in the program rather than via an elaborate SQL query - so it is simply # select * from table; then test each record as needed. # Obviously the data source must be redefined to match your database. # If your database requires lots of environment variables (as does Oracle) # then you may need to set these in the initialize function use strict; use DBI; my ($stuff, @splitstuff, $name, $value); my ($action, $enteredemail, $enteredtype, $enterdesire, @enteredinterest); # Fix this, here it references an ODBC datasource mapped to a little Microsoft Access # database (which wouldn't really be capable of handling multiple conccurrent # accessses etc) my $data_source = "DBI:ODBC:epalfinder"; my $dbh; my $searchHandle; my $insertHandle; my %interesttable; #The interest check list, matching the list in the form my @interestlist = ( "Abseiling", "Aerobics", "AmateurDramatics", "Archery", "ArmyReserve", "Astronomy", "Athletics", "AFL", "Ballet", "Baseball", "Basketball", "Biking", "BirdWatching", "BodyBuilding", "Buddhism", "BungeeJumping", "Camping", "Cars", "Cats", "Caving", "ChoralSociety", "Christianity", "ClassicalMusic", "Clubs", "Cookery", "Computing", "CountryMusic", "Craftwork", "Cricket", "Democrat", "Dieting", "DiscoDance", "Diving", "Dogs", "Drinking", "ECommerce", "Environment", "Fashion", "Fishing", "FolkMusic", "Gambling", "Gliding", "Golf", "GourmetFood", "Guitar", "GridIron", "Gymnastics", "HangGliding", "Hiking", "HinduReligion", "Hockey", "Horses", "IRC", "Islam", "Jazz", "Judaism", "Kayaking", "Labour", "Liberal", "LocalHistory", "LocalPolitics", "Marxism", "ModelMaking", "MotorBikes", "MotorRacing", "MovieMaking", "Movies", "MP3Music", "Naturism", "Novels", "Olympics", "Opera", "Orienteering", "Painting", "Parenting", "Philosophy", "Photography", "Piano", "Poetry", "PopMusic", "Psychology", "RockClimbing", "RolePlayingGames", "Rollerblades", "Running", "RugbyLeague", "Scouts&Guides", "Skiing", "Snowboarding", "Soccer", "Socialism", "SteamTrains", "StockMarket", "Sunbathing", "Surfing", "Swimming", "Tennis", "Theatre", "TVCartoons", "TVCommedies", "TVSoaps", "WebDesign", "WineTasting", "Yoga", "Zen" ); # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # initialize - create hash table for lookup of interests # connect to database # prepare sql statements # sub initialize { my ($id, $interest); $id = 0; foreach $interest (@interestlist) { $interesttable{$interest} = $id; $id++; } # # Your database needs environment variables set? # You may need to have explicit set up calls here # e.g. # $ENV{"ORACLE_HOME"} = "/packages/oracle8/u01/app/oracle/product/8.1.6"; # $ENV{"ORACLE_SID"} = "csci8"; # $ENV{"TWO_TASK"} = "csci8"; $dbh = DBI->connect($data_source) || die "Couldn't connect to db\n"; $searchHandle = $dbh->prepare("SELECT * FROM epal");; $insertHandle = $dbh->prepare("INSERT INTO epal VALUES ( ?, ?, ?, ?, ?, ?, ?, ? ) "); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # The following routines generate response pages with error messages # as needed. # Each is essentially a little HTML page defined as a "here" string sub badInterests { print <Please complete interest list Sorry but we are unable to handle your request. You must pick exactly 5 entries from the list of possible interests. BAD } sub badSubmission { print <Bad data in submission Sorry but we are unable to handle your request. Some of the data are missing or corrupt. BAD } sub badEmail { print <Please provide email You must supply an email address if you wish to have a record registered in the e-pal database. BAD } sub databaseFailure { print <Sorry we couldn't handle your request The attempt to entere your record in the database failed. Possibly there is already a record with your email address. DBF exit; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Now get subroutines that check the submitted data # Are there 5 interests, all from the predefined list sub checkinterests { my @list = @_; my (@nlist,$temp,$length); $length = scalar @list; if($length != 5) { badInterests; exit; } $temp = 1; my $item; foreach $item (@list) { unless (exists $interesttable{$item}) { badInterests; exit; } push(@nlist, $interesttable{$item}); } return @nlist; } # Are requestor type and preference both specified from known possible values sub checktype { my $type= $_[0]; my @allowed; @allowed = qw( MALE FEMALE EPERSON); if(grep { /$type/ } @allowed) { return 1; } return 0; } sub checkwant { my $type = $_[0]; my @allowed; @allowed = qw( MALE FEMALE EPERSON ANY); if(grep { /$type/ } @allowed) { return 1; } return 0; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # main program print "Content-type: text/html\n\n"; initialize; # It is a get request # Mainly so that you can see the data in the request line # It is OK to have a get request for the search - someone might want to # "bookmark" it and run the search again. # It is not that good an idea overall as someone could bookmark an add # request and try repeatedly adding themselves (getting errors each time) $stuff = $ENV{"QUERY_STRING"}; # pull apart the query and fill in parameters # here doing everything programmatically - no helper functions from CGI module @splitstuff= split /&/ , $stuff; foreach (@splitstuff) { ($name, $value) = split /=/; $value =~ s/\+/ /g; while($value =~ /%([0-9A-Fa-f]{2})/) { my ($old, $chrcode, $chrval, $symbol); $old = "%$1"; $chrcode = "0x$1"; $chrval = hex $chrcode; $symbol = chr $chrval; $value =~ s/$old/$symbol/; } if($name eq "act") { $action = $value; } elsif($name eq "self") { $enteredtype = $value; } elsif($name eq "other") { $enterdesire = $value; } elsif($name eq "email") { $enteredemail = $value; } elsif($name eq "interests") { push(@enteredinterest, $value); } else { #some hacker out there. ignore whatever trash they put in } } # data validation - may generte error response page and terminate script unless((defined $action) && (defined $enterdesire) && (defined $enteredtype) && ((scalar @enteredinterest) > 0)) { badSubmission; exit; } if($enteredemail eq "") { undef $enteredemail; } if(($action eq "add") && !(defined $enteredemail)) { badEmail; exit; } unless (checkwant($enterdesire) && checktype($enteredtype)) { badSubmission; exit; } # OK data appear valid so continue # convert list of interests (words) into list of interest numbers my @numericlist; @numericlist = checkinterests(@enteredinterest); # And handle either an add or a search request, response pages are # mostly as here strings if($action eq "add") { $insertHandle->execute( $enteredemail, $enteredtype, $enterdesire, @numericlist) || databaseFailure; print <Thanks for registering with e-pal

You are registered

We hope you find lots of new friends via e-pal. JOIN } elsif($action eq "search") { print "E-pals for you"; my ($score, @row); my ($theiremail, $theirtype, $theirdesire, @theirinterest); $searchHandle->execute || die "Select request failed because $DBI::errstr"; $score = 0; while(@row = $searchHandle->fetchrow_array) { ( $theiremail, $theirtype, $theirdesire, @theirinterest) = @row; next unless (($enterdesire eq "ANY") || ($enterdesire eq $theirtype)); next unless (($theirdesire eq "ANY") || ($theirdesire eq $enteredtype)); my @common = (); my $interest; foreach $interest (@numericlist) { push(@common, $interest) if (grep {$interest == $_ } @theirinterest); } next if ((scalar @common) == 0); $score++; print "Contact mail $theiremail:\tCommon interests: "; foreach (@common) { print "\t$interestlist[$_]"; } print "
\n"; } unless ($score > 0) { print "Sorry, we currently don't have any contacts for you\n"; } } else { badSubmission; } exit;