Apache2-PageKit
view release on metacpan or search on metacpan
lib/Apache2/PageKit.pm view on Meta::CPAN
sub param {
my $self = shift;
my $t = $self->{params_table}
||= $self->{_r}->param || APR::Table::make($self->{_r}->pool, 20);
if ( @_ == 0 ) {
my @keys = ();
$t->do( sub { push @keys, $_[0]; 1 } );
return wantarray ? (@keys) : scalar(@keys);
}
# only one argument
elsif ( @_ == 1 ) {
if (wantarray) {
my @list = $t->get(@_);
return @list;
}
else {
return $t->get(@_);
}
}
# insert something
else {
if ( ref $t eq 'APR::Request::Param::Table' ) {
my $n = APR::Table::make($self->{_r}->pool, 20);
$t->do(sub { $n->set(@_[0..1]) } );
$t = $self->{params_table} = $n;
}
while ( @_ > 0 ) {
my ( $k, $v ) = splice @_, 0, 2;
if ( ref $v eq 'ARRAY' ) {
$t->unset($k);
$t->merge( $k => $v->[$_] ) for ( 0 .. $#$v );
}
elsif ( !defined($v) ) {
$t->unset($k);
}
else {
$t->set( $k => $v );
}
}
}
}
1;
package Apache2::PageKit;
# $Id: PageKit.pm,v 1.236 2004/05/06 09:54:35 borisz Exp $
# require perl 5.8 for numerous utf8 issues ( and Encode )
require 5.008;
use strict;
# CPAN Modules required for pagekit
use mod_perl2 1.9921;
use Apache2::URI ();
use Apache2::Cookie ();
use Apache2::Request ();
use Apache::SessionX ();
use Apache2::Util ();
use Compress::Zlib ();
use File::Find ();
use HTML::FillInForm ();
use HTML::Parser ();
use HTML::Entities ();
use HTML::Template ();
use Encode ();
use XML::LibXML ();
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::ServerUtil ();
use Apache2::RequestUtil ();
use Apache2::Util ();
use APR::Date ();
use APR::Request::Param ();
$| = 1;
# PageKit modules
use Apache2::PageKit::Param ();
use Apache2::PageKit::View ();
use Apache2::PageKit::Content ();
use Apache2::PageKit::Model ();
use Apache2::PageKit::Config ();
use Apache2::PageKit::Edit ();
use Apache2::Const qw(OK DONE REDIRECT DECLINED HTTP_NOT_MODIFIED);
use APR::Const -compile => 'SUCCESS';
use vars qw($VERSION);
$VERSION = '2.15';
%Apache2::PageKit::DefaultMediaMap = (
pdf => 'application/pdf',
wml => 'text/vnd.wap.wml',
xml => 'application/xml');
# in httpd.conf file
sub startup {
my ($class, $pkit_root, $server) = @_;
my $s = Apache2::ServerUtil->server;
if ( defined $mod_perl::VERSION && $mod_perl::VERSION >= 1.26 ) {
$pkit_root ||= $s->dir_config('PKIT_ROOT') || die "PKIT_ROOT is not defined! Put PerlSetVar PKIT_ROOT /your/root/path in your httpd.conf";
$server ||= $s->dir_config('PKIT_SERVER') || die "PKIT_SERVER is not defined! Put PerlSetVar PKIT_SERVER servername in your httpd.conf";
} else {
$pkit_root || die 'must specify $pkit_root variable in startup. Usage: Apache2::PageKit->startup($pkit_root, $server)';
$server || die 'must specify $server variable in startup. Usage: Apache2::PageKit->startup($pkit_root, $server)';
}
# get user and group as specified by User and Group directives
# my $uid = $s->uid;
# my $gid = $s->gid;
# include user defined classes (Model) in perl search path
unshift(@INC,"$pkit_root/Model");
lib/Apache2/PageKit.pm view on Meta::CPAN
$apr->param('pkit_check_cookie','');
# goto home page when user logouts (if from page that requires login)
my $require_login = $config->get_page_attr($pk->{page_id},'require_login');
if (defined($require_login) && $require_login =~ m!^(?:yes|recent)$!) {
# $pk->{page_id} = $config->get_global_attr('default_page');
$pk->{page_id} = $model->pkit_get_default_page;
}
$model->pkit_gettext_message('You have successfully logged out.');
}
if($apr->param('pkit_login')){
if ($pk->login){
# if login is sucessful, redirect to (re)set cookie
return REDIRECT;
} else {
# else return to login form
# my $referer = $apr->header_in('Referer');
# $referer =~ s(http://[^/]*/([^?]*).*?)($1);
$pk->{page_id} = $apr->param('pkit_login_page') || $config->get_global_attr('login_page');
$pk->{browser_cache} = 'no';
}
}
if($auth_user){
my $pkit_check_cookie = $apr->param('pkit_check_cookie');
if(defined($pkit_check_cookie) && $pkit_check_cookie eq 'on'){
$model->pkit_gettext_message('You have successfully logged in.');
}
$pk->update_session($auth_session_id);
my $require_login = $config->get_page_attr($pk->{page_id},'require_login');
if(defined($require_login) && $require_login eq 'recent'){
if(exists($session->{pkit_inactivity_timeout})){
# user is logged in, but has had inactivity period
# display verify password form
$pk->{page_id} = $config->get_global_attr('verify_page') || $config->get_global_attr('login_page');
$pk->{browser_cache} = 'no';
# pkit_done parameter is used to return user to page that they originally requested
# after login is finished
$output_param_object->param("pkit_done",$uri_with_query) unless $apr->param("pkit_done");
# $apr->user(undef);
}
}
}
else {
# check if cookies should be set
my $pkit_check_cookie = $apr->param('pkit_check_cookie');
if(defined($pkit_check_cookie) && $pkit_check_cookie eq 'on'){
# cookies should be set but aren't.
if($config->get_global_attr('cookies_not_set_page')){
# display "cookies are not set" error page.
$pk->{page_id} = $config->get_global_attr('cookies_not_set_page');
$pk->{browser_cache} = 'no';
} else {
# display login page with error message
$pk->{page_id} = $config->get_global_attr('login_page');
$model->pkit_gettext_message('Cookies must be enabled in your browser.', is_error => 1);
}
}
my $require_login = $config->get_page_attr($pk->{page_id},'require_login');
if(defined($require_login) && $require_login =~ /^(yes|recent)$/){
# this page requires that the user has a valid cookie
$pk->{page_id} = $config->get_global_attr('login_page');
# do NOT cache this page other wise we end up on the loginpage instead of the page we want
$pk->{browser_cache} = 'no';
$output_param_object->param("pkit_done",$uri_with_query) unless $apr->param("pkit_done");
$model->pkit_gettext_message('This page requires a login.');
}
}
$model->pkit_common_code if $model->can('pkit_common_code');
if ( $static_file{name} ) {
if ( $pk->{page_id} eq $static_file{page_id} ) {
# page_id is the same as we tested already (this may save some stat calls)
return $pk->_send_static_file($static_file{name});
} elsif ( my $filename = $pk->static_page_exists($pk->{page_id}) ) {
return $pk->_send_static_file($filename);
}
}
# run the page code!
$pk->page_code;
# check for the statuscode that can be set with $model->pkit_status_code
return $pk->{status_code} if ( defined $pk->{status_code} );
# add pkit_message from previous page, if that pagekit did a pkit_redirect
if(my @pkit_messages = $apr->param('pkit_messages')){
for my $message (@pkit_messages){
$model->pkit_message($message);
}
}
if(my @pkit_error_messages = $apr->param('pkit_error_messages')){
for my $message (@pkit_error_messages){
$model->pkit_message($message, is_error => 1);
}
}
# deal with different views
if(my $pkit_view = $apr->param('pkit_view')){
$output_param_object->param('pkit_view:' . $pkit_view => 1);
}
return OK;
}
sub _send_static_file {
my ( $pk, $filename ) = @_;
my $apr = $pk->{apr};
my $file_mtime = (stat($filename))[9];
my $ims = $apr->headers_in->{'If-Modified-Since'};
if ( $ims ) {
my $t = APR::Date::parse_http($ims);
if ( $t && $file_mtime <= $t ) {
return HTTP_NOT_MODIFIED;
lib/Apache2/PageKit.pm view on Meta::CPAN
die "Must set pkit_auth_credential in your model base class";
}
my $ses_key = $model->pkit_auth_credential;
$ses_key || return 0;
# save page session (if any)
delete $pk->{page_session};
# allow user to view pages with require_login eq 'recent'
my $use_recent_login_timeout = $pk->{config}->get_global_attr('use_recent_login_timeout') || 'yes';
my $session_id;
if(defined $pk->{session}){
$session_id = tied(%{$pk->{session}})->getid;
if ( $session_id ) {
if ( $use_recent_login_timeout ne 'no' && !$pk->{is_new_session} ) {
delete $pk->{session}->{pkit_inactivity_timeout};
$pk->{session}->{pkit_last_activity} = time;
}
# save session
delete $pk->{session};
}
}
# this call can't fail it is already verified by pkit_auth_credential
my ($auth_user, $auth_session_id) = $model->pkit_auth_session_key($ses_key);
# watch if session was the session we search for, if not get the auth_session
if (!$session_id || $auth_session_id ne $session_id) {
my $ss = $model->pkit_session_setup;
my %auth_session;
my $session_class = $config->get_global_attr('session_class') || 'Apache::SessionX';
# get new session assoc with login
tie %auth_session, $session_class, $auth_session_id,
{
Lock => $ss->{session_lock_class},
Store => $ss->{session_store_class},
Generate => 'MD5',
Serialize => $ss->{session_serialize_class} || 'Storable',
create_unknown => 1,
lazy => 0,
%{$ss->{session_args}}
};
if ( $use_recent_login_timeout ne 'no' ) {
delete $auth_session{pkit_inactivity_timeout};
$auth_session{pkit_last_activity} = time;
}
# save session
untie %auth_session;
}
my $pkit_id = 'pkit_id' . ( $config->get_server_attr('cookie_postfix') || '' );
my $cookie_domain_str = $config->get_server_attr('cookie_domain');
my @cookie_domains = defined($cookie_domain_str) ? split(' ',$cookie_domain_str) : (undef);
for my $cookie_domain (@cookie_domains){
my $cookie = Apache2::Cookie->new($apr->env,
-name => $pkit_id,
-value => $ses_key,
-path => "/");
$cookie->domain($cookie_domain) if $cookie_domain;
if ($remember){
$cookie->expires("+10y");
}
$apr->err_headers_out->add( 'Set-Cookie' => $cookie->as_string );
}
# remove appending ? or & and any combination of them
$done =~ s/[\?&]+$//;
# this is used to check if cookie is set
if($done =~ /\?/){
$done .= "&pkit_check_cookie=on";
} else {
$done .= "?pkit_check_cookie=on";
}
$done =~ s/ /+/g;
if(my @pkit_messages = $apr->param('pkit_messages')){
for my $message (@pkit_messages){
$done .= "&pkit_messages=" . Apache2::Util::escape_path($message, $apr->pool);
}
}
if(my @pkit_error_messages = $apr->param('pkit_error_messages')){
for my $message (@pkit_error_messages){
$done .= "&pkit_error_messages=" . Apache2::Util::escape_path($message, $apr->pool);
}
}
$apr->headers_out->set(Location => "$done");
return 1;
}
sub authenticate {
my ($pk) = @_;
my $apr = $pk->{apr};
my $model = $pk->{model};
my %cookies = Apache2::Cookie->fetch($apr->env);
my $cookie_pkit_id = 'pkit_id' . ( $pk->{config}->get_server_attr('cookie_postfix') || '' );
return unless $cookies{$cookie_pkit_id};
my %ticket = $cookies{$cookie_pkit_id}->value;
# in case pkit_auth_session_key is not defined, but cookie
# is somehow already set
return unless $model->can('pkit_auth_session_key');
my ($auth_user, $auth_session_id) = $model->pkit_auth_session_key(\%ticket);
return unless $auth_user;
$auth_session_id = $auth_user unless defined($auth_session_id);
$apr->user($auth_user);
# $apr->param(pkit_user => $auth_user);
# $pk->{output_param_object}->param(pkit_user => $auth_user);
return ($auth_user, $auth_session_id);
}
sub logout {
my ($pk) = @_;
my $apr = $pk->{apr};
my $config = $pk->{config};
my %cookies = Apache2::Cookie->fetch($apr->env);
my $cookie_postfix = $config->get_server_attr('cookie_postfix') || '';
my $pkit_id = 'pkit_id' . $cookie_postfix;
my $pkit_session_id = 'pkit_session_id' . $cookie_postfix;
my $logout_kills_session = $config->get_global_attr('logout_kills_session') || 'yes';
my @cookies_to_kill = ( $cookies{$pkit_id} );
push @cookies_to_kill, $cookies{$pkit_session_id} if $logout_kills_session eq 'yes';
my $cookie_domain = $config->get_server_attr('cookie_domain');
my @cookie_domains = defined($cookie_domain) ? split(' ',$cookie_domain) : (undef);
for my $tcookie (@cookies_to_kill){
next unless $tcookie;
for my $cookie_domain (@cookie_domains){
$tcookie->value("");
$tcookie->path("/");
$tcookie->domain($cookie_domain) if $cookie_domain;
$tcookie->expires('-5y');
$apr->err_headers_out->add( 'Set-Cookie' => $tcookie->as_string );
}
}
}
# get session_id from cookie
sub setup_session {
my ($pk, $auth_session_id) = @_;
my $model = $pk->{model};
my $ss = $model->pkit_session_setup;
unless($ss->{session_store_class} && $ss->{session_lock_class}){
warn "failed to set up session - session_store_class and session_lock_class must be defined";
$pk->{session} = {};
return;
}
my $apr = $pk->{apr};
my $config = $pk->{config};
my %cookies = Apache2::Cookie->fetch($apr->env);
my $pkit_session_id = 'pkit_session_id' . ( $config->get_server_attr('cookie_postfix') || '' );
my $session_id;
if(defined $cookies{$pkit_session_id}){
my $scookie = $cookies{$pkit_session_id};
$session_id = $scookie->value;
}
$session_id ||= $auth_session_id;
# this sets a flag so we know if we should send a cookie later...
$pk->{is_new_session} = 1 unless $session_id;
# set up session handler class
my %session;
$pk->load_page_session($ss);
my $session_lock_class = $ss->{session_lock_class};
my $session_store_class = $ss->{session_store_class};
my $session_serialize_class = $ss->{session_serialize_class} || 'Storable';
my $session_class = $config->get_global_attr('session_class') || 'Apache::SessionX';
tie %session, $session_class, $session_id,
{
Lock => $session_lock_class,
Store => $session_store_class,
Generate => 'MD5',
Serialize => $session_serialize_class,
create_unknown => 1,
lazy => 1,
%{$ss->{session_args}}
};
if(defined($auth_session_id) &&
$auth_session_id ne $session_id){
my %auth_session;
# get new session assoc with login
tie %auth_session, $session_class, $auth_session_id,
{
Lock => $session_lock_class,
Store => $session_store_class,
Generate => 'MD5',
Serialize => $session_serialize_class,
create_unknown => 1,
lazy => 0,
%{$ss->{session_args}}
};
# user must have just logged in, so we must merge session objects!
$pk->{model}->pkit_merge_sessions(\%session,\%auth_session);
# permanently remove old session from storage
tied(%session)->delete;
untie(%session);
undef(%session);
# unset cookie for old session
my $cookie_domain_str = $pk->{config}->get_server_attr('cookie_domain');
my @cookie_domains = defined($cookie_domain_str) ? split(' ',$cookie_domain_str) : (undef);
for my $cookie_domain (@cookie_domains){
my $cookie = Apache2::Cookie->new($apr->env,
-name => $pkit_session_id,
-value => "",
-path => "/");
$cookie->domain($cookie_domain) if $cookie_domain;
$cookie->expires('-5y');
$apr->err_headers_out->add( 'Set-Cookie' => $cookie->as_string );
}
$pk->{session} = \%auth_session;
} else {
$pk->{session} = \%session;
}
}
sub set_session_cookie {
my ($pk) = @_;
return unless exists $pk->{is_new_session};
my $session = $pk->{session};
my $apr = $pk->{apr};
if(my $session_id = tied(%$session)->getid){
# something was stored in session
my $pkit_session_id = 'pkit_session_id' . ( $pk->{config}->get_server_attr('cookie_postfix') || '' );
my $expires = $pk->{config}->get_global_attr('session_expires');
my $cookie_domain_str = $pk->{config}->get_server_attr('cookie_domain');
my @cookie_domains = defined($cookie_domain_str) ? split(' ',$cookie_domain_str) : (undef);
for my $cookie_domain (@cookie_domains){
my $cookie = Apache2::Cookie->new($apr->env,
-name => $pkit_session_id,
-value => $session_id,
-path => "/");
$cookie->domain($cookie_domain) if $cookie_domain;
$cookie->expires($expires) if $expires;
$apr->err_headers_out->add('Set-Cookie' => $cookie->as_string );
}
# save for logging purposes (warning, undocumented and might go away)
$apr->notes->set(pkit_session_id => $session_id);
}
}
# check to see if page has either template or perl code associated with it
sub page_exists{
my ($pk, $page_id) = @_;
# check to see if template file exists
my $pkit_view = $pk->{apr}->param('pkit_view') || 'Default';
return 1 if $pk->{view}->template_file_exists($page_id, $pkit_view);
# check to see if perl subroutine for page exists
return 1 if $pk->page_sub;
# check to see if content file exists
my $pkit_root = $pk->{apr}->dir_config('PKIT_ROOT');
return 1 if (-f "$pkit_root/Content/$page_id.xml");
}
sub is_directory {
my ($pk, $page_id) = @_;
# check to see if the page/url is a directory
my $apr = $pk->{apr};
foreach ($apr->param('pkit_view'), 'Default') {
if (defined ($_)) {
my $filename = $apr->dir_config('PKIT_ROOT') . '/View/' . $_ . '/' . $page_id;
return $filename if (-d "$filename");
}
}
return undef;
}
sub static_page_exists{
my ($pk, $page_id) = @_;
my $apr = $pk->{apr};
foreach ($apr->param('pkit_view'), 'Default') {
if (defined ($_)){
my $filename = $apr->dir_config('PKIT_ROOT') . '/View/' . $_ . '/' . $page_id;
return $filename if (-f "$filename");
}
}
return undef;
}
1;
__END__
=head1 NAME
Apache2::PageKit - MVCC web framework using mod_perl, XML and HTML::Template
=head1 SYNOPSIS
In httpd.conf
lib/Apache2/PageKit.pm view on Meta::CPAN
Requires mod_perl2, Apache::SessionX, Compress::Zlib, Data::FormValidator,
HTML::Clean, HTML::FillInForm and HTML::Template, Text::Iconv and
XML::LibXML
I wrote these modules because I needed an application framework that was based
on mod_perl and seperated HTML from Perl. HTML::Embperl, Apache::ASP
and HTML::Mason are frameworks that work with mod_perl, but embed Perl code
in HTML. The development was inspired in part by Webmacro, which
is an open-source Java servlet framework that seperates Code from HTML.
The goal is of these modules is to develop a framework that provides most of the
functionality that is common across dynamic web sites, including session management,
authorization, form validation, component design, error handling, and content management.
=head1 BUGS
Please submit any bug reports, comments, or suggestions to the Apache2::PageKit
mailing list at http://lists.sourceforge.net/mailman/listinfo/pagekit-users
=head1 TODO
Support Template-Toolkit templates as well as HTML::Template templates.
Support for multiple transformations with stylesheets, and for filters.
Add more tests to the test suite.
=head1 AUTHORS
T.J. Mather (tjmather@tjmather.com)
Boris Zentner (bzm@2bz.de) has contributed numerous patches and is currently
maintaining the package.
=head1 CREDITS
Fixes, Bug Reports, Docs have been generously provided by:
Ben Ausden
Stu Pae
Yann Kerhervé
Chris Burbridge
Leonardo de Carvalho
Rob Falcon
Sheffield Nolan
David Raimbault
Rob Starkey
Anton Berezin
Chris Hamilton
David Christian
Anton Permyakov
Glenn Morgan
Gabriel Burca
John Robinson
Paul G. Weiss
Russell D. Weiss
Paul Flinders
Bill Karwin
Daniel Gardner
Andy Massey
Michael Cook
Michael Pheasant
John Moose
Sheldon Hearn
Vladimir Sekissov
Tomasz Konefal
Michael Wojcikiewicz
Vladimir Bogdanov
Eugene Rachinsky
Erik Günther
Bruno Czekay
Shimon Rura
Henry Kilmer
Tony Martin
Shawn Poulson
Sean Lee
Veeresh Khanorkar
Mike Castle
Also, thanks to Dan Von Kohorn for helping shape the initial architecture
and for the invaluable support and advice.
=head1 COPYRIGHT
Copyright (c) 2000, 2001, 2002, 2003, 2004, 2005 AnIdea Corporation. All rights Reserved. PageKit is a trademark
of AnIdea Corporation.
Parts of code Copyright (c) 2000, 2001, 2002 AxKit.com Ltd.
=head1 LICENSE
This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Ricoh Source Code Public License for more details.
You can redistribute this module and/or modify it only under the terms of the Ricoh Source Code Public License.
You should have received a copy of the Ricoh Source Code Public License along with this program; if not, obtain one at http://www.pagekit.org/license.html
=cut
( run in 0.513 second using v1.01-cache-2.11-cpan-e1769b4cff6 )