The Labs.Com Issue_11_mod_perl

TPJ: Issue_11_mod_perl

This is a collection of programs published by The Perl Journal. You can download all source-code also from TPJ: Programs.

1. TopTenTrans.pm
2. rate.html
3. rateit
4. rating-image
5. rating-image.html
6. real-index
7. real-index.html
8. tables.sql
9. ttadmin
10. More Samples on mod_perl

Download TopTenTrans.pm

package TopTenTrans;

## This gets us values like OK, NOT_FOUND, and DECLINED

use Apache::Constants qw(:common);

sub handler {

my $r = shift;                # Get Apache request object

my $uri = $r->uri();                # Save the URI and filename (\

if any)

my $file = $r->filename;

## Read configuration variables (set with PerlSetVar)

my $prefix = $r->dir_config( 'TopTenPrefix' ) || 'topten';

my $ttdb = $r->dir_config( 'TopTenDB' ) || 'tpj';

my $dbuser = $r->dir_config( 'TopTenDBUser' ) || 'ap_auth';

my $dbpass = $r->dir_config( 'TopTenDBPass' ) || '';

my $ttroot = $r->dir_config( 'TopTenRoot' ) || $r->document_ro\

ot;

my $ttindex = $r->dir_config( 'TopTenIndex' ) || $r->document_\

root;

## Decline to handle request if it's not for our heirarchy

return DECLINED

unless( $uri =~ m{^/$prefix} );

if( $uri =~ m{^/$prefix/(\d+)} ) {

my $docnum = $1;

## Return 404 if the number is not in 1..10 inclusive

return NOT_FOUND if $docnum == 0 || $docnum > 10;

## Open connection to the database

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass );

## Prepare select statement to get information from db

my $sth = $dbh->prepare( qq{

select path, hits, rating from documents

order by rating desc, hits desc;

} );

## Return a server error if the statement doesn't run

return SERVER_ERROR unless $sth->execute;

## Fetch the $docnum'th item from the table

my $row = undef;

for( my $i = 0; $i < $docnum ; $i++ ) {

$row = $sth->fetchrow_arrayref;

}

## Done with database handles

$sth->finish;

$dbh->disconnect;

## Return page not found if we ran out of items

return NOT_FOUND if !defined( $row );

## Else, set filename relative $ttroot

$r->filename( $ttroot . '/' . $row->[0] );

## Set the handler to add the footer via Apache::Sandwich

if( $r->is_main ) {

$r->handler( "perl-script" );

$r->push_handlers( "PerlHandler", "Apache::Sandwich" );

## Push handler to log hit to database if this is the main reque\

st

$r->push_handlers( "PerlLogHandler",

sub { log_hit( shift, $file ) }

)

}

return OK;                        # Return that we translated OK

} elsif( $uri =~ m{^/$prefix/(index\.html)?$} ) {

## Point to index document and return OK

$r->filename( $ttindex );

return OK;

} else {

my $file = ($uri =~ m{^/$prefix/(.*)})[0];

$r->filename( $ttroot . '/' . $file );

## Go ahead and return 404 if the file doesn't exist

return NOT_FOUND unless -e $r->filename;

## Set the handler to add the footer via Apache::Sandwich

if( $r->is_main ) {

$r->handler( "perl-script" );

$r->push_handlers( "PerlHandler", "Apache::Sandwich" );

## Push handler to log hit to database if this is the main reque\

st

$r->push_handlers( "PerlLogHandler",

sub { log_hit( shift, $file ) }

)

}

return OK;

}

return DECLINED;                # Should never reach here

}

## log_hit -- This is run as a PerlLogHandler

## after the request has completed and the

## document has been sent to the user.

sub log_hit {

my $r = shift;

my $file = shift;

## Read configuration variables (set with PerlSetVar)

my $ttdb = $r->dir_config( 'TopTenDB' ) || 'tpj';

my $dbuser = $r->dir_config( 'TopTenDBUser' ) || 'ap_auth';

my $dbpass = $r->dir_config( 'TopTenDBPass' ) || '';

## Open a connection to the database

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass );

## Prepare select statement to update hit count

my $sth = $dbh->prepare( qq{

update documents set hits = hits+1 where path = '$file';

} );

## Return a server error if the statement doesn't run

unless( $sth->execute ) {

warn "DBI Error: " . $sth->errstr;

return SERVER_ERROR;

}

## Done with database handles

$sth->finish;

$dbh->disconnect;

return OK;

}

1;                                # Return true for require

Issue_11_mod_perl 2. rate.html

rate.html

Issue_11_mod_perl 3. rateit

Download rateit

#!/usr/bin/perl

use strict;

use CGI;

use DBI ();

## Create a CGI query object

my $q = CGI->new();

my $base_url = $q->url( -full => 1 );

## Map rating numbers to strings

my %ratings = (

1=> qq{I\'m dumber for having read it},

2=> qq{Useless},

3=> qq{Not very helpful},

4=> qq{Somewhat helpful},

5=> qq{Just what I needed},

);

## Define these variables here so they're visible to all parts of our

## script (including subroutines)

my( $prefix, $ttdb, $dbuser, $dbpass, $ttroot );

##

## Get Database parameters from %ENV

##

$prefix = $ENV{'TopTenPrefix'} || 'topten';

$ttdb = $ENV{'TopTenDB'} || 'tpj';

$dbuser = $ENV{'TopTenDBUser'} || 'ap_auth';

$dbpass = $ENV{'TopTenDBPass'} || '';

$ttroot = $ENV{'TopTenRoot'} || '/tmp';

## Print HTTP headers, and start of HTML page

print $q->header( 'text/html' ),

$q->start_html( -title => 'TopTen Ratings',

-bgcolor => '#ffffff'

),

"<h1>TopTen Ratings</h1>\n";

## Get rating parameter

my $rating = $q->param( 'rating' );

## See if they actually selected anything first

if( defined $rating ) {

## Figure out which document they're rating.

my $referer = $q->referer;

$referer =~ s/.*\/$ENV{TopTenPrefix}\///;

## Convert to path of file if a positional number was used.

$referer = &position_to_path( $referer )

if $referer =~ /\d+/;

## Open a connection to the database and retrieve the current rating

## and number of ratings

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass )

or die "DBI Error: $DBI::errstr";

my $sth = $dbh->prepare( qq{

select rating, raters from documents where path = ?;

})

or die "DBI Error: " . $dbh->errstr;

die "DBI Error: " . $dbh->errstr

unless ($sth->execute( $referer ));

my( $oldrating, $raters ) = $sth->fetchrow;

## Done with the statment handle

$sth->finish;

## Compute the new average rating

my $newrating = (($raters * $oldrating) + $rating) / ($raters+1);

## Update the values in the database

$sth = $dbh->prepare( qq{

update documents set rating =  ?, raters = raters + 1

where path = ?;

})

or die "DBI Error: " . $dbh->errstr;

die "DBI Error: " . $dbh->errstr

unless ($sth->execute( $newrating, $referer ));

## Done with database

$sth->finish;

$dbh->disconnect;

##

## Give the user feedback and let them see the new rating

##

print "Document: " . $q->referer . "<br>\n",

"Your Rating: ", $ratings{$rating}, "($rating)<br>\\

n",

"New Average Rating: ",

sprintf( "%-0.2f", $newrating ), "<p>\n",

qq{

Thank you for your feedback.<p>

<a href="/$prefix/">Back to the Top Ten Documents</a>&\

lt;p>

<a href="@{[$q->referer]}">Back to the document</a>\

<p>

};

} else {

## Didn't give us a rating, so gripe at them.

print qq{

<p>Please use your browsers 'Back' button and select a rating be\

fore hitting

the 'Submit Rating' button.</p>

};

}

print $q->end_html, "\n";

##

## Subroutines

##

sub position_to_path {

my $position = shift;

## Open connection to the database

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass );

## Prepare select statement to get information from db

my $sth = $dbh->prepare( qq{

select path, hits, rating from documents

order by rating desc, hits desc;

} );

## Return a server error if the statement doesn't run

die "DBI Error: " . $sth->errstr

unless $sth->execute;

## Fetch the $docnum'th item from the table

my $row = undef;

for( my $i = 0; $i < $position ; $i++ ) {

$row = $sth->fetchrow_arrayref;

}

## Done with database handles

$sth->finish;

$dbh->disconnect;

return $row->[0];                # Return path

}

Issue_11_mod_perl 4. rating-image

Download rating-image

#!/usr/bin/perl

use CGI;

$query = new CGI;

print <<'EOF';

<HR>

<FONT FACE="Arial,Helvetica" SIZE=+2><B>Please rate this p\

age</B></FONT><P>

EOF

print $query->start_form;

print $query->radio_group('w', ["I'm dumber for having read it", "U\

seless",

"Not very helpful", "Somewhat helpful", "Just what I needed"])\

, "<P>";

print $query->submit("Submit Rating"), "<P>";

print $query->end_form;

Issue_11_mod_perl 5. rating-image.html

rating-image.html

Issue_11_mod_perl 6. real-index

Download real-index

#!/usr/bin/perl

use CGI;

$query = new CGI;

print <<'EOF';

<BODY BGCOLOR="#ffffff">

<FONT FACE="Arial,Helvetica" SIZE=+2><B>Top Ten Tracked Do\

cuments</B></FONT><P>

<table border="0" width="75%">

<tr>

<th>#</th><th>Title</th><th>Hits<\

/th><th>Rating</th>

</tr>

<tr bgcolor="#ffaaff"><td>1</td><td width="75%"\

>Unclogging pipes with <CODE>$|</CODE></td><td\

>22</td><td>4.80</td></tr>

<tr bgcolor="white"><td>2</td><td width="50%"&g\

t;Sandblasting your Lemur</td><td>837</td><td>\

3.21</td></tr>

<tr bgcolor="#ffaaff"><td>3</td><td width="50%"\

>HTTP POST with LWP</td><td>12</td><td>3.21\

</td></tr>

<tr bgcolor="white"><td>4</td><td width="50%"&g\

t;Creating Applications with mod_perl and Apache</td><td>2\

</td><td>1.50</td></tr>

<tr bgcolor="#ffaaff"><td>5</td><td width="50%"\

>Teach Yourself Quantum Physics in 21 Attofortnights</td><\

td>51047</td><td>1.21</td></tr>

</table>

<A HREF="foo">All Tracked Documents</A>

EOF

Issue_11_mod_perl 7. real-index.html

real-index.html

Issue_11_mod_perl 8. tables.sql

tables.sql

Issue_11_mod_perl 9. ttadmin

Download ttadmin

#!/usr/bin/perl

use strict;

use CGI;

use DBI ();

## Create a CGI query object

my $q = CGI->new();

## Store off the base URL to access this script

my $base_url = $q->url( -full => 1 );

## Define these variables here so they're visible to all parts of our

## script (including subroutines)

my( $prefix, $ttdb, $dbuser, $dbpass, $ttroot );

##

## Get Database parameters from %ENV

##

$prefix = $ENV{'TopTenPrefix'} || 'topten';

$ttdb = $ENV{'TopTenDB'} || 'tpj';

$dbuser = $ENV{'TopTenDBUser'} || 'ap_auth';

$dbpass = $ENV{'TopTenDBPass'} || '';

$ttroot = $ENV{'TopTenRoot'} || '/tmp';

## Print HTTP headers, and start of HTML page

print $q->header( 'text/html' ),

$q->start_html( -title => 'TopTen Administration',

-bgcolor => '#ffffff'

),

"<h1>TopTen Administration</h1>\n";

## If script was't passed parameters, simply print the initial options

unless( $q->param() ) {

## Start a form to add a file.  Prints the necessary <FORM> HT\

ML.

print $q->start_multipart_form( -method => 'POST',

-action => $base_url );

## Print some explanatory text and a file upload button

print qq{\n<h2>Add a file to the repository</h2>

File to upload:  \n},

$q->filefield( -name => 'addfile',

-size => 50,

),

"<br>Title:  ",

$q->textfield( -name => 'title' ),

"\n";

print $q->submit( -name => 'action',

-value => 'Add',

);

## Print HTML to end the form

print $q->endform, "\n";

## You can roll the an entire form (or even the entire output of you\

r

## script, for that matter) up into one print statement

print $q->startform( -method => 'POST',

-action => $base_url,

-encoding => &CGI::MULTIPART ),

qq{\n<h2>Zero a file\'s hit counter</h2>\nPick fil\

e . . .  },

$q->submit( -name => 'action',

-value => 'Zero',

),

$q->endform, "\n";

print $q->startform( -method => 'POST',

-action => $base_url,

-enctype => &CGI::MULTIPART ),

qq{\n<h2>Delete a file</h2>\nPick file . . . \

},

$q->submit( -name => 'action',

-value => 'Delete',

),

$q->endform, "\n";

} else {

##

## Decide what to do based on $q->param( 'action' )

##

my $action = $q->param( 'action' );

if ($action eq 'Add') {

## Make them give us a file and a title

unless (defined $q->param('title') && defined $q->param('add\

file')) {

print "You must specify a title and upload a file.\n";

} else {

## Strip out the filename from the full path

my $pathname = $q->param( 'addfile' );

$pathname =~ s/.*[\/\\:]([^\/\\:]+)$/$1/;

## Gripe if a file with that pathname already exists

if (-f "$ttroot/$pathname") {

print qq{

<h2>Error!</h2>

File '$pathname' already exists.  Use the 'Delete' action to remove

the current file if you really want to overwrite.<p>

}, &back_to_main();

exit 0;

}

## Copy the file to the document root.

open( OUTPUT, ">$ttroot/$pathname" )

or die "Can't create outputfile '$ttroot/$pathname': $!";

## Strict won't let us use the filename CGI.pm setup as a

## handle by default.  Turn off that part of strict for this

## one block of code.

{

no strict qw(refs);

my $addfile = $q->param('addfile');

while (<$addfile>) {

print OUTPUT;

}

}

print OUTPUT "<!-- Uploaded at ", scalar localtime, " -->\\

n";

close( OUTPUT );

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass )

or die "DBI Error: $DBI::errstr";

my $title = $q->param('title');

## select statement to insert new record into database

my $sth = $dbh->prepare( qq{

insert into documents values ( ?, ? , 0, 3, 1 );

})

or die "DBI Error: " . $dbh->errstr . "\n";

unless ( $sth->execute( "$pathname", $title ) ) {

die "DBI Error: " . $dbh->errstr . "\n";

}

$sth->finish;

$dbh->disconnect;

print qq{

<h2>File Added</h2>

The file '$title' ($pathname) was added successfully.<p>

<ul>

<li><a href="/$prefix/$pathname">$title</a>

<li><a href="/$prefix/">TopTen Area</a>

<li>}, &back_to_main(), qq{

</ul>

};

}

} elsif ($action eq 'Zero') {

unless ($q->param( 'victimfile' )) {

print $q->startform( -method => 'POST',

-action => $base_url,

-encoding => &CGI::MULTIPART );

## Use a hidden form field to pass the action back to ourselves

print $q->hidden( -name => 'action',

-value => 'Zero',

);

print "<h2>Pick a file to zero hits for . . .</h2>\n\

";

## Print table listing all files

&list_all_files( $q );

print $q->endform;

print &back_to_main();

} else {

my $file = $q->param( 'victimfile' );

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass )

or die "DBI Error: $DBI::errstr";

## select statement to grab information

my $sth = $dbh->prepare( qq{

update documents set hits = 0 where path = ?;

})

or die "DBI Error: " . $dbh->errstr . "\n";

unless ( $sth->execute( $file ) ) {

die "DBI Error: " . $sth->errstr . "\n";

}

$sth->finish;

$dbh->disconnect;

print qq{

<h2>Hits for $file zeroed.</h2>

<ul>

<li>}, &back_to_main(), qq{

<li><a href="/$prefix/">TopTen Area</a>

</ul>

};

}

} elsif ($action eq 'Delete') {

unless ($q->param( 'victimfile' )) {

print $q->startform( -method => 'POST',

-action => $base_url,

-encoding => &CGI::MULTIPART );

## Use a hidden form field to pass the action back to ourselves

print $q->hidden( -name => 'action',

-value => 'Delete',

);

print "<h2>Pick file to delete . . .</h2>\n";

## Print table listing all files

&list_all_files( $q );

print $q->endform;

print &back_to_main();

} else {

my $file = $q->param( 'victimfile' );

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass )

or die "DBI Error: $DBI::errstr";

## select statement to grab information

my $sth = $dbh->prepare( qq{

delete from documents where path = ?;

})

or die "DBI Error: " . $dbh->errstr . "\n";

unless ( $sth->execute( $file ) ) {

die "DBI Error: " . $sth->errstr . "\n";

}

unlink "$ttroot/$file"

or die "Can't unlink '$ttroot/$file': $!";

$sth->finish;

$dbh->disconnect;

print qq{

<h2>'$file' Deleted.</h2>

<ul>

<li>}, &back_to_main(), qq{

<li><a href="/$prefix/">TopTen Area</a>

</ul>

};

}

} else {

print qq{<h2>Unknown Action</h2>\n}, &back_to_main();

}

}

print $q->end_html;

##

## Subroutines

##

sub list_all_files {

my $q = shift;

my $dbh = DBI->connect( "dbi:Pg:dbname=$ttdb",

$dbuser, $dbpass )

or die "DBI Error: $DBI::errstr\n";

## select statement to grab information

my $sth = $dbh->prepare( qq{

select title, path, hits, rating from documents

order by hits desc, rating desc;

})

or die "DBI Error: " . $dbh->errstr . "\n";

unless ( $sth->execute ) {

die "DBI Error: " . $sth->errstr . "\n";

}

## qq{} and here docs are handy ways to print large chunks of

## HTML text

print qq{

<table>

<tr>

<th>Title</th><th>Path</th><th>Hits&\

lt;/th><th> </th>

</tr>

};

##

## $filelist will look like:

## $filelist = [

##               [ title, path, hits, rating ],

##                   [ title, path, hits, rating ],

##                   ...

##             ]

##

my $filelist = $sth->fetchall_arrayref;

foreach (@{$filelist}) {

print "  <tr>\n<td>$_->[0]</td>", # Title

"<td>$_->[1]</td>",        # Path

"<td>$_->[2]</td>",        # Hits

"<td>",

$q->submit( -name => 'victimfile',

-value => $_->[1],

),

"</td>\n</tr>\n";

}

print "\n</table>\n";

$sth->finish;

$dbh->disconnect;

return;

}

sub back_to_main {

return qq{<a href="$base_url">Back to TopTen Administration<\

;/a>\n};

}

Issue_11_mod_perl 10. More Samples on mod_perl

• Issue_09_mod_perl
• Issue_11_mod_perl