package Apache::PageKit;
# $Id: PageKit.pm,v 1.175 2002/03/13 22:41:15 borisz Exp $
# required for UNIVERSAL->can
require 5.005;
use strict;
# CPAN Modules required for pagekit
use Apache::URI ();
use Apache::Cookie ();
use Apache::Request ();
use Apache::SessionX ();
use Apache::Util ();
use Compress::Zlib ();
use File::Find ();
use HTML::FillInForm ();
use HTML::Parser ();
use HTML::Template ();
use Text::Iconv ();
use XML::LibXML ();
$| = 1;
# PageKit modules
use Apache::PageKit::Param ();
use Apache::PageKit::View ();
use Apache::PageKit::Content ();
use Apache::PageKit::Model ();
use Apache::PageKit::Config ();
use Apache::PageKit::Edit ();
use Apache::Constants qw(OK DONE REDIRECT DECLINED);
use vars qw($VERSION);
$VERSION = 1.09_01;
%Apache::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 = Apache->server;
if ( defined $mod_perl::VERSION && $mod_perl::VERSION >= 1.26 ) {
$pkit_root = $s->dir_config('PKIT_ROOT') || $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') || $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: Apache::PageKit->startup($pkit_root, $server)';
$server || die 'must specify $server variable in startup. Usage: Apache::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");
my $config_dir = $pkit_root . '/Config';
my $config = Apache::PageKit::Config->new(config_dir => $config_dir,
server => $server);
$config->parse_xml;
die "No config data for your server '$server' maybe you mistyped something?"
unless exists $Apache::PageKit::Config::server_attr->{$config_dir}->{$server};
my $cache_dir = $config->get_global_attr('cache_dir');
my $view_cache_dir = $cache_dir ? $cache_dir . '/pkit_cache' :
$pkit_root . '/View/pkit_cache';
unless(-e "$view_cache_dir"){
mkdir $view_cache_dir, 0755;
}
# User defined base model class
my $model_base_class = $config->get_global_attr('model_base_class') || "MyPageKit::Common";
eval "require $model_base_class";
if($@){
die "Failed to load $model_base_class ($@)";
}
# User defined session class
for ( qw /session_class page_session_class/ ) {
my $user_session_class = $config->get_global_attr($_) || next;
eval "require $user_session_class";
$@ && die "Failed to load $user_session_class ($@)";
}
# User defined template toolkit class
my $template_class = $config->get_global_attr('template_class');
if ( $template_class ) {
eval "require $template_class";
$@ && die "Failed to load $template_class ($@)";
}
# delete all cache files, since some of them might be stale
# and might not be checked for freshness, if reload is off
# even if reload is on, PageKit might change, so it should be refreshed
my $unlink_sub = sub {
-f && unlink;
};
File::Find::find($unlink_sub,$view_cache_dir);
# init gettext
if (($config->get_global_attr('use_locale') || 'no') eq 'yes') {
eval { require Locale::gettext };
unless ($@) {
# check for broken locale settings
delete @ENV{qw/LANG LANGUAGE LC_ALL/};
$ENV{LC_MESSAGES} = $config->get_global_attr('default_lang') || 'en';
# ( my $textdomain ) = $config->get_global_attr('model_base_class') =~ m/^([^:]+)/;
my $textdomain = 'PageKit';
Locale::gettext::bindtextdomain($textdomain, $pkit_root . '/locale');
Locale::gettext::textdomain($textdomain);
}
else {
warn "Locale::gettext not installed ($@)";
}
}
$model_base_class->pkit_startup($pkit_root, $server, $config)
if $model_base_class->can('pkit_startup');
}
# object oriented method call, see Eagle p.65
sub handler ($$){
my $class = shift;
my ($pk, $model, $status_code);
$| = 1;
eval {
$pk = $class->new;
$model = $pk->{model};
my $apr = $pk->{apr};
my $view = $pk->{view};
my $config = $pk->{config};
$status_code = $pk->prepare_page;
my $use_template = $config->get_page_attr($pk->{page_id},'use_template') || 'yes' if ($status_code eq OK);
if ($status_code eq OK && $use_template ne 'no'){
COMPONENT: {
$pk->open_view;
# for my $component_id (@{$view->{record}->{component_ids}}){
# $pk->component_code($component_id);
local $pk->{component_params_hashref};
for my $component_id_params_ref (@{$view->{record}->{component_ids}}){
$pk->{component_params_hashref} = $component_id_params_ref->[1];
$pk->component_code($component_id_params_ref->[0]);
if ( defined $pk->{status_code} ) {
$status_code = $pk->{status_code};
last COMPONENT;
}
}
$model->pkit_post_common_code if $model->can('pkit_post_common_code');
$pk->set_session_cookie;
$pk->prepare_and_print_view;
}
}
};
if ( $pk ) {
$status_code = $pk->_fatal_error($@) if ( $@ );
# save changes
delete @$pk{qw/session page_session/};
}
# the session and page_session references can not be used
# inside pkit_cleanup_code -- they are already deleted
$model->pkit_cleanup_code if $model && $model->can('pkit_cleanup_code');
if($@ and !$pk){
if(exists $INC{'Apache/ErrorReport.pm'}){
Apache::ErrorReport::fatal($@);
}
die $@;
}
return $status_code || OK;
}
# called in case die is trapped by eval
sub _fatal_error {
my ($pk, $error) = @_;
my $model = $pk->{model};
eval {
$error = $model->pkit_on_error($error) if $model->can('pkit_on_error');
};
# just in case we die again inside pkit_on_error
$error = $@ if ($@);
# save changes
delete @$pk{qw/session page_session/};
# the session and page_session references can not be used
# inside pkit_cleanup_code -- they are already deleted
$model->pkit_cleanup_code if $model->can('pkit_cleanup_code');
if( exists $INC{'Apache/ErrorReport.pm'} && $error ){
Apache::ErrorReport::fatal($error);
}
die $error if $error;
return ( defined $pk->{status_code} ? $pk->{status_code} : undef );
}
# utility function, concats parameters from request parameters into string
# seperated by '&' and '=' - suitable for displaying in a URL
sub params_as_string {
my ($apr, $exclude_param) = @_;
my $args;
# we cache args in pnotes - i think it is faster this way
# especially if you have <PKIT_SELFURL exclude="foo"> tags
unless ($args = $apr->pnotes('r_args')){
# this fine easy line is replaced with this beast to parse url's
# like http://ka.brain.de/login2?passwd=ss&&&&submit&&login=s&
# my %args = $apr->args;
my %args = ();
my @args = $apr->args;
while (@args) {
my $k = shift @args;
next unless $k;
$args{$k} = shift @args;
}
for (qw(login logout view check_cookie messages error_messages lang)){
delete $args{"pkit_$_"};
}
$args = \%args;
$apr->pnotes(r_args => $args);
}
if($exclude_param && @$exclude_param){
my %exclude_param_hash = map {$_ => 1} @$exclude_param;
return join ('&', map { Apache::Util::escape_uri("$_") ."=" . Apache::Util::escape_uri($args->{$_} || "")} grep {!exists $exclude_param_hash{$_}} keys %$args);
} else {
return join ('&', map { Apache::Util::escape_uri("$_") ."=" . Apache::Util::escape_uri($args->{$_} || "")} keys %$args);
}
}
sub update_session {
my ($pk, $auth_session_id) = @_;
# keep recent sessions recent, if user is logged in
# that is sessions time out if user hasn't viewed in a page
# in recent_login_timeout seconds
my $session = $pk->{session};
return unless defined($session);
unless(exists($session->{pkit_inactivity_timeout})){
my $recent_login_timeout = $pk->{config}->get_global_attr('recent_login_timeout') || 3600;
my $last_activity = $session->{pkit_last_activity};
if(defined($last_activity) && $last_activity + $recent_login_timeout < time()){
# user has been inactive for recent_login_timeout seconds, timeout
$session->{pkit_inactivity_timeout} = 1;
} else {
# update last_activity timestamp
$session->{pkit_last_activity} = time();
}
}
}
sub load_page_session {
my ( $pk, $ss ) = @_;
$ss ||= $pk->{model}->pkit_session_setup;
my $config = $pk->{config};
my $want_page_session = $config->get_page_attr($pk->{page_id}, 'page_session')
|| $config->get_global_attr('page_session') || 'no';
if ( $want_page_session eq 'yes' ) {
my ( %page_session, $secret );
{
no strict 'refs';
$secret = ${ $config->get_global_attr('model_base_class') . '::secret_md5' };
}
my $page_session_class = $config->get_global_attr('page_session_class') || 'Apache::SessionX';
tie %page_session, $page_session_class, Digest::MD5::md5_hex( $secret, $pk->{page_id} ),
{
Lock => $ss->{session_lock_class},
Store => $ss->{session_store_class},
Generate => 'MD5',
Serialize => $ss->{session_serialize_class} || 'Storable',
create_unknown => 1,
lazy => 1,
%{$ss->{session_args}}
};
$pk->{page_session} = \%page_session;
}
}
sub prepare_page {
my $pk = shift;
# $apr is an Apache::Request object, derived from Apache request object
my $apr = $pk->{apr};
# $view is an Apache::PageKit::View object
my $view = $pk->{view};
# $config is an Apache::PageKit::Config object
my $config = $pk->{config};
# $model is an Apache::PageKit::Model object
my $model = $pk->{model};
# decline to serve images, etc
# return DECLINED if $apr->content_type && $apr->content_type !~ m|^text/|io;
my $uri = $apr->uri;
my $output_param_object = $pk->{output_param_object};
my $fillinform_object = $pk->{fillinform_object};
# decline files_match
if (my $files_match = $config->get_server_attr('files_match')){
return DECLINED if $uri =~ m/$files_match/;
}
# this is the color, that replaces all <PKIT_ERRORSTR>
my $default_errorstr = $config->get_global_attr('default_errorstr') || '#ff0000';
$output_param_object->param(PKIT_ERRORSTR => $default_errorstr);
my $uri_prefix = $config->get_global_attr('uri_prefix') || '';
if($uri_prefix){
$uri =~ s(^/$uri_prefix/*)(/); # */
}
if($model->can('pkit_fixup_uri')){
$uri = $model->pkit_fixup_uri($uri);
}
# my $host = (split(':',$apr->headers_in->{'Host'}))[0];
my ($host, $uri_with_query);
if(my $X_Original_URI = $apr->headers_in->{'X-Original-URI'}){
($host) = ($X_Original_URI =~ m!^https?://([^/]*)!);
$uri_with_query = $X_Original_URI;
} else {
$host = $apr->headers_in->{'Host'};
$uri_with_query = ((defined( $ENV{HTTPS} ) && $ENV{HTTPS} eq 'on') ? 'https' : 'http') . '://' . $host . ($uri_prefix ? '/' . $uri_prefix : '' ) . $uri;
}
# my $pkit_selfurl;
$apr->notes(orig_uri => $uri_with_query);
my $query_string = params_as_string($apr);
if($query_string){
$uri_with_query .= "?" . $query_string;
# $pkit_selfurl = $uri_with_query . '&';
# } else {
# $pkit_selfurl = $uri_with_query . '?';
}
# $view->param(PKIT_SELFURL => $pkit_selfurl);
$output_param_object->param(PKIT_HOSTNAME => $host);
# my $pkit_done = Apache::Util::escape_uri($apr->param('pkit_done') || $uri_with_query);
my $pkit_done = $apr->param('pkit_done') || $uri_with_query;
# $pkit_done =~ s/"/\%22/g;
# $pkit_done =~ s/&/\%26/g;
# $pkit_done =~ s/\?/\%3F/g;
$output_param_object->param("pkit_done",$pkit_done);
# $fillinform_object->param("pkit_done",$pkit_done);
$pk->{page_id} = $uri;
# add the default_page for pageid with trailing slash "/"
# WARNING - this is undocumented and may go away at anytime
$pk->{page_id} =~ s!^(.*?)/+$! "$1/" . $model->pkit_get_default_page !e;
# get rid of leading forward slash
$pk->{page_id} =~ s(^/+)();
# get default page if there is no page specified in url
if($pk->{page_id} eq ''){
$pk->{page_id} = $model->pkit_get_default_page;
}
# store name and page_id for a static file, that require a login
my %static_file;
# redirect "not found" pages
unless ($pk->page_exists($pk->{page_id})){
# first try to see if we can find a static file that we
# can return
my $filename = $pk->static_page_exists($pk->{page_id});
unless($filename) {{
if ($pk->is_directory($pk->{page_id})) {
$pk->{page_id} .= '/' . $model->pkit_get_default_page;
last if ($pk->page_exists($pk->{page_id}));
$filename = $pk->static_page_exists($pk->{page_id});
last if ($filename);
}
$pk->{page_id} = $config->uri_match($pk->{page_id})
|| $config->get_global_attr('not_found_page')
|| $model->pkit_get_default_page;
unless ($pk->page_exists($pk->{page_id})){
# if not_found_page is static, then return DECLINED...
$filename = $pk->static_page_exists($pk->{page_id});
}
}}
if ($filename){
my $require_login = $config->get_page_attr($pk->{page_id},'require_login') || 'no';
my $protect_static = $config->get_global_attr('protect_static') || 'yes';
if ( $require_login eq 'no' || $protect_static ne 'yes' ) {
# return the static page only, if no parameters are attached to the uri
# otherwise we can not login logout and so on when one the default or index
# or whatever page is static.
# if we have some parameters, defer the delivery of the page after the
# auth check
return $pk->_send_static_file($filename) unless ( $apr->param );
}
$static_file{name} = $filename;
$static_file{page_id} = $pk->{page_id};
}
}
my ($auth_user, $auth_session_id);
unless($apr->param('pkit_logout')){
($auth_user, $auth_session_id) = $pk->authenticate;
}
# session handling
if($model->can('pkit_session_setup')){
$pk->setup_session($auth_session_id);
}
my $session = $pk->{session};
# get language
# get Locale settings
my ($lang, $accept_lang);
if( $lang = $apr->param('pkit_lang') ){
$session->{'pkit_lang'} = $lang if $session;
} elsif ( $session && !exists $pk->{is_new_session} ){
$lang = $session->{'pkit_lang'} if exists $session->{'pkit_lang'};
}
# if we have no lang setting here look what the browser likes most.
unless ($lang) {
if ( $accept_lang = $apr->header_in('Accept-Language') ) {
$lang = substr($accept_lang, 0, 2);
}
}
$lang ||= $config->get_global_attr('default_lang') || 'en';
# TEMP only for anidea.com site, until fix problems with localization in content
$output_param_object->param("PKIT_LANG_$lang" => 1);
$pk->{lang} = $lang;
if($apr->param('pkit_logout')){
$pk->logout;
$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');
}
}
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');
# 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->connection->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');
} 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');
$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};
require MIME::Types;
my ($media_type) = MIME::Types::by_suffix($filename);
if (defined $media_type) {
$apr->content_type($media_type);
if($media_type eq "text/html" && $pk->{use_gzip} ne 'none') {
my $gzipped = $pk->{view}->get_static_gzip($filename);
if ($gzipped){
$apr->content_encoding("gzip");
$apr->send_http_header;
$apr->print($gzipped) unless $apr->header_only;
return DONE;
}
}
}
# set path_info to '', otherwise Apache tacks it on at the end
$apr->path_info('');
$apr->filename($filename);
return DECLINED;
}
sub _check_gzip {
my $pk = shift;
# check Accent-Encoding or if the user_agent field for Unix/Mac Netscape
# to see if should gzip output
my $gzip_output = $pk->{config}->get_global_attr("gzip_output") || 'none';
$pk->{use_gzip} = 'none';
my $apr = $pk->{apr};
if ($gzip_output =~ m!^(all|static)$!){
if(($apr->header_in("Accept-Encoding") || "") =~ /gzip/){
$pk->{use_gzip} = $gzip_output;
} else {
my $user_agent = $apr->header_in("User-Agent");
# this regular expression borrowed from Apache::AxKit::ConfigReader::DoZip
if ($user_agent =~ m{
^Mozilla/
\d+
\.
\d+
[\s\[\]\w\-]+
(
\(X11 |
Macint.+PPC,\sNav
)
}x
) {
$pk->{use_gzip} = $gzip_output;
}
}
}
}
sub open_view {
my ($pk) = @_;
my $pkit_view = $pk->{apr}->param('pkit_view') || 'Default';
# open template file
$pk->{view}->open_view($pk->{page_id}, $pkit_view, $pk->{lang});
}
sub prepare_and_print_view {
my ($pk) = @_;
my $apr = $pk->{apr};
my $view = $pk->{view};
my $config = $pk->{config};
my $model = $pk->{model};
my $page_id = $pk->{page_id};
# set view fillinform_objects and associated_objects, if approriate
my $fill_in_form = $config->get_page_attr($page_id,'fill_in_form') || 'yes';
# $apr comes first, so that fillinform overrides request parameters
my @fillinform_objects_array = ( $apr, $pk->{fillinform_object} );
if ( $fill_in_form eq 'no' ) {
# we want only the $pk->{fillinform_object} object
shift @fillinform_objects_array;
}
$view->{fillinform_objects} = [ grep {$_->param} @fillinform_objects_array ];
$view->{ignore_fillinform_fields} = $pk->{ignore_fillinform_fields};
my $page_rpit = $config->get_page_attr($page_id,'request_param_in_tmpl') || '';
my $global_rpit = $config->get_global_attr('request_param_in_tmpl') || 'no';
if($page_rpit eq 'yes' || ($page_rpit ne 'no' && $global_rpit eq 'yes')) {
$view->{associated_objects} = [$apr];
}
# set up page template and run component code
my $output_ref = $view->fill_in_view;
# determine output media type
my $pkit_view = $apr->param('pkit_view') || 'Default';
my $output_media = $config->get_page_attr($page_id, 'content_type')
|| $config->get_view_attr($pkit_view, 'content_type')
|| $Apache::PageKit::DefaultMediaMap{$pkit_view}
|| 'text/html';
# set expires to now so prevent caching
#$apr->no_cache(1) if $apr->param('pkit_logout') || $config->get_page_attr($pk->{page_id},'template_cache') eq 'no';
# see http://support.microsoft.com/support/kb/articles/Q234/0/67.ASP
# and http://www.pacificnet.net/~johnr/meta.html
my $browser_cache = $config->get_page_attr($page_id,'browser_cache') || 'yes';
$apr->header_out('Expires','-1') if $apr->param('pkit_logout') || $browser_cache eq 'no' || $apr->connection->user;
my $default_output_charset = $view->{default_output_charset};
my @charsets = ();
if($output_media eq 'text/html'){
# first get accepted charsets from incoming Accept-Charset HTTP header
if(my $accept_charset = $apr->headers_in->{'Accept-Charset'}){
my $pos = 0;
foreach my $charset (split(/,\s*/, $accept_charset)) {
my $score;
($charset, $score) = split(/;\s*q=/, $charset, 2);
$score = 1 unless (defined($score) && ($score =~ /^(\+|\-)?\d+(\.\d+)?$/));
$charset =~ s/iso/ISO/;
$charset =~ s/utf/UTF/;
$charset =~ s/(us\-)?ascii/US-ASCII/;
push @charsets, [ $charset, $score, $pos++ ];
}
@charsets = sort {$b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @charsets;
# set a content-type perhaps we overwrite this later if we know about the charset for the output pages
$apr->content_type("text/html");
}
} elsif ($output_media eq 'application/pdf'){
# write output_media to file, using process number of Apache child process
my $view_cache_dir = $view->{cache_dir};
my $fo_file = "$view_cache_dir/$$.fo";
my $pdf_file = "$view_cache_dir/$$.pdf";
open FO_TEMPLATE, ">$fo_file" or die "can't open file: $fo_file ($!)";
print FO_TEMPLATE $$output_ref;
close FO_TEMPLATE;
# call Apache XML FOP
my $fop_command = $config->get_server_attr('fop_command') ||
$config->get_global_attr('fop_command');
die "fop_command not specifed in configuration - must specify to use Apache XML FOP to generate PDFs" unless $fop_command;
# my $error_message = `$fop_command $fo_file $pdf_file 2>&1 1>/dev/null`;
my $error_message = `$fop_command $fo_file $pdf_file 2>&1`;
## the recommended fop converter has no usefull error messages.
## the errormoessages go also to STDOUT
## and the returncode is always 0
unless ($error_message =~ /^\[ERROR\]:/m){
local $/;
open PDF_OUTPUT, "<$pdf_file" or die "can't open file: $pdf_file ($!)";
$$output_ref = <PDF_OUTPUT>;
close PDF_OUTPUT;
} else {
die "Error processing template with Apache XML FOP: $error_message";
}
$apr->content_type($output_media);
} else {
# just set content_type
$apr->content_type($output_media);
}
# for a head request
if ($apr->header_only) {
$apr->send_http_header if $apr->is_initial_req;
return;
}
# call output filter, if applicable
$model->pkit_output_filter($output_ref)
if $model->can('pkit_output_filter');
my ( $converted_data, $retcharset );
if ($output_media eq 'text/html'){
my $data;
while (@charsets){
$retcharset = (shift @charsets)->[0];
last if ($retcharset eq $default_output_charset);
eval {
my $converter = Text::Iconv->new($default_output_charset, $retcharset);
$converted_data = $converter->convert($$output_ref);
};
last if ($converted_data);
$retcharset = undef;
}
## here no action is needed, if we did not convert the data to anything usefull.
## we deliver in our default_output_charset.
# correct the header
$apr->content_type("text/html; charset=$retcharset") if ($retcharset);
$apr->content_type("text/html") unless ($retcharset);
}
# only pages with propper $retcharset are tranfered gzipped.
# this can maybe changed!? Needs some tests
my $send_gzipped = ( $retcharset && $pk->{use_gzip} eq 'all' );
$apr->content_encoding('gzip') if ($send_gzipped);
$apr->send_http_header if $apr->is_initial_req;
if ($send_gzipped) {
$apr->print(Compress::Zlib::memGzip($converted_data || $$output_ref));
} else {
$apr->print($converted_data || $$output_ref);
}
}
sub new {
my $class = shift;
my $r = Apache->request;
my $self = {@_};
bless $self, $class;
# set up contained objects
my $pkit_root = $r->dir_config('PKIT_ROOT');
die "Must specify PerlSetVar PKIT_ROOT in httpd.conf file" unless $pkit_root;
my $config_dir = $pkit_root . '/Config';
my $content_dir = $pkit_root . '/Content';
my $view_dir = $pkit_root . '/View';
my $server = $r->dir_config('PKIT_SERVER');
die "Must specify PerlSetVar PKIT_SERVER in httpd.conf file" unless $server;
my $config = $self->{config} = Apache::PageKit::Config->new(config_dir => $config_dir,
server => $server);
my $post_max = $self->{config}->get_global_attr('post_max') || 100_000_000;
my $apr = $self->{apr} = Apache::Request->new($r, POST_MAX => $post_max);
my $model_base_class = $self->{config}->get_global_attr('model_base_class') || "MyPageKit::Common";
$self->_check_gzip;
my $model;
eval {$model = $self->{model} = $model_base_class->new(pkit_pk => $self)};
if($@){
unless($model_base_class){
die "model_base_class not specified";
} else {
die "Model class $model_base_class has no new method ($@)";
}
}
$self->{dbh} = $model->pkit_dbi_connect if $model->can('pkit_dbi_connect');
my $default_lang = $config->get_global_attr('default_lang') || 'en';
my $default_input_charset = $config->get_global_attr('default_input_charset') || 'ISO-8859-1';
my $default_output_charset = $config->get_global_attr('default_output_charset') || 'ISO-8859-1';
my $html_clean_level = $config->get_server_attr('html_clean_level') || 0;
my $can_edit = $config->get_server_attr('can_edit') || 'no';
my $reload = $config->get_server_attr('reload') || 'no';
my $cache_dir = $config->get_global_attr('cache_dir');
my $view_cache_dir = $cache_dir ? $cache_dir . '/pkit_cache' : $pkit_root . '/View/pkit_cache';
my $relaxed_parser = $config->get_global_attr('relaxed_parser') || 'no';
my $errorspan_begin_tag = $config->get_global_attr('errorspan_begin_tag') || q{<font color="<PKIT_ERRORSTR>">};
my $errorspan_end_tag = $config->get_global_attr('errorspan_end_tag') || q{</font>};
my $default_errorstr = $config->get_global_attr('default_errorstr') || '#ff0000';
my $template_class = $config->get_global_attr('template_class') || 'HTML::Template';
$self->{view} = Apache::PageKit::View->new(view_dir => "$pkit_root/View",
content_dir => "$pkit_root/Content",
cache_dir => $view_cache_dir,
default_lang => $default_lang,
default_input_charset => $default_input_charset,
default_output_charset => $default_output_charset,
reload => $reload,
html_clean_level => $html_clean_level,
input_param_object => $apr,
output_param_object => $self->{output_param_object},
can_edit => $can_edit,
relaxed_parser => $relaxed_parser,
errorspan_begin_tag => $errorspan_begin_tag,
errorspan_end_tag => $errorspan_end_tag,
default_errorstr => $default_errorstr,
template_class => $template_class,
);
return $self;
}
sub page_sub {
my $pk = shift;
my $page_id = shift || $pk->{page_id};
# change all the / to ::
$page_id =~ s!/!::!g;
my $perl_sub;
if($page_id =~ s/^pkit_edit:://){
$perl_sub = 'Apache::PageKit::Edit::' . $page_id;
} else {
my $model_dispatch_prefix = $pk->{config}->get_global_attr('model_dispatch_prefix');
$perl_sub = $model_dispatch_prefix . '::' . $page_id;
}
return $perl_sub if defined &{$perl_sub};
my ($class_package) = $perl_sub =~ m/^(.*)::/;
return if exists $Apache::PageKit::checked_classes{$class_package};
# with this funny require line, we can check also for files with expressions like
# Foo::Bar-Foo::Bar without a warining and this is more secure
eval "require $class_package" if ( $class_package =~ /^[\w\d:]+$/ );
$Apache::PageKit::checked_classes{$class_package} = 1;
return undef unless (defined &{$perl_sub});
my $model_base_class = $pk->{config}->get_global_attr('model_base_class') || "MyPageKit::Common";
warn qq{For full preformance please add "use $class_package" in your $model_base_class or startup.pl script};
return $perl_sub;
}
sub page_code {
my $pk = shift;
my ( $common_page_id, $model_dispatch_prefix, $default_code_perl_sub );
( $common_page_id = $pk->{page_id} ) =~ s!/!::!g;
$model_dispatch_prefix = $pk->{config}->get_global_attr('model_dispatch_prefix');
( $default_code_perl_sub = $model_dispatch_prefix . '::' . $common_page_id ) =~ s/[^:]+$/pkit_default/;
$default_code_perl_sub = undef unless (defined &$default_code_perl_sub);
my @subs = grep { $_ } ( $default_code_perl_sub, $pk->page_sub );
return $pk->call_model_code(@subs) if (@subs);
return;
}
sub component_code {
my $pk = shift;
my $component_id = shift;
#remove any leading /
$component_id =~ s!^/+!!;
# change all the / to ::
$component_id =~ s!/!::!g;
# insert a module_ before the method
# $component_id =~ s/(.*?)([^:]+)$/$1::$2/;
my $model_dispatch_prefix = $pk->{config}->get_global_attr('model_dispatch_prefix');
my $perl_sub = $model_dispatch_prefix . '::' . $component_id;
return $pk->call_model_code($perl_sub) if (defined &{$perl_sub});
return;
}
# calls code from user module in Model
sub call_model_code {
my $pk = shift;
my $model = $pk->{model};
my $dispatch_model;
for (@_) {
# extract class and method from perl subroutine
my ($model_class, $method) = m!^(.+?)::([^:]+)$!;
$dispatch_model = $model->create($model_class) unless ( $dispatch_model && $model_class eq ref $dispatch_model );
# dispatch message to model class
no strict 'refs';
$dispatch_model->$method();
# for the case, that someone has set this -- with $model->pkit_status_code
return if ( defined $pk->{status_code} );
}
}
sub login {
my ($pk) = @_;
my $apr = $pk->{apr};
my $config = $pk->{config};
my $model = $pk->{model};
my $remember = $apr->param('pkit_remember');
my $done = $apr->param('pkit_done') || $apr->notes('orig_uri') || $model->pkit_get_default_page;
unless($model->can('pkit_auth_credential')){
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 $session_id;
if(defined $pk->{session}){
$session_id = tied(%{$pk->{session}})->getid;
if ( $session_id ) {
unless ( $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}}
};
delete $auth_session{pkit_inactivity_timeout};
$auth_session{pkit_last_activity} = time;
# save session
untie %auth_session;
}
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 = Apache::Cookie->new($apr,
-name => 'pkit_id',
-value => $ses_key,
-path => "/");
$cookie->domain($cookie_domain) if $cookie_domain;
if ($remember){
$cookie->expires("+10y");
}
$cookie->bake;
}
# 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=" . Apache::Util::escape_uri($message);
}
}
if(my @pkit_error_messages = $apr->param('pkit_error_messages')){
for my $message (@pkit_error_messages){
$done .= "&pkit_error_messages=" . Apache::Util::escape_uri($message);
}
}
$apr->headers_out->set(Location => "$done");
return 1;
}
sub authenticate {
my ($pk) = @_;
my $apr = $pk->{apr};
my $model = $pk->{model};
my %cookies = Apache::Cookie->fetch;
return unless $cookies{'pkit_id'};
my %ticket = $cookies{'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->connection->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 %cookies = Apache::Cookie->fetch;
my $logout_kills_session = $pk->{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 = $pk->{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');
$tcookie->bake;
}
}
}
# 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 = Apache::Cookie->fetch;
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 = Apache::Cookie->new($apr,
-name => 'pkit_session_id',
-value => "",
-path => "/");
$cookie->domain($cookie_domain) if $cookie_domain;
$cookie->expires('-5y');
$cookie->bake;
}
$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 $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 = Apache::Cookie->new($apr,
-name => 'pkit_session_id',
-value => $session_id,
-path => "/");
$cookie->domain($cookie_domain) if $cookie_domain;
$cookie->expires($expires) if $expires;
$cookie->bake;
}
# save for logging purposes (warning, undocumented and might go away)
$apr->notes(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
Apache::PageKit - MVCC web framework using mod_perl, XML and HTML::Template
=head1 SYNOPSIS
In httpd.conf
SetHandler perl-script
PerlSetVar PKIT_ROOT /path/to/pagekit/files
PerlSetVar PKIT_SERVER staging
PerlHandler +Apache::PageKit
<Perl>
Apache::PageKit->startup('/path/to/pagekit/files', 'staging');
</Perl>
In MyPageKit/Common.pm
package MyPageKit::Common;
use base 'Apache::PageKit::Model';
sub pkit_dbi_connect {
return DBI->connect("DBI:mysql:db","user","passwd");
}
sub pkit_session_setup {
my $model = shift;
my $dbh = $model->dbh;
return {
session_lock_class => 'MySQL',
session_store_class => 'MySQL',
session_args => {
Handle => $dbh,
LockHandle => $dbh,
},
};
}
sub pkit_auth_credential {
my ($model) = @_;
# in this example, login and passwd are the names of the credential fields
my $login = $model->input('login');
my $passwd = $model->input('passwd');
# create a session key
# your code here.........
return $ses_key;
}
sub pkit_auth_session_key {
my ($model, $ses_key) = @_;
# check whether $ses_key is valid, if so return user id in $user_id
# your code here.........
return $ok ? $user_id : undef;
}
=head1 DESCRIPTION
PageKit is an mod_perl based application framework that uses HTML::Template and
XML to separate code, design, and content. Includes session management,
authentication, form validation, co-branding, and a content management system.
Its goal is to solve all the common problems of web programming, and to make
the creation and maintenance of dynamic web sites fast, easy and enjoyable.
You have to write a module named MyPageKit::Common
that inherits from Apache::PageKit::Model and
provides methods common across the site.
For example, if you wish to support authentication, it must
include the two methods C<pkit_auth_credential> and C<pkit_auth_session_key>.
For more information, visit http://www.pagekit.org/
Most of the docs have been moved out of POD to DocBook. The sources can
be found in the docsrc directory of the distribution, and the HTML output
can be found at http://www.pagekit.org/guide
=head1 METHODS
The following method is available to the user as Apache::PageKit API.
=over 4
This function should be called at server startup from your httpd.conf file:
If you use PageKit >= 1.09 and mod_perl < 1.26, the follow the instructions
for PageKit < 1.09.
PerlSetVar PKIT_ROOT /path/to/pagekit/files
PerlSetVar PKIT_SERVER staging
PerlHandler +Apache::PageKit
<Perl>
Apache::PageKit->startup;
</Perl>
PageKit < 1.09 should be started this way:
PerlSetVar PKIT_ROOT /path/to/pagekit/files
PerlSetVar PKIT_SERVER staging
PerlHandler +Apache::PageKit
<Perl>
Apache::PageKit->startup("/path/to/pagekit/files","staging");
</Perl>
Where the first argument is the root directory of the
PageKit application. The second (optional) argument is the server id.
It loads /path/to/pagekit/files/Model into the perl search
path so that PageKit can make calls into MyPageKit::Common and
other Model classes. It also loads
the Config and Content XML files and pre-parses the View template files.
=back
=head1 FREQUENTLY ASKED QUESTIONS
See http://www.pagekit.org/faq.html
=head1 SEE ALSO
L<Apache::Request>, L<HTML::FillInForm>, L<HTML::Template>,
L<Data::FormValidator>
=head1 VERSION
This document describes Apache::PageKit module version 1.10
=head1 NOTES
Requires mod_perl, 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 Apache::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 (boris@id9.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
Anton Berezin
Chris Hamilton
David Christian
Rob Starkey
Anton Permyakov
John Robinson
Daniel Gardner
Andy Massey
Michael Cook
Michael Pheasant
John Moose
Sheldon Hearn
Vladimir Sekissov
Gabriel Burca
Tomasz Konefal
Michael Wojcikiewicz
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 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