|
Show Contents Previous Page Next Page
Appendix F - HTML::Embperl--Embedding Perl Code in HTML
An Extended Example
Hopefully, you now have a general overview of the main features of Embperl. For more information--for example, to learn more about the many options you have in configuring Embperl or for instructions on how to configure Apache or mod_perl--please take a look at the Embperl web site at http://perl.apache.org/embperl/. Embperl is actively supported and development is going on all of the time. The web site will always contain information on the newest features.
Example F-2 shows one last example of how you can use Embperl. It's a rewritten version of the hangman game of Chapter 5, Maintaining State. Instead of creating its own session management, as in Chapter 5, this hangman game uses the Embperl built-in capabilities
Example F-2. Hangman with Embperl
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> <HTML><HEAD><TITLE>Hangman with Embperl</TITLE></HEAD> <BODY BGCOLOR="white" ONLOAD="if (document.gf) document.gf.guess.focus()">
<H1>Hangman with Embperl</H1>
<P> This is an Embperl version of the Hangman game from
<A HREF=http://www.modperl.com/>Writing Apache Modules with Perl and C<A>
Chapter 5 </P>
<HR>
[!
use constant WORDS => 'hangman-words'; use constant ICONS => '../images'; use constant TRIES => 6; use constant TOP_COUNT => 15; # how many top scores to show ########### subroutines ############## # This subroutines are just the same as in the hangman6.pl from chapter 5
# This is called to process the user's guess
sub process_guess {
my ($guess,$state) = @_;
# lose immediately if user has no more guesses left
return ('','lost') unless $state->{LEFT} > 0;
# lose immediately if user aborted
if ($fdat{'abort'}) {
$state->{TOTAL} += $state->{LEFT};
$state->{LEFT} = 0;
return (qq{Chicken! The word was "$state->{WORD}."},'lost') ;
}
# break the word and guess into individual letters
my %guessed = map { $_ => 1 } split('',$state->{GUESSED});
my %letters = map { $_ => 1 } split('',$state->{WORD});
# return immediately if user has already guessed the word
return ('','won') unless grep(!$guessed{$_},keys %letters);
# do nothing more if no guess
return ('','continue') unless $guess;
return (qq{You\'ve lost. The word was "$state->{WORD}".},'lost')
if $state->{LEFT} <= 0;
# This section processes individual letter guesses
$guess = lc($guess);
return ("Not a valid letter or word!",'error') unless $guess=~/^[a-z]+$/;
return ("You already guessed that letter!",'error') if $guessed{$guess};
# This section is called when the user guesses the whole word
if (length($guess) > 1 && $guess ne $state->{WORD}) {
$state->{TOTAL} += $state->{LEFT};
$state->{LEFT} = 0;
return (qq{You lose. The word was "$state->{WORD}."},'lost')
}
# update the list of guesses
foreach (split('',$guess)) { $guessed{$_}++; }
$state->{GUESSED} = join('',sort keys %guessed);
# correct guess -- word completely filled in
unless (grep (!$guessed{$_},keys %letters)) {
$state->{WON}++;
return (qq{You got it! The word was "$state->{WORD}."},'won');
}
# incorrect guess
if (!$letters{$guess}) {
$state->{TOTAL}++;
$state->{LEFT}--;
# user out of turns
return (qq{The jig is up. The word was "$state->{WORD}".},'lost')
if $state->{LEFT} <= 0;
# user still has some turns
return ('Wrong guess!','continue');
}
# correct guess but word still incomplete
return (qq{Good guess!},'continue');
}
############################
# pick a word, any word
sub pick_random_word {
open (LIST, WORDS)
|| die "Couldn't open ${\WORDS}: $!\n";
my $word;
rand($.) < 1 && ($word = $_) while <LIST>;
chomp($word);
close LIST ;
$word;
}
# End of subroutines ###############################################################
!]
[-
# change username if requested
$udat{username} = $fdat{change_name} if ($fdat{change_name}) ;
# store the score of the last game if we start a new one
# NOTE: %mdat stores data for that page across multiple requests
$mdat{$udat{username}} = {GAMENO => $udat{GAMENO},
WON => $udat{WON},
AVERAGE => $udat{AVERAGE},
SCORE => $udat{SCORE}}
if ($udat{username} && $fdat{newgame}) ;
# initialize user data if necessary
# NOTE: %udat stores data for that user across multiple requests
%udat = {} if ($fdat{clear}) ;
if ($fdat{restart} || !$udat{WORD})
{
$udat{WORD} = pick_random_word() ;
$udat{LEFT} = TRIES;
$udat{TOTAL} += 0;
$udat{GUESSED} = '';
$udat{GAMENO} += 1;
$udat{WON} += 0;
}
# check what the user has guessed
($message,$status) = process_guess($fdat{'guess'} || '',\%udat)
unless $fdat{'show_scores'};
# setup score values
$current_average = int($udat{TOTAL}/$udat{GAMENO} * 100) / 100 ;
$udat{AVERAGE} = $udat{GAMENO}>1 ?
int(($udat{TOTAL}-(TRIES-$udat{LEFT}))/($udat{GAMENO}-1) * 100)/100 : 0;
$udat{SCORE} = $udat{AVERAGE} > 0 ?
int(100*$udat{WON}/($udat{GAMENO}*$udat{AVERAGE})) : 0;
# convert strings to hashs
%guessed = map { $_ => 1 } split ('', $udat{GUESSED});
%letters = map { $_ => 1 } split ('', $udat->{WORD});
$word = join (' ', map {$guessed{$_} ? $_ : '_'} split ('', $udat{WORD})) ;
# delete the the values posted as guess, so the input field will be empty
delete $fdat{guess} ;
-]
[#### show the current status ####]
[$ if $udat{username} $]
<H2>Player: [+ $udat{username} +]</H2>
[$ endif $]
<TABLE>
<TR WIDTH="90%">
<TD><B>Word #:</B> [+ $udat{GAMENO} +] </TD>
<TD><B>Won:</B> [+ $udat{WON} +] </TD>
<TD><B>Guessed:</B> [+ $udat{GUESSED} +] </TD>
</TR>
<TR>
<TD><B>Current average:</B> [+ $current_average +] </TD>
<TD><B>Overall average:</B> [+ $udat{AVERAGE} +] </TD>
<TD><B>Score:</B> [+ $udat{SCORE} +] </TD>
</TR>
</TABLE>
[$if !$fdat{show_scores} $]
[#### show the images, the word and the message form process_guess ####]
<IMG ALIGN="LEFT" SRC="[+ ICONS +]/h[+ TRIES-$udat{LEFT} +].gif"
ALT="[ [+ $udat{LEFT} +] tries left]">
<H2>Word: [+ $word +] </H2>
<H2><FONT COLOR="red">[+ $message +]</FONT></H2>
<FORM METHOD="POST" ENCTYPE="application/x-www-form-urlencoded"> [$if $status =~ /won|lost/ $]
[#### game over, if won let the user enter his name and
ask if he like to play again ####]
[$if $status eq 'won' $]
<P>Enter your name for posterity:
<INPUT TYPE="text" NAME="change_name" VALUE="[+ $udat{username} +]">
[$ endif $]
<P>Do you want to play again?
<INPUT TYPE="submit" NAME="restart" VALUE="Another game">
<INPUT TYPE="submit" NAME="show_scores" VALUE="Show High Scores">
<INPUT TYPE="checkbox" NAME="clear" VALUE="on">Clear my score</P>
<INPUT TYPE="hidden" NAME="newgame" VALUE="on">
[$else$]
[#### let the user enter a guess or give up ####]
Your guess: <INPUT TYPE="text" NAME="guess" VALUE="">
<INPUT TYPE="submit" NAME=".submit" VALUE="Guess">
<BR CLEAR="ALL">
<INPUT TYPE="submit" NAME="show_scores" VALUE="Show High Scores">
<INPUT TYPE="submit" NAME="abort" VALUE="Give Up" STYLE="color: red">
[$endif$]
</FORM><BR CLEAR="ALL">
[$ else $]
[#### show a sorted table of the best players ####]
[-
$maxrow = TOP_COUNT ;
@name = sort { $mdat{$a}{SCORE} <=> $mdat{$b}{SCORE} }
grep (/^[^_]/, keys (%mdat))
-]
<TABLE BORDER="undef" WIDTH="75%">
<CAPTION><B>Top 15 Winners</B></CAPTION>
<TR>
<TH>Name</TH>
<TH>Games</TH>
<TH>Won</TH>
<TH>Average</TH>
<TH>Score</TH>
</TR>
<TR>
<TD>[+ $n = $name[$row] +]</TD>
<TD>[+ $mdat{$n}{GAMENO} +]</TD>
<TD>[+ $mdat{$n}{WON} +]</TD>
<TD>[+ $mdat{$n}{AVERAGE} +]</TD>
<TD>[+ $mdat{$n}{SCORE} +]</TD>
</TR>
</TABLE>
[$ if $#name == -1 $]
<H2>No scores available, nobody won the game so far</H2>
[$endif$]
<FORM METHOD="POST" ENCTYPE="application/x-www-form-urlencoded">
<INPUT TYPE="submit" NAME="play" VALUE="Play">
</FORM>
[$endif$]
<p><hr>
<small>Hangman for <A HREF="http://perl.apache.org/embperl/">HTML::Embperl</A>
(c) 1998 G.Richter, Lincoln Stein, graphics courtesy Andy Wardley</small>
</body> </html>
Here is a sample srm.conf entry to go with it:
PerlSetEnv SESSION_FILE_DIRECTORY /tmp/sessions PerlSetEnv EMBPERL_SESSION_CLASS File PerlModule Apache::Session::File PerlModule HTML::Embperl <Location /hangman> SetHandler perl-script PerlHandler HTML::Embperl Options ExecCGI </Location>Show Contents Previous Page Next Page
Copyright © 1999 by O'Reilly & Associates, Inc.
