CAM-App
view release on metacpan or search on metacpan
lib/CAM/App.pm view on Meta::CPAN
package CAM::App;
=head1 NAME
CAM::App - Web database application framework
=head1 LICENSE
Copyright 2005 Clotho Advanced Media, Inc., <cpan@clotho.com>
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=head1 SYNOPSIS
You can either directly instantiate this module, or create a subclass,
creating overridden methods as needed.
Direct use:
use CAM::App;
require "Config.pm"; # user-edited config hash
my $app = CAM::App->new(Config->new(), CGI->new());
$app->authenticate() or $app->error("Login failed");
my $tmpl = $app->template("message.tmpl");
my $ans = $app->getCGI()->param('ans');
if (!$ans) {
$tmpl->addParams(msg => "What is your favorite color?");
} elsif ($ans eq "blue") {
$tmpl->addParams(msg => "Very good.");
} else {
$tmpl->addParams(msg => "AIIEEEEE!");
}
$tmpl->print();
Subclass: (then use just like above, replacing CAM::App with my::App)
package my::App;
use CAM::App;
@ISA = qw(CAM::App);
sub init {
my $self = shift;
my $basedir = "..";
$self->{config}->{cgidir} = ".";
$self->{config}->{basedir} = $basedir;
$self->{config}->{htmldir} = "$basedir/html";
$self->{config}->{templatedir} = "$basedir/tmpls";
$self->{config}->{libdir} = "$basedir/lib";
$self->{config}->{sqldir} = "$basedir/lib/sql";
$self->{config}->{error_template} = "error_tmpl.html";
$self->addDB("App", "live", "dbi:mysql:database=app", "me", "mypass");
$self->addDB("App", "dev", "dbi:mysql:database=appdev", "me", "mypass");
return $self->SUPER::init();
}
sub authenticate {
my $self = shift;
return(($self->getCGI()->param('passwd') || "") eq "secret");
}
sub selectDB {
my ($self, $params) = @_;
my $key = $self->{config}->{myURL} =~ m,^http://dev\.foo\.com/, ?
"dev" : "live";
return @{$params->{$key}};
}
=head1 DESCRIPTION
CAM::App is a framework for web-based, database-driven applications.
This package abstracts away a lot of the tedious interaction with the
application configuration state. It is quite generic, and is designed
to be subclassed with more specific functions overriding its behavior.
=cut
#--------------------------------#
require 5.005_62;
use strict;
use warnings;
use File::Spec;
use Carp;
use CGI;
## These are loaded on-demand below, if they are not already loaded.
## Please keep this list up to date!
#use DBI;
#use CAM::Template;
#use CAM::EmailTemplate;
#use CAM::EmailTemplate::SMTP;
#use CAM::Template::Cache;
#use CAM::Session;
# The following modules may loaded externally, if at all. This module
# detects their presence by looking for their $VERSION variables.
# CGI::Compress::Gzip
# CAM::Session
# CAM::SQLManager
# CAM::Template::Cache
our @ISA = qw();
lib/CAM/App.pm view on Meta::CPAN
=item new [config => CONFIGURATION], [cgi => CGI], [dbi => DBI], [session => SESSION]
Create a new application instance. The configuration object must be a
hash reference (blessed or unblessed, it doesn't matter). Included in
this distibution is the example/SampleConfig.pm module that shows what
sort of config data should be passed to this constructor. Otherwise,
you can apply configuration parameters by subclassing and overriding
the constructor.
Optional objects will be accepted as arguments; otherwise they will be
created as needed. If you pass an argument with value undef, that
will be interpreted as meaning that you don't want the object
auto-created. For example, C<new()> will cause a CGI object to be
created, C<new(cgi =E<gt> $cgi)> will use the passed CGI object, and
C<new(cgi =E<gt> undef)> will not create use CGI object at all. The
latter is useful where the creation of a CGI object may be
destructive, for example in a SOAP::Lite environment.
=cut
sub new
{
my $pkg = shift;
my %params = (@_);
my $self = bless({
dbparams => {},
status => [],
}, $pkg);
$self->applyDBH(); # clear any cached values
foreach my $key (qw(cgi dbh session config))
{
$self->{$key} = $params{$key} if (exists $params{$key});
}
if (!$self->{config})
{
$self->{config} = {};
}
$self->init();
return $self;
}
#--------------------------------#
=item init
After an object is constructed, this method is called. Subclasses may
want to override this method to apply tweaks before calling the
superclass initializer. An example:
sub init {
my $self = shift;
$self->{config}->{sqldir} = "../lib/sql";
return $self->SUPER::init();
}
This init function does the following:
* Sets up some of the basic configuration parameters
(myURL, fullURL, cgidir, cgiurl)
* Creates a new CGI object if one does not exist (as per getCGI)
* Sets up the DBH object if one exists
* Tells CAM::SQLManager where the sqldir is located if possible
=cut
sub init
{
my $self = shift;
my $cfg = $self->{config}; # shorthand
#$SIG{__DIE__} = sub {$self->{dying}=1;$self->error(@_)};
## Initialize session package
$cfg->{sessionclass} ||= "CAM::Session";
## Initialize CGI
$self->getCGI(); # initialize CGI if possible/appropriate
## Initialize myURL
if (!exists $cfg->{myURL})
{
$cfg->{myURL} = CGI->url();
}
if (!exists $cfg->{fullURL} && $self->getCGI())
{
# For file uploads, the self_url call generates a
# "Use of uninitialized value at (eval 29) line 8."
# error because of a bug in CGI v2.46.
# Block this by turning off warnings for this line.
no warnings;
$cfg->{fullURL} = $self->getCGI()->self_url();
use warnings;
}
## Initialize cgiurl
if ($cfg->{myURL} && (!exists $cfg->{cgiurl}))
{
# Truncate the filename from the URL
($cfg->{cgiurl} = $cfg->{myURL}) =~ s,/[^/\\]*$,,;
}
## Initialize cgidir
if (!exists $cfg->{cgidir})
{
$cfg->{cgidir} = $self->computeDir();
}
## Initialize DBH
if ($self->{dbh})
{
# Note that unlike getDBH(), the DBH is NOT cached in this case.
# This is the correct behavior. Since the calling script handed
# us the DBH, it's assumed that the caller will handle any
# caching
$self->applyDBH();
}
## Initialize sqldir
if ($CAM::SQLManager::VERSION && $self->{config}->{sqldir})
{
CAM::SQLManager->setDirectory($self->{config}->{sqldir});
}
return $self;
}
#--------------------------------#
=item computeDir
Returns the directory in which this CGI script is located. This can
be a class or instance method.
=cut
sub computeDir
{
my $pkg_or_self = shift;
my $cgidir;
if ($ENV{SCRIPT_FILENAME})
{
($cgidir = $ENV{SCRIPT_FILENAME}) =~ s,/[^/\\]*$,,;
}
elsif ($ENV{PATH_TRANSLATED})
{
$cgidir = $ENV{PATH_TRANSLATED};
}
elsif ($ENV{PWD})
{
# Append the calling path (if any) to the PWD
if ($0 =~ /(.*)[\/\\]/)
{
my $execpath = $1;
if ($execpath =~ m,^[/\\],)
{
$cgidir = $execpath;
}
else
{
$cgidir = File::Spec->catdir($ENV{PWD}, $execpath);
}
}
else
{
$cgidir = $ENV{PWD};
}
}
# Fix odd cases, like a script called from "./myscript" or "../myscript
if ($cgidir)
{
$cgidir =~ s,/[^/]+/\.\.,,g; # remove "/dir/.."
$cgidir =~ s,\\[^\\]+\\\.\.,,g; # remove "\dir\.."
$cgidir =~ s,/\./,/,g; # change "path/./path" to "path/path"
$cgidir =~ s,\\\.\\,\\,g; # change "path\.\path" to "path\path"
$cgidir =~ s,/\.$,,g; # change "path/." to "path"
$cgidir =~ s,\\\.$,,g; # change "path\." to "path"
$cgidir =~ s,//+$,/,g; # change "path///path" to "path/path"
$cgidir =~ s,\\\\+$,\\,g; # change "path\\\path" to "path\path"
}
return $cgidir;
}
#--------------------------------#
=item authenticate
Test the login information, if any. Currently no tests are performed
-- this is a no-op. Subclasses may override this method to test login
credentials. Even though it's currently trivial, subclass methods
should alway include the line:
return undef if (!$self->SUPER::authenticate());
In case the parent authenticate() method adds a test in the future.
=cut
sub authenticate {
my $self = shift;
# No checks
return $self;
}
#--------------------------------#
=item header
Compose and return a CGI header, including the CAM::Session cookie, if
applicable (i.e. if getSession() has been called first). Returns the
empty string if the header has already been printed.
=cut
sub header {
my $self = shift;
my $cgi = $self->getCGI();
if (!$cgi)
{
if (!$self->{header_printed})
{
$self->{header_printed} = 1;
return "Content-Type: text/html\n\n";
}
else
{
return "";
}
}
elsif (!$cgi->{'.header_printed'})
{
if ($self->{session})
{
return $cgi->header(-cookie => $self->{session}->getCookie(), @_);
}
else
{
return $cgi->header(@_);
}
lib/CAM/App.pm view on Meta::CPAN
# Internal function:
# builds, fills and returns a template object
sub _template {
my $self = shift;
my $module = shift || "CAM::Template";
my $file = shift;
my $key = shift;
if (!$self->loadModule($module))
{
$self->error("Internal error: Failed to load the $module library")
unless ($self->{in_error});
}
my $template;
if ($key)
{
# This is a ::Cache template
$template = $module->new($key, $self->getDBH());
}
else
{
# This is a normal template
$template = $module->new();
}
if (defined $file)
{
my $dir = $self->{config}->{templatedir} || "";
if (defined $dir)
{
$dir =~ s,[/\\]$,,; # trim trailing sep char
}
if (!$template->setFilename(defined $dir && $dir ne "" ? File::Spec->catfile($dir, $file) : $file))
{
$self->error("Internal error: problem locating the web page template")
unless ($self->{in_error});
}
}
$self->prefillTemplate($template, @_);
return $template;
}
#--------------------------------#
=item prefillTemplate TEMPLATE, [KEY => VALUE, KEY => VALUE, ...]
This fills the search-and-replace list of a template with typical
values (like the base URL, the URL of the script, etc. Usually, it is
just called from withing getTemplate() and related methods, but if you
build your own templates you may want to use this explicitly.
The following value are set (and the order is significant, since later
keys can override earlier ones):
- the configuration variables, including:
- myURL => URL of the current script
- fullURL => URL of the current page, including CGI parameters and target
- cgiurl => URL of the directory containing the current script
- cgidir => directory containing the current script
- many others...
- mod_perl => boolean indicating whether the script is in mod_perl mode
- anything passed as arguments to this method
Subclasses may override this to add more fields to the template. We
recommend implementing override methods like this:
sub prefillTemplate {
my $self = shift;
my $template = shift;
$self->SUPER::prefillTemplate($template);
$template->addParams(
myparam => myvalue,
# any other key-value pairs or hashes ...
@_, # add this LAST to override any earlier params
);
return $self;
}
=cut
sub prefillTemplate
{
my $self = shift;
my $template = shift;
if (!$template->setParams(
# you MUST update the documentation above
# if you change anything in this list!!!
%{$self->{config}},
mod_perl => (exists $ENV{MOD_PERL}),
@_,
))
{
$self->error("Internal error: problem setting template parameters")
unless ($self->{in_error});
}
return $self;
}
#--------------------------------#
=item addStatusMessage MESSAGE
This is a handy repository for non-fatal status messages accumulated
by the application. [Fatal messages can be handled by the error()
method] Applications who use this mechanism frequently may wish to
override prefillTemplate to set something like:
status => join("<br>", $app->getStatusMessages())
so in template HTML you could, for example, display this via
<style> .status { color: red } </style>
...
??status??<div class="status">::status::</div>??status??
=cut
( run in 0.812 second using v1.01-cache-2.11-cpan-5735350b133 )