home | O'Reilly's CD bookshelfs | FreeBSD | Linux | Cisco | Cisco Exam    

Writing Apache Modules with Perl and C
By:   Lincoln Stein and Doug MacEachern
Published:   O'Reilly & Associates, Inc.  - March 1999

Copyright © 1999 by O'Reilly & Associates, Inc.


 


   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 &lt;LIST&gt;;
    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.










??????????????@Mail.ru