The Labs.Com Issue_09_mod_perl

TPJ: Issue_09_mod_perl

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

1. listing1
2. listing2
3. listing3
4. More Samples on mod_perl

Download listing1

package PageSession;

use vars qw($NEXTID $MAXSESSIONS %SESSIONS);

$MAX_SESSIONS = 100;

$NEXTID = 0 if $NEXTID eq '';

# Find a new ID to use by the simple expedient of cycling

# through a numeric list.  In a real application, the ID

# should be unique, and maintained in a most-frequently-used cache.

sub new {

my($package) = @_;

$NEXTID=0 if $NEXTID > $MAX_SESSIONS;

my $self = bless {

name    =>  '',

article =>  '',

page    =>  0,

id      =>  $NEXTID++

},$package;

return $self;

}

sub fetch {

my ($package,$id) = @_;

return undef if $id eq '';

return $SESSIONS{$id};

}

sub save {

my $self = shift;

$SESSIONS{$self->{id}} = $self;

}

sub id    { $_[0]->{id}; }

sub name    { $_[0]->{name} = $_[1]    if defined($_[1]); $_[0]->\

;{name};    }

sub article { $_[0]->{article} = $_[1] if defined($_[1]); $_[0]->\

;{article}; }

sub page    {

$_[0]->{page} = $_[1] if defined($_[1]);

$_[0]->{page} = 0 if $_[0]->{page} < 0;

$_[0]->{page};

}

1;

Issue_09_mod_perl 2. listing2

Download listing2

#!/usr/local/bin/perl

# File: stately.cgi

use strict vars;

use CGI qw(:html2 :html3 start_form end_form center

textfield submit param popup_menu);

use Apache::Constants qw(:response_codes :common);

use PageSession;

my %ARTICLES = (

'emr.txt' => 'The Electronic Medical Record',

'microbot.txt' => 'Beware the Microbots',

'sbox.txt' => 'Box and Wrapped',

'servlets.txt' => 'Back to the Future'

);

my $ARTICLE_ROOT =  "/articles";

my $LINES_PER_PAGE = 20;

my $MAX_BUTTONS = 10;  # how many page buttons to line up

my $r = Apache->request;

my $id = get_session_id($r);

my $session = PageSession->fetch($id);

if (!$session) {

$session = PageSession->new();

# remove any path info already there

my $uri = $r->path_info ? substr($r->uri,0,-length($r->pa\

th_info)) : $r->uri;

my $new_uri = "$uri/".$session->id;

$r->header_out(Location=>$new_uri);

$r->send_http_header;

$session->save;

return REDIRECT;

}

34

# If we get here, we have a session object in hand and

# can proceed.

$r->content_type('text/html');

$r->send_http_header;

$r->print(

start_html(-bgcolor=>'white',-Title=>'Document Browser'),

h1('Document Browser'),

start_form()

);

# Set the user's name to whatever is specified in the

# CGI parameter.

$session->name(param('name'));

# If there's no name in the session, then prompt the

# user to enter it.

unless ($session->name) {

$r->print( "Your name [optional]: ",

textfield(-name=>'name',-size=>40),br );

} else {

$r->print( h2("User: ",$session->name) );

}

# Here's where we do something based on the action

my $action = param('action');

CASE: {

$session->page($session->page+1),last CASE     if $action e\

q 'Next Page >>';

$session->page($session->page-1),last CASE     if $action e\

q '<< Previous Page';

$session->page($action-1),last CASE            if $action =~ /\

^\d+$/;

do_select($session,param('article'))           if $action eq 'Sel\

ect Article' || param('name');

}

# Popup menu to select article to view.

$r->print(

'Select an article to browse: ',

popup_menu(-name=>'article',-Values=>\%ARTICLES,

-default=>$session->article),

submit(-name=>'action',-value=>'Select Article'),p(),

);

# Here's where we fetch the article and divide it into pages

my @pages = fetch_article($r,$session);

if (@pages) {

# truncate page counter if it is off for some reason.

$session->page($#pages) if $session->page > $#pages;

# List of page buttons.  Note transform from zero-based to one-bas\

ed indexing

my @buttons = map { $_ == $session->page+1 ?

strong($_) :

submit(-name=>'action',-value=>"$_") } (1..@pages);

# Trim the buttons a bit to the left and right of the current page\

.  Want no more

# than MAX_BUTTONS shown at any time.

splice(@buttons,0,$session->page-$MAX_BUTTONS/2,strong('...'))

if @buttons > $MAX_BUTTONS and $session->page > $MAX_\

BUTTONS/2;

splice(@buttons,$MAX_BUTTONS+1,@buttons-6,strong('...'))

if @buttons > $MAX_BUTTONS;

unshift(@buttons,submit(-name=>'action',-value=>'<< Pr\

evious Page'))

if $session->page > 0;

push   (@buttons,submit(-name=>'action',-value=>'Next Page &\

gt;>'))

if $session->page < $#pages;

$r->print(hr,

table({-width=>'100%'},TR(td(\@buttons))),

table({-width=>'100%'},

TR(

td({-bgcolor=>'yellow'},

$session->page == 0 ? center(strong("-start-"))\

: '',

pre($pages[$session->page]),

$session->page == $#pages ? center(strong("-end\

-")) : ''

))

),

table({-width=>'100%'},TR(td(\@buttons)))

);

}

$r->print(

end_form(),

hr(),end_html() );

$session->save;

sub get_session_id {

my $r = shift;

my ($session) = $r->path_info()=~m!^/(\d+)!;

return $session;

}

sub do_select {

my ($session,$article) = @_;

$session->page(0);

$session->article($article);

}

sub fetch_article {

my ($r,$session) = @_;

return () unless $ARTICLES{$session->article};

my $path = $r->lookup_uri("$ARTICLE_ROOT/".$session->article\

)->filename();

return () unless $path;

my (@lines,@pages);

open (FILE,$path) || return ();

@lines = <FILE>;  # slurp

close FILE;

push(@pages,join('',splice(@lines,0,$LINES_PER_PAGE))) while @line\

s;

return @pages;

}

Issue_09_mod_perl 3. listing3

Download listing3

package PageSession;

use IPC::Shareable;

use vars qw($NEXTID $MAXSESSIONS %SESSIONS);

$MAX_SESSIONS = 100;

tie $NEXTID,  IPC::Shareable,'S000',{create=>1,mode=>0600};

tie %SESSIONS,IPC::Shareable,'S001',{create=>1,mode=>0600};

$NEXTID = 0 if $NEXTID eq '';

# Find a new ID to use by the simple expedient of cycling

# through a numeric list.  In a real application, the ID

# should be unique, and maintained in a most-frequently-used cache.

sub new {

my($package) = @_;

tied($NEXTID)->shlock;

$NEXTID=0 if $NEXTID > $MAX_SESSIONS;

my $self = bless {

name    =>  '',

article =>  '',

page    =>  0,

id      =>  $NEXTID++

},$package;

tied($NEXTID)->shunlock;

return $self;

}

sub fetch {

my ($package,$id) = @_;

return undef if $id eq '';

# Storeable will automagically make this a PageSession object

return $SESSIONS{$id};

}

sub save {

my $self = shift;

# store the object

tied(%SESSIONS)->shlock;

$SESSIONS{$self->{id}} = $self;

tied(%SESSIONS)->shunlock;

}

sub id    { $_[0]->{id}; }

sub name    { $_[0]->{name} = $_[1]    if defined($_[1]); $_[0]->\

;{name};    }

sub article { $_[0]->{article} = $_[1] if defined($_[1]); $_[0]->\

;{article}; }

sub page    {

$_[0]->{page} = $_[1] if defined($_[1]);

$_[0]->{page} = 0 if $_[0]->{page} < 0;

$_[0]->{page};

}

1;

Issue_09_mod_perl 4. More Samples on mod_perl

• Issue_09_mod_perl
• Issue_11_mod_perl