CGI-Framework
view release on metacpan or search on metacpan
lib/CGI/Framework.pm view on Meta::CPAN
sub validate_templatename {
my $instance = shift;
if (!$instance->form("country")) {
$instance->add_error("You must select a country");
}
else {
$instance->remember("country");
}
}
sub pre_templatename {
my $instance = shift;
$instance->html("country", [qw(CA US BR)]);
}
=item THE FUNCTION-BASED WAY
The function-based way is very similar (and slightly less cumbersome to use due to less typing) than the OO way. The differences are: You have to use the ":nooop" tag in the use() line to signify that you want the methods exported to your namespace, ...
use CGI::Framework ':nooop';
initialize_cgi_framework (
this => that,
foo => bar,
);
dispatch();
sub validate_templatename {
if (!form("country")) {
add_error("You must select a country");
}
else {
remember("country");
}
}
sub pre_templatename {
html("country", [qw(CA US BR)]);
}
=back
=head1 THE CONSTRUCTOR / INITIALIZER
=over 4
=item new(%hash)
This is the standard object-oriented constructor. When called, will return a new CGI::Framework instance. It accepts a hash (or a hashref) with the following keys:
=over 4
=item action
B<OPTIONAL>
If this key is supplied, it should contain the value to be used in the <form> HTML element's "action" parameter. If not supplied, it will default to environment variable SCRIPT_NAME
=item callbacks_namespace
B<OPTIONAL>
This key should have a scalar value with the name of the namespace that you will put all the validate_templatename(), pre_templatename(), post_templatename(), pre__pre__all(), post__pre__all(), pre__post__all() and post__post__all() subroutines in. ...
The main use of this option is to allow you, if you so choose, to place your callbacks subs into any arbitrary namespace you decide on (to avoid pollution of your main namespace for example).
=item cookie_domain
B<OPTIONAL>
The key should have a scalar value with the domain that cookie_name is set to. If not supplied the cookie will not be assigned to a specific domain, essentially making tied to the current hostname.
=item cookie_name
B<OPTIONAL>
This key should have a scalar value with the name of the cookie to use when communicating the session ID to the client. If not supplied, will default to "sessionid_" and a simplified representation of the URL.
=item disable_back_button
B<OPTIONAL>
This key should have a scalar value that's true (such as 1) or false (such as 0). Setting it to true will instruct the framework not to allow the user to use their browser's back button. This is done by setting no-cache pragmas on every page served...
This behaviour is often desired in time-sensitive web applications.
=item expire
B<OPTIONAL>
Set this to a value that will be passed to CGI::Session's expire() method. If supplied and contains non-digits (such as "+2h") it will be passed verbatim. If supplied and is digits only, it will be passed as minutes. If not supplied will default t...
=item fatal_error_email
B<OPTIONAL>
If you would like to receive an email when a fatal error occurs, supply this key with a value of either a scalar email address, or an arrayref of multiple email addresses. You will also need to supply the smtp_host key and/or the sendmail key.
=item fatal_error_template
B<OPTIONAL>
Normally fatal errors (caused by a die() anywhere in the program) are captured by CGI::Carp and sent to the browser along with the web server's error log file. If this key is supplied, it's value should be a template name. That template would then ...
=item initial_template
B<MANDATORY>
This key should have a scalar value with the name of the first template that will be shown to the client when the dispatch() method is called. It can be changed after initialization with the initial_template() method before the dispatch() method is ...
=item import_form
B<OPTIONAL>
This variable should have a scalar value with the name of a namespace in it. It imports all the values of the just-submitted form into the specified namespace. For example:
import_form => "FORM",
You can then use form elements like:
$error = "Sorry $FORM::firstname, you may not $FORM::action at this time.";
It provides a more flexible alternative to using the form() method since it can be interpolated inside double-quoted strings, however costs more memory. I am also unsure about how such a namespace would be handled under mod_perl and if it'll remain ...
=item log_filename
lib/CGI/Framework.pm view on Meta::CPAN
#
# Delete all values
#
$self->{_session}->clear();
#
# Restore preserved values
#
foreach (keys %preserve) {
$self->session($_, $preserve{$_});
}
return 1;
}
#
# This sub takes care of calling any validate_XYZ methods, displaying old page or requested page
# based on whether there were errors or not
#
sub dispatch {
my $self = _getself(\@_);
my $validate_template;
no strict 'refs';
#
# Validate the data entered:
#
if ($self->form("_sv")) {
#We skip validation as per requested
}
else {
if ($self->form("_template") && !$self->session("_lastsent")) {
#
# They are submitting a page but we don't have a lastsent template in session - they probably timed out
#
$self->_missinginfo();
}
if ($self->{disable_back_button} && $self->session("_lastsent")) {
#
# If disable_back_button is set, we always validate last template we sent them
#
$validate_template = $self->session("_lastsent");
}
elsif ($self->form("_template")) {
#
# Otherwise we validate the template they're submitting
#
$validate_template = $self->form("_template");
}
#
# We implement validation if possible
#
if ($validate_template && defined &{"$self->{callbacks_namespace}::validate_$validate_template"}) {
&{"$self->{callbacks_namespace}::validate_$validate_template"}($self);
if ($self->{_html}->{_errors}) {
#
# The validation didn't go so well and errors were recorded
# so we re-show the template the failed validation
#
$self->show_template($validate_template);
}
}
}
#
# If we reached here, we're all good and present the action they requested
#
$self->show_template($self->form("_action") || $self->{initial_template});
# Should not reach here
die "Something's wrong. You should not be seeing this.\n";
}
#
# Cleans up internal references to allow for destruction THEN EXITS
#
sub finalize {
undef $LASTINSTANCE;
set_message(undef);
exit;
}
#
# Takes a scalar key
# Returns the value for that key from the just-submitted form
#
sub form {
my $self = _getself(\@_);
my $key = shift;
my $value;
no strict 'refs';
if (length($key)) {
return $self->{_import_form} ? ${ $self->{_import_form} . '::' . $key } : $self->{_cgi}->param($key);
}
else {
return $self->{_cgi}->param();
}
}
#
# Returns the CGI object
#
sub get_cgi_object {
my $self = _getself(\@_);
return $self->{_cgi};
}
#
# Returns the CGI::Session object
#
sub get_cgi_session_object {
lib/CGI/Framework.pm view on Meta::CPAN
#
# Takes a scalar key and a scalar value
# Adds them to the html que
#
sub html {
my $self = _getself(\@_);
my $key = shift || croak "key not supplied";
my $value = shift;
$self->{_html}->{$key} = $value;
return 1;
}
#
# Takes a scalar key and a scalar value
# Pushes the value into the html element as an array
#
sub html_push {
my $self = _getself(\@_);
my $key = shift || croak "key not supplied";
my $value = shift;
my $existing_value = $self->{_html}->{$key} || [];
if (ref($existing_value) ne "ARRAY") {
croak "Key $key already exists as non-array. Cannot push into it.";
}
push(@{$existing_value}, $value);
$self->{_html}->{$key} = $existing_value;
return 1;
}
#
# Takes a scalar key and a scalar value
# Unshifts the value into the html element as an array
#
sub html_unshift {
my $self = _getself(\@_);
my $key = shift || croak "key not supplied";
my $value = shift;
my $existing_value = $self->{_html}->{$key} || [];
if (ref($existing_value) ne "ARRAY") {
croak "Key $key already exists as non-array. Cannot unshift into it.";
}
unshift(@{$existing_value}, $value);
$self->{_html}->{$key} = $existing_value;
return 1;
}
#
# Re-sets initial_template
#
sub initial_template {
my $self = _getself(\@_);
my $initial_template = shift || croak "initial template not supplied";
$self->{initial_template} = $initial_template;
}
#
# An alias to new(), to be used in nooop mode
#
sub initialize_cgi_framework {
my %para = ref($_[0]) eq "HASH" ? %{ $_[0] } : @_;
$para{callbacks_namespace} ||= (caller)[0] || "main";
return new("CGI::Framework", \%para);
}
#
# The constructor. Initializes pretty much everything, returns a new bless()ed instance
#
sub new {
my $class = shift || "CGI::Framework";
my %para = ref($_[0]) eq "HASH" ? %{ $_[0] } : @_;
my $self = {};
my $cookie_value;
my $temp;
my $expire;
my $sessions_driver;
my $sessions_serializer;
local (*FH);
$self = bless($self, ref($class) || $class);
#
# Paranoia: It should be clear anyways... but
#
if ($LASTINSTANCE) {
$LASTINSTANCE->finalize();
}
#
# Backwards compatability support
#
foreach (qw(callbacks_namespace cookie_name import_form initial_template sessions_dir templates_dir valid_languages)) {
$temp = $_;
$temp =~ s/_//g;
if (!exists $para{$_} && exists $para{$temp}) {
$para{$_} = $para{$temp};
delete $para{$temp};
}
}
#
# Custom fatal error handling
#
$para{fatal_error_email} && !$para{smtp_host} && !$para{sendmail} && croak "You must supply smtp_host and/or sendmail when supplying fatal_error_email";
if ($para{"fatal_error_template"} || $para{"fatal_error_email"}) {
set_message(
sub {
my $error = shift;
my $emailsent = 0;
my $errorsent = 0;
my $index;
my @callerparts;
my @stack;
local (*SMH);
#
# Hold your horses - some errors should just be ignored
#
if (exists $ENV{"HTTPS"} && $ENV{"HTTPS"} && $error =~ /^((103:)?Software caused connection abort)|((104:)?Connection reset by peer)/i) {
#
# This is generated by some braindead web browsers that do not properly terminate an SSL session
#
$self->finalize();
return ();
}
#
# Append stack to error message:
#
for ($index = 0 ; @callerparts = caller($index) ; $index++) {
push(@stack, "$callerparts[1]:$callerparts[2] ($callerparts[3])");
}
@stack = reverse @stack;
$error .= "\n\nStack trace appended by CGI::Framework fatal error handler:\n";
foreach (0 .. $#stack) {
$error .= " " x ($_ + 1);
$error .= $stack[$_];
$error .= "\n";
}
#
# Show something back to the web user regarding the error
# We do this first BEFORE sending off emails because under mod_perl, an open() to a pipe (sendmail) sends some
# crap to the browser - FIXME - NEEDS INVESTIGATING
#
if ($para{"fatal_error_template"}) {
eval {
$self->{_html}->{_fatal_error} = $error;
$self->show_template($para{"fatal_error_template"}, 1);
};
if (!$@) {
lib/CGI/Framework.pm view on Meta::CPAN
elsif ($@ =~ /mod_?perl/i && $@ =~ /exit/i) {
#
# Under mod_perl, an exit() (deep in finalize()) called inside an eval (above) gets thrown and therefore caught above
# so we treat it as success
#
$errorsent = 1;
}
}
if (!$errorsent) {
print "Content-type: text/html\n\n<h1>The following fatal error occurred:</h1><p><pre>$error</pre>\n";
}
#
# Now try to send the fatal error email
#
if (!$emailsent && $para{"fatal_error_email"} && $para{"sendmail"}) {
eval {
open(SMH, "| $para{sendmail} -t -i") || die "Failed to open pipe to sendmail: $!\n";
print SMH "From: " . ($para{"smtp_from"} || 'cgiframework@localhost') . "\n";
print SMH "To: ", (ref($para{"fatal_error_email"}) eq "ARRAY" ? join(",", @{ $para{"fatal_error_email"} }) : $para{"fatal_error_email"}), "\n";
print SMH "Subject: Fatal Error\n";
print SMH "X-CGI-Framework-Method: sendmail $para{sendmail}\n";
print SMH "X-CGI-Framework-REMOTE-ADDR: $ENV{REMOTE_ADDR}\n";
print SMH "X-CGI-Framework-PID: $$\n";
print SMH "\n";
print SMH "The following fatal error occurred:\n\n$error\n";
close(SMH);
};
$emailsent = 1 if !$@;
}
if (!$emailsent && $para{"fatal_error_email"} && $para{"smtp_host"}) {
eval {
require Net::SMTP;
my $smtp = Net::SMTP->new($para{"smtp_host"}) || die "Could not create Net::SMTP object: $@\n";
$smtp->mail($para{"smtp_from"} || 'cgiframework@localhost') || die "Could not send MAIL command: $@\n";
$smtp->recipient(ref($para{"fatal_error_email"}) eq "ARRAY" ? @{ $para{"fatal_error_email"} } : $para{"fatal_error_email"}) || die "Could not send RECIPIENT command: $@\n";
$smtp->data("X-CGI-Framework-Method: Net::SMTP $para{smtp_host}\nX-CGI-Framework-REMOTE-ADDR: $ENV{REMOTE_ADDR}\nX-CGI-Framework-PID: $$\n\nThe following fatal error occurred:\n\n$error") || die "Could not send DATA command: $@\n";
$smtp->quit();
};
$emailsent = 1 if !$@;
}
#
# Finally cleanup cruft:
#
$self->finalize();
}
);
}
#
# Some initial setup
#
$para{_html} = {};
#
# We set some defaults if unsupplied
#
$para{valid_languages} ||= [];
$para{callbacks_namespace} ||= (caller)[0] || "main";
if (!$para{cookie_name}) {
$para{cookie_name} = "sessionid_$ENV{SCRIPT_NAME}";
$para{cookie_name} =~ s/[^0-9a-z]//gi;
}
if (!$para{sessions_mysql_dbh} && !$para{sessions_dir}) {
#
# They didn't supply any sessions stuff, so let's take a guess at some directories for file-based storage:
#
foreach (qw(/tmp /var/tmp c:/tmp c:/temp c:/windows/temp)) {
if (-d $_) {
$para{sessions_dir} = $_;
last;
}
}
}
if (!$para{templates_dir}) {
foreach (qw(./templates ../templates)) {
if (-d $_) {
$para{templates_dir} = $_;
last;
}
}
}
if (!$para{sessions_serializer_default} && !$para{sessions_serializer_storable} && !$para{sessions_serializer_freezethaw}) {
$para{sessions_serializer_default} = 1;
}
#
# Now we do sanity checking
#
ref $para{valid_languages} eq "ARRAY" || croak "valid_languages must be an array ref";
if ($para{"maketext_class_name"}) {
@{ $para{valid_languages} } || croak "valid_languages must be set to at least one language to specify the maketext_class_name key";
}
$para{sessions_dir} && $para{sessions_mysql_dbh} && croak "Only one of sessions_dir and sessions_mysql_dbh may be supplied";
if ($para{sessions_dir}) {
#
# Supplied (or determined) file-based sessions storage
#
-e $para{sessions_dir} && !-d $para{sessions_dir} && croak "$para{sessions_dir} exists but is not a directory";
-d $para{sessions_dir} || mkdir($para{sessions_dir}, 0700) || croak "Failed to create $para{sessions_dir}: $!";
-w $para{sessions_dir} || croak "$para{sessions_dir} is not writable by me";
}
elsif ($para{sessions_mysql_dbh}) {
#
# Supplied mysql-based sessions storage
# Should be a reference to mysql object - but I'll just make sure it's *a* reference to something
#
ref($para{sessions_mysql_dbh}) || croak "Invalid sessions_mysql_dbh supplied";
}
else {
croak "Neither sessions_dir or sessions_mysql_dbh were supplied, and could not automatically determine a suitable sessions_dir";
}
if ((grep { $para{$_} } qw(sessions_serializer_default sessions_serializer_storable sessions_serializer_freezethaw)) > 1) {
croak "Only one of sessions_serializer_default, sessions_serializer_storable and sessions_serializer_freezethaw may be supplied";
}
$para{templates_dir} || croak "templates_dir must be supplied";
-d $para{templates_dir} || croak "$para{templates_dir} does not exist or is not a directory";
-f "$para{templates_dir}/errors.html" || croak "Templates directory $para{templates_dir} does not contain the mandatory errors.html template";
$para{initial_template} || croak "initial_template not supplied";
if ($para{log_filename}) {
open(FH, ">>$para{log_filename}") || croak "Log filename $para{log_filename} is not writeable by me: $@";
close(FH);
}
if ($para{output_filter}) {
if (ref($para{output_filter}) eq "CODE") {
#
# It's a code ref - good
#
}
elsif (defined &{"$self->{callbacks_namespace}::$para{output_filter}"}) {
#
# It's a sub name that exists. good
#
$para{output_filter} = &{"$self->{callbacks_namespace}::$para{output_filter}"};
}
else {
croak "Output filter not a code ref and not a sub name that I can find";
}
}
#
# And now some initialization
#
$self->{action} = $para{action};
$self->{valid_languages} = $para{valid_languages};
$self->{templates_dir} = $para{templates_dir};
$self->{initial_template} = $para{initial_template};
$self->{callbacks_namespace} = $para{callbacks_namespace};
$self->{log_filename} = $para{log_filename};
$self->{disable_back_button} = $para{disable_back_button};
$self->{output_filter} = $para{output_filter};
$self->{_cgi} = new CGI || die "Failed to create a new CGI instance: $! $@\n";
$cookie_value = $self->{_cgi}->cookie($para{cookie_name}) || undef;
if ($para{"maketext_class_name"}) {
undef $@;
eval { eval("require $para{'maketext_class_name'};") || die "Failed to require() $para{'maketext_class_name'}: $! $@"; };
if ($@) {
croak "Could not properly initialize maketext_class_name ($para{'maketext_class_name'}): $@";
}
else {
$self->{maketext_class_name} = $para{"maketext_class_name"};
}
}
#
# Initialize session object
#
if ($para{sessions_dir}) {
$sessions_driver = "File";
}
else {
$sessions_driver = "MySQL";
}
if ($para{sessions_serializer_storable}) {
$sessions_serializer = "Storable";
}
elsif ($para{sessions_serializer_freezethaw}) {
$sessions_serializer = "FreezeThaw";
}
else {
$sessions_serializer = "Default";
}
$self->{_session} = new CGI::Session(
"driver:$sessions_driver;serializer:$sessions_serializer",
$cookie_value,
{
Handle => $para{sessions_mysql_dbh},
Directory => $para{sessions_dir},
}
)
|| die "Failed to create new CGI::Session instance with $sessions_driver - based storage and $sessions_serializer - based serialization: $! $@\n";
if ($para{"import_form"}) {
$self->{_cgi}->import_names($para{"import_form"});
$self->{_import_form} = $para{"import_form"};
}
if (!$cookie_value || ($self->{_session}->id() ne $cookie_value)) {
# We just created a new session - send it to the user
print "Set-Cookie: $para{cookie_name}=", $self->{_session}->id(), ($para{cookie_domain} ? "; domain=" . $para{cookie_domain} : ""), "\n";
}
$expire = $para{"expire"} ? ($para{"expire"} =~ /[^0-9]/ ? $para{"expire"} : "+$para{expire}m") : "+15m";
$self->{_session}->expire($expire);
#
# Language handling
lib/CGI/Framework.pm view on Meta::CPAN
}
document.myform.submit();
return false;
}
function checksubmit() {
if (document.myform._action.value == "") {
return false;
}
else {
return true;
}
}
// -->
</script>
<form name="myform" method="POST" enctype="multipart/form-data" action="$action" onSubmit="return checksubmit();">
<input type="hidden" name="_action" value="">
<input type="hidden" name="_item" value="">
<input type="hidden" name="_sv" value="">
<input type="hidden" name="_template" value="$template_name">
<!-- CGI::Framework END HEADER -->
EOM
$footer = <<"EOM";
<!-- CGI::Framework BEGIN FOOTER -->
</form>
<!-- CGI::Framework END FOOTER -->
EOM
$output =~ s/<cgi_framework_header>/$header/i;
$output =~ s/<cgi_framework_footer>/$footer/i;
}
return wantarray ? ($output, $content_type) : $output;
}
#
# Takes a scalar key, and an optional value
# Gives them to the param() method of CGI::Session
#
sub session {
my $self = _getself(\@_);
my $key = shift || croak "key not supplied";
my $value = shift;
return defined($value) ? $self->{_session}->param($key, $value) : $self->{_session}->param($key);
}
#
# Takes a template name
# Calls pre__pre__all() and pre_templatename() and post__pre__all()
# Shows it
# Calls pre__post__all() and post_templatename() and post__post__all()
# THEN EXITS
#
sub show_template {
my $self = _getself(\@_);
my $template_name = shift || croak "Template name not supplied";
my $nofinalize = shift;
my $content;
my $content_type;
no strict 'refs';
if (defined &{"$self->{callbacks_namespace}::pre__pre__all"}) {
#
# Execute a pre__pre__all
#
&{"$self->{callbacks_namespace}::pre__pre__all"}($self, $template_name);
}
if (defined &{"$self->{callbacks_namespace}::pre_$template_name"}) {
#
# Execute a pre_ for this template
#
&{"$self->{callbacks_namespace}::pre_$template_name"}($self, $template_name);
}
if (defined &{"$self->{callbacks_namespace}::post__pre__all"}) {
#
# Execute a post__pre__all
#
&{"$self->{callbacks_namespace}::post__pre__all"}($self, $template_name);
}
#
# Parse template
#
($content, $content_type) = $self->return_template($template_name);
#
# Implement outbound filter
#
if ($self->{output_filter}) {
&{ $self->{output_filter} }($self, \$content);
}
#
# Send content
#
print "Content-type: $content_type\n";
if ($self->{disable_back_button}) {
print "Cache-control: no-cache\n";
print "Pragma: no-cache\n";
print "Expires: Thu, 01 Dec 1994 16:00:00 GMT\n";
}
print "\n";
print $content;
$self->session("_lastsent", $template_name);
if (defined &{"$self->{callbacks_namespace}::pre__post__all"}) {
#
# Execute a pre__post__all
#
&{"$self->{callbacks_namespace}::pre__post__all"}($self, $template_name);
}
if (defined &{"$self->{callbacks_namespace}::post_$template_name"}) {
#
# Execute a post_ for this template
#
&{"$self->{callbacks_namespace}::post_$template_name"}($self);
}
if (defined &{"$self->{callbacks_namespace}::post__post__all"}) {
#
# Execute a post__post__all
#
&{"$self->{callbacks_namespace}::post__post__all"}($self, $template_name);
}
if (!$nofinalize) {
$self->finalize();
}
}
#
# This sub takes whatever's passed to it and
# records it in the log file
#
sub log_this {
my $self = _getself(\@_);
my $message = shift;
my $filename = $self->{log_filename} || croak "Can not use log_this since no log_filename was defined in the constructor";
local (*FH);
$message =~ s/[\n\r]/-/g;
open(FH, ">>$filename") || die "Error opening $filename: $!\n";
flock(FH, LOCK_EX);
seek(FH, 0, 2);
print FH scalar(localtime), " : ", $ENV{'REMOTE_ADDR'}, " : ", $ENV{"SCRIPT_NAME"}, " : ", $message, "\n";
flock(FH, LOCK_UN);
close(FH);
return (1);
}
#
# Takes a scalar
# Returns it's localized version
# or exact same unmodified string if localization is not applicable in current session
#
sub localize {
my $self = _getself(\@_);
my $string = shift || croak "string not supplied to localize";
my @parameters = @_;
my $localized;
my $language;
$self->{"maketext_class_name"} || return $string;
if (!$self->{_language_handle}) {
foreach $language (@{ $self->{valid_languages} }) {
if ($self->session("_lang") eq $language) {
undef $@;
eval { eval('$self->{_language_handle} = ' . $self->{'maketext_class_name'} . '->get_handle( "' . $language . '" );') || die "Failed to get_handle() from $self->{'maketext_class_name'}: $! $@"; };
die $@ if $@;
last;
}
}
}
$localized = $self->{_language_handle}->maketext($string, @parameters);
return $localized;
}
############################################################################
#
# PRIVATE SUBS START HERE
#
# Takes a templatename
# If found, returns templatefilename, contenttype if wantarray and just the filename in scalar mode
( run in 0.549 second using v1.01-cache-2.11-cpan-39bf76dae61 )