r26609 - in /branches/upstream/libcgi-application-perl/current: Changes MANIFEST lib/CGI/Application.pm t/default_runmode.t
jaldhar at users.alioth.debian.org
jaldhar at users.alioth.debian.org
Mon Nov 3 20:52:38 UTC 2008
Author: jaldhar
Date: Mon Nov 3 20:52:35 2008
New Revision: 26609
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=26609
Log:
[svn-upgrade] Integrating new upstream version, libcgi-application-perl (4.20)
Added:
branches/upstream/libcgi-application-perl/current/t/default_runmode.t
Modified:
branches/upstream/libcgi-application-perl/current/Changes
branches/upstream/libcgi-application-perl/current/MANIFEST
branches/upstream/libcgi-application-perl/current/lib/CGI/Application.pm
Modified: branches/upstream/libcgi-application-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcgi-application-perl/current/Changes?rev=26609&op=diff
==============================================================================
--- branches/upstream/libcgi-application-perl/current/Changes (original)
+++ branches/upstream/libcgi-application-perl/current/Changes Mon Nov 3 20:52:35 2008
@@ -1,4 +1,29 @@
Revision history for CGI::Application.
+
+4.20 Sat Nov 1, 2008
+
+ [DOCUMENTATION]
+ - typo fix (Lyle)
+
+4.19_1 Fri Sep 27, 2008
+
+ [FEATURES]
+ - New 'html_tmpl_class' method allows you to specify an alternative
+ HTML::Template class. This technique will eliminate the need to use
+ a plugin for HTML::Template-compatible classes. See the docs
+ for load_tmpl() for details.
+
+ Thanks to Rhesa Rozendaal for the initial patch, and Mark Stosberg for
+ documentation refinements.
+
+ [DOCUMENTATION]
+ - typo fix (George Hartzell)
+ - Revert back to documenting the use of "$self", not $c, after community
+ feedback.
+
+ [INTERNALS]
+ - Change how default run modes are declared for better compatibility
+ with AutoRunmode and RunmodeDeclare plugins. Thanks Rhesa via RT#39631.
4.11 Sun Aug 10, 2008
No code changes.
Modified: branches/upstream/libcgi-application-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcgi-application-perl/current/MANIFEST?rev=26609&op=diff
==============================================================================
--- branches/upstream/libcgi-application-perl/current/MANIFEST (original)
+++ branches/upstream/libcgi-application-perl/current/MANIFEST Mon Nov 3 20:52:35 2008
@@ -13,6 +13,7 @@
Makefile.PL
README
t/basic.t
+t/default_runmode.t
t/mailform.t
t/prerun.t
t/getquery.t
Modified: branches/upstream/libcgi-application-perl/current/lib/CGI/Application.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcgi-application-perl/current/lib/CGI/Application.pm?rev=26609&op=diff
==============================================================================
--- branches/upstream/libcgi-application-perl/current/lib/CGI/Application.pm (original)
+++ branches/upstream/libcgi-application-perl/current/lib/CGI/Application.pm Mon Nov 3 20:52:35 2008
@@ -3,7 +3,7 @@
use strict;
use Class::ISA;
-$CGI::Application::VERSION = '4.11';
+$CGI::Application::VERSION = '4.20';
my %INSTALLED_CALLBACKS = (
# hook name package sub
@@ -29,34 +29,34 @@
}
# Create our object!
- my $c = {};
- bless($c, $class);
+ my $self = {};
+ bless($self, $class);
### SET UP DEFAULT VALUES ###
#
# We set them up here and not in the setup() because a subclass
# which implements setup() still needs default values!
- $c->header_type('header');
- $c->mode_param('rm');
- $c->start_mode('start');
+ $self->header_type('header');
+ $self->mode_param('rm');
+ $self->start_mode('start');
# Process optional new() parameters
my $rprops;
if (ref($args[0]) eq 'HASH') {
- $rprops = $c->_cap_hash($args[0]);
+ $rprops = $self->_cap_hash($args[0]);
} else {
- $rprops = $c->_cap_hash({ @args });
+ $rprops = $self->_cap_hash({ @args });
}
# Set tmpl_path()
if (exists($rprops->{TMPL_PATH})) {
- $c->tmpl_path($rprops->{TMPL_PATH});
+ $self->tmpl_path($rprops->{TMPL_PATH});
}
# Set CGI query object
if (exists($rprops->{QUERY})) {
- $c->query($rprops->{QUERY});
+ $self->query($rprops->{QUERY});
}
# Set up init param() values
@@ -64,33 +64,33 @@
croak("PARAMS is not a hash ref") unless (ref($rprops->{PARAMS}) eq 'HASH');
my $rparams = $rprops->{PARAMS};
while (my ($k, $v) = each(%$rparams)) {
- $c->param($k, $v);
+ $self->param($k, $v);
}
}
# Lock prerun_mode from being changed until cgiapp_prerun()
- $c->{__PRERUN_MODE_LOCKED} = 1;
+ $self->{__PRERUN_MODE_LOCKED} = 1;
# Call cgiapp_init() method, which may be implemented in the sub-class.
# Pass all constructor args forward. This will allow flexible usage
# down the line.
- $c->call_hook('init', @args);
+ $self->call_hook('init', @args);
# Call setup() method, which should be implemented in the sub-class!
- $c->setup();
-
- return $c;
+ $self->setup();
+
+ return $self;
}
sub __get_runmode {
- my $c = shift;
+ my $self = shift;
my $rm_param = shift;
my $rm;
# Support call-back instead of CGI mode param
if (ref($rm_param) eq 'CODE') {
# Get run mode from subref
- $rm = $rm_param->($c);
+ $rm = $rm_param->($self);
}
# support setting run mode from PATH_INFO
elsif (ref($rm_param) eq 'HASH') {
@@ -98,24 +98,24 @@
}
# Get run mode from CGI param
else {
- $rm = $c->query->param($rm_param);
+ $rm = $self->query->param($rm_param);
}
# If $rm undefined, use default (start) mode
- $rm = $c->start_mode unless defined($rm) && length($rm);
+ $rm = $self->start_mode unless defined($rm) && length($rm);
return $rm;
}
sub __get_runmeth {
- my $c = shift;
+ my $self = shift;
my $rm = shift;
my $rmeth;
my $is_autoload = 0;
- my %rmodes = ($c->run_modes());
+ my %rmodes = ($self->run_modes());
if (exists($rmodes{$rm})) {
$rmeth = $rmodes{$rm};
}
@@ -132,20 +132,20 @@
}
sub __get_body {
- my $c = shift;
+ my $self = shift;
my $rm = shift;
- my ($rmeth, $is_autoload) = $c->__get_runmeth($rm);
+ my ($rmeth, $is_autoload) = $self->__get_runmeth($rm);
my $body;
eval {
- $body = $is_autoload ? $c->$rmeth($rm) : $c->$rmeth();
+ $body = $is_autoload ? $self->$rmeth($rm) : $self->$rmeth();
};
if ($@) {
my $error = $@;
- $c->call_hook('error', $error);
- if (my $em = $c->error_mode) {
- $body = $c->$em( $error );
+ $self->call_hook('error', $error);
+ if (my $em = $self->error_mode) {
+ $body = $self->$em( $error );
} else {
croak("Error executing run mode '$rm': $error");
}
@@ -158,45 +158,45 @@
sub run {
- my $c = shift;
- my $q = $c->query();
-
- my $rm_param = $c->mode_param();
-
- my $rm = $c->__get_runmode($rm_param);
+ my $self = shift;
+ my $q = $self->query();
+
+ my $rm_param = $self->mode_param();
+
+ my $rm = $self->__get_runmode($rm_param);
# Set get_current_runmode() for access by user later
- $c->{__CURRENT_RUNMODE} = $rm;
+ $self->{__CURRENT_RUNMODE} = $rm;
# Allow prerun_mode to be changed
- delete($c->{__PRERUN_MODE_LOCKED});
+ delete($self->{__PRERUN_MODE_LOCKED});
# Call PRE-RUN hook, now that we know the run mode
# This hook can be used to provide run mode specific behaviors
# before the run mode actually runs.
- $c->call_hook('prerun', $rm);
+ $self->call_hook('prerun', $rm);
# Lock prerun_mode from being changed after cgiapp_prerun()
- $c->{__PRERUN_MODE_LOCKED} = 1;
+ $self->{__PRERUN_MODE_LOCKED} = 1;
# If prerun_mode has been set, use it!
- my $prerun_mode = $c->prerun_mode();
+ my $prerun_mode = $self->prerun_mode();
if (length($prerun_mode)) {
$rm = $prerun_mode;
- $c->{__CURRENT_RUNMODE} = $rm;
+ $self->{__CURRENT_RUNMODE} = $rm;
}
# Process run mode!
- my $body = $c->__get_body($rm);
+ my $body = $self->__get_body($rm);
# Support scalar-ref for body return
$body = $$body if ref $body eq 'SCALAR';
# Call cgiapp_postrun() hook
- $c->call_hook('postrun', \$body);
+ $self->call_hook('postrun', \$body);
# Set up HTTP headers
- my $headers = $c->_send_headers();
+ my $headers = $self->_send_headers();
# Build up total output
my $output = $headers.$body;
@@ -207,7 +207,7 @@
}
# clean up operations
- $c->call_hook('teardown');
+ $self->call_hook('teardown');
return $output;
}
@@ -218,7 +218,7 @@
############################
sub cgiapp_get_query {
- my $c = shift;
+ my $self = shift;
# Include CGI.pm and related modules
require CGI;
@@ -231,7 +231,7 @@
sub cgiapp_init {
- my $c = shift;
+ my $self = shift;
my @args = (@_);
# Nothing to init, yet!
@@ -239,7 +239,7 @@
sub cgiapp_prerun {
- my $c = shift;
+ my $self = shift;
my $rm = shift;
# Nothing to prerun, yet!
@@ -247,7 +247,7 @@
sub cgiapp_postrun {
- my $c = shift;
+ my $self = shift;
my $bodyref = shift;
# Nothing to postrun, yet!
@@ -255,16 +255,12 @@
sub setup {
- my $c = shift;
-
- $c->run_modes(
- 'start' => 'dump_html',
- );
+ my $self = shift;
}
sub teardown {
- my $c = shift;
+ my $self = shift;
# Nothing to shut down, yet!
}
@@ -277,19 +273,19 @@
######################################
sub dump {
- my $c = shift;
+ my $self = shift;
my $output = '';
# Dump run mode
- my $current_runmode = $c->get_current_runmode();
+ my $current_runmode = $self->get_current_runmode();
$current_runmode = "" unless (defined($current_runmode));
$output .= "Current Run mode: '$current_runmode'\n";
# Dump Params
$output .= "\nQuery Parameters:\n";
- my @params = $c->query->param();
+ my @params = $self->query->param();
foreach my $p (sort(@params)) {
- my @data = $c->query->param($p);
+ my @data = $self->query->param($p);
my $data_str = "'".join("', '", @data)."'";
$output .= "\t$p => $data_str\n";
}
@@ -305,12 +301,12 @@
sub dump_html {
- my $c = shift;
- my $query = $c->query();
+ my $self = shift;
+ my $query = $self->query();
my $output = '';
# Dump run-mode
- my $current_runmode = $c->get_current_runmode();
+ my $current_runmode = $self->get_current_runmode();
$output .= "<p>Current Run-mode:
'<strong>$current_runmode</strong>'</p>\n";
@@ -334,31 +330,31 @@
sub header_add {
- my $c = shift;
- return $c->_header_props_update(\@_,add=>1);
+ my $self = shift;
+ return $self->_header_props_update(\@_,add=>1);
}
sub header_props {
- my $c = shift;
- return $c->_header_props_update(\@_,add=>0);
+ my $self = shift;
+ return $self->_header_props_update(\@_,add=>0);
}
# used by header_props and header_add to update the headers
sub _header_props_update {
- my $c = shift;
+ my $self = shift;
my $data_ref = shift;
my %in = @_;
my @data = @$data_ref;
# First use? Create new __HEADER_PROPS!
- $c->{__HEADER_PROPS} = {} unless (exists($c->{__HEADER_PROPS}));
+ $self->{__HEADER_PROPS} = {} unless (exists($self->{__HEADER_PROPS}));
my $props;
# If data is provided, set it!
if (scalar(@data)) {
- if ($c->header_type eq 'none') {
+ if ($self->header_type eq 'none') {
warn "header_props called while header_type set to 'none', headers will NOT be sent!"
}
# Is it a hash, or hash-ref?
@@ -376,55 +372,55 @@
# merge in new headers, appending new values passed as array refs
if ($in{add}) {
for my $key_set_to_aref (grep { ref $props->{$_} eq 'ARRAY'} keys %$props) {
- my $existing_val = $c->{__HEADER_PROPS}->{$key_set_to_aref};
+ my $existing_val = $self->{__HEADER_PROPS}->{$key_set_to_aref};
next unless defined $existing_val;
my @existing_val_array = (ref $existing_val eq 'ARRAY') ? @$existing_val : ($existing_val);
$props->{$key_set_to_aref} = [ @existing_val_array, @{ $props->{$key_set_to_aref} } ];
}
- $c->{__HEADER_PROPS} = { %{ $c->{__HEADER_PROPS} }, %$props };
+ $self->{__HEADER_PROPS} = { %{ $self->{__HEADER_PROPS} }, %$props };
}
# Set new headers, clobbering existing values
else {
- $c->{__HEADER_PROPS} = $props;
+ $self->{__HEADER_PROPS} = $props;
}
}
# If we've gotten this far, return the value!
- return (%{ $c->{__HEADER_PROPS}});
+ return (%{ $self->{__HEADER_PROPS}});
}
sub header_type {
- my $c = shift;
+ my $self = shift;
my ($header_type) = @_;
my @allowed_header_types = qw(header redirect none);
# First use? Create new __HEADER_TYPE!
- $c->{__HEADER_TYPE} = 'header' unless (exists($c->{__HEADER_TYPE}));
+ $self->{__HEADER_TYPE} = 'header' unless (exists($self->{__HEADER_TYPE}));
# If data is provided, set it!
if (defined($header_type)) {
$header_type = lc($header_type);
croak("Invalid header_type '$header_type'")
unless(grep { $_ eq $header_type } @allowed_header_types);
- $c->{__HEADER_TYPE} = $header_type;
+ $self->{__HEADER_TYPE} = $header_type;
}
# If we've gotten this far, return the value!
- return $c->{__HEADER_TYPE};
+ return $self->{__HEADER_TYPE};
}
sub param {
- my $c = shift;
+ my $self = shift;
my (@data) = (@_);
# First use? Create new __PARAMS!
- $c->{__PARAMS} = {} unless (exists($c->{__PARAMS}));
-
- my $rp = $c->{__PARAMS};
+ $self->{__PARAMS} = {} unless (exists($self->{__PARAMS}));
+
+ my $rp = $self->{__PARAMS};
# If data is provided, set it!
if (scalar(@data)) {
@@ -453,47 +449,47 @@
sub delete {
- my $c = shift;
+ my $self = shift;
my ($param) = @_;
# return undef it the param name isn't given
return undef unless defined $param;
- #simply delete this param from $c->{__PARAMS}
- delete $c->{__PARAMS}->{$param};
+ #simply delete this param from $self->{__PARAMS}
+ delete $self->{__PARAMS}->{$param};
}
sub query {
- my $c = shift;
+ my $self = shift;
my ($query) = @_;
# We're only allowed to set a new query object if one does not yet exist!
- unless (exists($c->{__QUERY_OBJ})) {
+ unless (exists($self->{__QUERY_OBJ})) {
my $new_query_obj;
# If data is provided, set it! Otherwise, create a new one.
if (defined($query)) {
$new_query_obj = $query;
} else {
- $new_query_obj = $c->cgiapp_get_query();
+ $new_query_obj = $self->cgiapp_get_query();
}
- $c->{__QUERY_OBJ} = $new_query_obj;
- }
-
- return $c->{__QUERY_OBJ};
+ $self->{__QUERY_OBJ} = $new_query_obj;
+ }
+
+ return $self->{__QUERY_OBJ};
}
sub run_modes {
- my $c = shift;
+ my $self = shift;
my (@data) = (@_);
# First use? Create new __RUN_MODES!
- $c->{__RUN_MODES} = {} unless (exists($c->{__RUN_MODES}));
-
- my $rr_m = $c->{__RUN_MODES};
+ $self->{__RUN_MODES} = { 'start' => 'dump_html' } unless (exists($self->{__RUN_MODES}));
+
+ my $rr_m = $self->{__RUN_MODES};
# If data is provided, set it!
if (scalar(@data)) {
@@ -520,83 +516,83 @@
sub start_mode {
- my $c = shift;
+ my $self = shift;
my ($start_mode) = @_;
# First use? Create new __START_MODE
- $c->{__START_MODE} = 'start' unless (exists($c->{__START_MODE}));
+ $self->{__START_MODE} = 'start' unless (exists($self->{__START_MODE}));
# If data is provided, set it
if (defined($start_mode)) {
- $c->{__START_MODE} = $start_mode;
- }
-
- return $c->{__START_MODE};
+ $self->{__START_MODE} = $start_mode;
+ }
+
+ return $self->{__START_MODE};
}
sub error_mode {
- my $c = shift;
+ my $self = shift;
my ($error_mode) = @_;
# First use? Create new __ERROR_MODE
- $c->{__ERROR_MODE} = undef unless (exists($c->{__ERROR_MODE}));
+ $self->{__ERROR_MODE} = undef unless (exists($self->{__ERROR_MODE}));
# If data is provided, set it.
if (defined($error_mode)) {
- $c->{__ERROR_MODE} = $error_mode;
- }
-
- return $c->{__ERROR_MODE};
+ $self->{__ERROR_MODE} = $error_mode;
+ }
+
+ return $self->{__ERROR_MODE};
}
sub tmpl_path {
- my $c = shift;
+ my $self = shift;
my ($tmpl_path) = @_;
# First use? Create new __TMPL_PATH!
- $c->{__TMPL_PATH} = '' unless (exists($c->{__TMPL_PATH}));
+ $self->{__TMPL_PATH} = '' unless (exists($self->{__TMPL_PATH}));
# If data is provided, set it!
if (defined($tmpl_path)) {
- $c->{__TMPL_PATH} = $tmpl_path;
+ $self->{__TMPL_PATH} = $tmpl_path;
}
# If we've gotten this far, return the value!
- return $c->{__TMPL_PATH};
+ return $self->{__TMPL_PATH};
}
sub prerun_mode {
- my $c = shift;
+ my $self = shift;
my ($prerun_mode) = @_;
# First use? Create new __PRERUN_MODE
- $c->{__PRERUN_MODE} = '' unless (exists($c->{__PRERUN_MODE}));
+ $self->{__PRERUN_MODE} = '' unless (exists($self->{__PRERUN_MODE}));
# Was data provided?
if (defined($prerun_mode)) {
# Are we allowed to set prerun_mode?
- if (exists($c->{__PRERUN_MODE_LOCKED})) {
+ if (exists($self->{__PRERUN_MODE_LOCKED})) {
# Not allowed! Throw an exception.
croak("prerun_mode() can only be called within cgiapp_prerun()! Error");
} else {
# If data is provided, set it!
- $c->{__PRERUN_MODE} = $prerun_mode;
+ $self->{__PRERUN_MODE} = $prerun_mode;
}
}
# If we've gotten this far, return the value!
- return $c->{__PRERUN_MODE};
+ return $self->{__PRERUN_MODE};
}
sub get_current_runmode {
- my $c = shift;
+ my $self = shift;
# It's OK if we return undef if this method is called too early
- return $c->{__CURRENT_RUNMODE};
+ return $self->{__CURRENT_RUNMODE};
}
@@ -609,13 +605,13 @@
sub _send_headers {
- my $c = shift;
- my $q = $c->query;
- my $type = $c->header_type;
+ my $self = shift;
+ my $q = $self->query;
+ my $type = $self->header_type;
return
- $type eq 'redirect' ? $q->redirect( $c->header_props )
- : $type eq 'header' ? $q->header ( $c->header_props )
+ $type eq 'redirect' ? $q->redirect( $self->header_props )
+ : $type eq 'header' ? $q->header ( $self->header_props )
: $type eq 'none' ? ''
: croak "Invalid header_type '$type'"
}
@@ -626,7 +622,7 @@
# have come to rely on it, so any changes here should be
# made with great care or avoided.
sub _cap_hash {
- my $c = shift;
+ my $self = shift;
my $rhash = shift;
my %hash = map {
my $k = $_;
@@ -658,10 +654,10 @@
# ( setup() can even be skipped for common cases. See docs below. )
sub setup {
- my $c = shift;
- $c->start_mode('mode1');
- $c->mode_param('rm');
- $c->run_modes(
+ my $self = shift;
+ $self->start_mode('mode1');
+ $self->mode_param('rm');
+ $self->run_modes(
'mode1' => 'do_stuff',
'mode2' => 'do_more_stuff',
'mode3' => 'do_something_else'
@@ -687,7 +683,7 @@
CGI::Application judiciously avoids employing technologies and techniques which
would bind a developer to any one set of tools, operating system or web server.
-It is lightweight in turns of memory usage, making it suitable for common CGI
+It is lightweight in terms of memory usage, making it suitable for common CGI
environments, and a high performance choice in persistent environments like
FastCGI or mod_perl.
@@ -737,30 +733,30 @@
use CGI::Application::Plugin::DBH;
sub setup {
- my $c = shift;
- $c->start_mode('mode1');
- $c->run_modes(
+ my $self = shift;
+ $self->start_mode('mode1');
+ $self->run_modes(
'mode1' => 'showform',
'mode2' => 'showlist',
'mode3' => 'showdetail'
);
# Connect to DBI database, with the same args as DBI->connect();
- $c->dbh_config();
+ $self->dbh_config();
}
sub teardown {
- my $c = shift;
+ my $self = shift;
# Disconnect when we're done, (Although DBI usually does this automatically)
- $c->dbh->disconnect();
+ $self->dbh->disconnect();
}
sub showform {
- my $c = shift;
+ my $self = shift;
# Get CGI query object
- my $q = $c->query();
+ my $q = $self->query();
my $output = '';
$output .= $q->start_html(-title => 'Widget Search Form');
@@ -775,13 +771,13 @@
}
sub showlist {
- my $c = shift;
+ my $self = shift;
# Get our database connection
- my $dbh = $c->dbh();
+ my $dbh = $self->dbh();
# Get CGI query object
- my $q = $c->query();
+ my $q = $self->query();
my $widgetcode = $q->param("widgetcode");
my $output = '';
@@ -806,13 +802,13 @@
}
sub showdetail {
- my $c = shift;
+ my $self = shift;
# Get our database connection
- my $dbh = $c->dbh();
+ my $dbh = $self->dbh();
# Get CGI query object
- my $q = $c->query();
+ my $q = $self->query();
my $widgetid = $q->param("widgetid");
my $output = '';
@@ -951,8 +947,8 @@
my $app = WebApp->new(PARAMS => { cfg_file => 'config.pl' });
# Later in your app:
- my %cfg = $c->cfg()
- # or ... $c->cfg('HTML_ROOT_DIR');
+ my %cfg = $self->cfg()
+ # or ... $self->cfg('HTML_ROOT_DIR');
See the list of of plugins below for more config file integration solutions.
@@ -1001,17 +997,17 @@
Your setup() method might be implemented something like this:
sub setup {
- my $c = shift;
- $c->tmpl_path('/path/to/my/templates/');
- $c->start_mode('putform');
- $c->error_mode('my_error_rm');
- $c->run_modes({
+ my $self = shift;
+ $self->tmpl_path('/path/to/my/templates/');
+ $self->start_mode('putform');
+ $self->error_mode('my_error_rm');
+ $self->run_modes({
'putform' => 'my_putform_func',
'postdata' => 'my_data_func'
});
- $c->param('myprop1');
- $c->param('myprop2', 'prop2value');
- $c->param('myprop3', ['p3v1', 'p3v2', 'p3v3']);
+ $self->param('myprop1');
+ $self->param('myprop2', 'prop2value');
+ $self->param('myprop3', ['p3v1', 'p3v2', 'p3v3']);
}
However, often times all that needs to be in setup() is defining your run modes
@@ -1050,7 +1046,7 @@
package MySuperclass;
use base 'CGI::Application';
sub cgiapp_init {
- my $c = shift;
+ my $self = shift;
# Perform some project-specific init behavior
# such as to load settings from a database or file.
}
@@ -1088,7 +1084,7 @@
package MySuperclass;
use base 'CGI::Application';
sub cgiapp_prerun {
- my $c = shift;
+ my $self = shift;
# Perform some project-specific init behavior
# such as to implement run mode specific
# authorization functions.
@@ -1139,7 +1135,7 @@
cgiapp_postrun() method might be implemented as follows:
sub cgiapp_postrun {
- my $c = shift;
+ my $self = shift;
my $output_ref = shift;
# Enclose output HTML table
@@ -1248,12 +1244,28 @@
L<CGI::Application::Plugin::Stream> can help if you want to return a stream and
not a file. It features a simple syntax and MIME-type detection.
+B<specifying the template class with html_tmpl_class()>
+
+You may specify an API-compatible alternative to HTML::Template by overriding
+C<html_tmpl_class()>. This method should return the class name of your template
+system. The default simply returns "HTML::Template". The alternate class should
+provide at least the following parts of the HTML::Template API:
+
+ $t = $class->new( scalarref => ... ); # If you use scalarref templates
+ $t = $class->new( filehandle => ... ); # If you use filehandle templates
+ $t = $class->new( filename => ... );
+ $t->param(...);
+
+Example implementation:
+
+ sub html_tmpl_class { 'HTML::Template::Pro' }
+
B<The load_tmpl() callback>
Plugin authors will be interested to know that you can register a callback that
will be executed just before load_tmpl() returns:
- $c->add_callback('load_tmpl',\&your_method);
+ $self->add_callback('load_tmpl',\&your_method);
When C<your_method()> is executed, it will be passed three arguments:
@@ -1432,7 +1444,7 @@
behavior, it is possible to catch this exception by implementing
a run mode with the reserved name "AUTOLOAD":
- $c->run_modes(
+ $self->run_modes(
"AUTOLOAD" => \&catch_my_exception
);
@@ -1442,7 +1454,7 @@
receive, as an argument, the name of the run mode which invoked it:
sub catch_my_exception {
- my $c = shift;
+ my $self = shift;
my $intended_runmode = shift;
my $output = "Looking for '$intended_runmode', but found 'AUTOLOAD' instead";
@@ -1607,15 +1619,15 @@
B<Example of redirecting>:
sub some_redirect_mode {
- my $c = shift;
+ my $self = shift;
# do stuff here....
- $c->header_type('redirect');
- $c->header_props(-url=> "http://site/path/doc.html" );
+ $self->header_type('redirect');
+ $self->header_props(-url=> "http://site/path/doc.html" );
}
To simplify that further, use L<CGI::Application::Plugin::Redirect>:
- return $c->redirect('http://www.example.com/');
+ return $self->redirect('http://www.example.com/');
Setting the header to 'none' may be useful if you are streaming content.
In other contexts, it may be more useful to set C<$ENV{CGI_APP_RETURN_ONLY} = 1;>,
@@ -1626,12 +1638,14 @@
=cut
+sub html_tmpl_class { 'HTML::Template' }
+
sub load_tmpl {
- my $c = shift;
+ my $self = shift;
my ($tmpl_file, @extra_params) = @_;
# add tmpl_path to path array if one is set, otherwise add a path arg
- if (my $tmpl_path = $c->tmpl_path) {
+ if (my $tmpl_path = $self->tmpl_path) {
my @tmpl_paths = (ref $tmpl_path eq 'ARRAY') ? @$tmpl_path : $tmpl_path;
my $found = 0;
for( my $x = 0; $x < @extra_params; $x += 2 ) {
@@ -1650,26 +1664,28 @@
%ht_params = () unless keys %ht_params;
# Define our extension if doesn't already exist;
- $c->{__CURRENT_TMPL_EXTENSION} = '.html' unless defined $c->{__CURRENT_TMPL_EXTENSION};
+ $self->{__CURRENT_TMPL_EXTENSION} = '.html' unless defined $self->{__CURRENT_TMPL_EXTENSION};
# Define a default template name based on the current run mode
unless (defined $tmpl_file) {
- $tmpl_file = $c->get_current_runmode . $c->{__CURRENT_TMPL_EXTENSION};
+ $tmpl_file = $self->get_current_runmode . $self->{__CURRENT_TMPL_EXTENSION};
}
- $c->call_hook('load_tmpl', \%ht_params, \%tmpl_params, $tmpl_file);
-
- require HTML::Template;
+ $self->call_hook('load_tmpl', \%ht_params, \%tmpl_params, $tmpl_file);
+
+ my $ht_class = $self->html_tmpl_class;
+ eval "require $ht_class;" || die "require $ht_class failed: $@";
+
# let's check $tmpl_file and see what kind of parameter it is - we
# now support 3 options: scalar (filename), ref to scalar (the
# actual html/template content) and reference to FILEHANDLE
my $t = undef;
if ( ref $tmpl_file eq 'SCALAR' ) {
- $t = HTML::Template->new_scalar_ref( $tmpl_file, %ht_params );
+ $t = $ht_class->new( scalarref => $tmpl_file, %ht_params );
} elsif ( ref $tmpl_file eq 'GLOB' ) {
- $t = HTML::Template->new_filehandle( $tmpl_file, %ht_params );
+ $t = $ht_class->new( filehandle => $tmpl_file, %ht_params );
} else {
- $t = HTML::Template->new_file($tmpl_file, %ht_params);
+ $t = $ht_class->new( filename => $tmpl_file, %ht_params);
}
if (keys %tmpl_params) {
@@ -1711,7 +1727,7 @@
to use directly. Example:
sub some_method {
- my $c = shift;
+ my $self = shift;
return 'run_mode_x';
}
@@ -1765,11 +1781,11 @@
=cut
sub mode_param {
- my $c = shift;
+ my $self = shift;
my $mode_param;
# First use? Create new __MODE_PARAM
- $c->{__MODE_PARAM} = 'rm' unless (exists($c->{__MODE_PARAM}));
+ $self->{__MODE_PARAM} = 'rm' unless (exists($self->{__MODE_PARAM}));
my %p;
# expecting a scalar or code ref
@@ -1783,8 +1799,8 @@
%p = @_;
$mode_param = $p{param};
- if ( $p{path_info} && $c->query->path_info() ) {
- my $pi = $c->query->path_info();
+ if ( $p{path_info} && $self->query->path_info() ) {
+ my $pi = $self->query->path_info();
my $idx = $p{path_info};
# two cases: negative or positive index
@@ -1806,10 +1822,10 @@
# If data is provided, set it
if (defined $mode_param and length $mode_param) {
- $c->{__MODE_PARAM} = $mode_param;
- }
-
- return $c->{__MODE_PARAM};
+ $self->{__MODE_PARAM} = $mode_param;
+ }
+
+ return $self->{__MODE_PARAM};
}
@@ -1825,15 +1841,15 @@
package WebApp;
use base 'CGI::Application';
sub cgiapp_prerun {
- my $c = shift;
+ my $self = shift;
# Get the web user name, if any
- my $q = $c->query();
+ my $q = $self->query();
my $user = $q->remote_user();
# Redirect to login, if necessary
unless ($user) {
- $c->prerun_mode('login');
+ $self->prerun_mode('login');
}
}
@@ -1892,7 +1908,7 @@
that contain JavaScript.
Direct testing is also easy. CGI::Application will normally print the output of it's
-run modes directly to STDOUT. This can be surprised with an enviroment variable,
+run modes directly to STDOUT. This can be suppressed with an enviroment variable,
CGI_APP_RETURN_ONLY. For example:
$ENV{CGI_APP_RETURN_ONLY} = 1;
@@ -2034,23 +2050,23 @@
$class->add_callback('init', \&some_other_method);
# Object-based: callback will only last for lifetime of this object
- $c->add_callback('prerun', \&some_method);
+ $self->add_callback('prerun', \&some_method);
# If you want to create a new hook location in your application,
# You'll need to know about the following two methods to create
# the hook and call it.
# Create a new hook
- $c->new_hook('pretemplate');
+ $self->new_hook('pretemplate');
# Then later execute all the callbacks registered at this hook
- $c->call_hook('pretemplate');
+ $self->call_hook('pretemplate');
B<Callback Methods>
=head3 add_callback()
- $c->add_callback ('teardown', \&callback);
+ $self->add_callback ('teardown', \&callback);
$class->add_callback('teardown', 'method');
The add_callback method allows you to register a callback
@@ -2071,7 +2087,7 @@
method:
# add object-based callback
- $c->add_callback('teardown', \&callback);
+ $self->add_callback('teardown', \&callback);
# add class-based callbacks
$class->add_callback('teardown', \&callback);
@@ -2124,8 +2140,8 @@
if (ref $c_or_class) {
# Install in object
- my $c = $c_or_class;
- push @{ $c->{__INSTALLED_CALLBACKS}{$hook} }, $callback;
+ my $self = $c_or_class;
+ push @{ $self->{__INSTALLED_CALLBACKS}{$hook} }, $callback;
}
else {
# Install in class
@@ -2137,7 +2153,7 @@
=head3 new_hook(HOOK)
- $c->new_hook('pretemplate');
+ $self->new_hook('pretemplate');
The C<new_hook()> method can be used to create a new location for developers to
register callbacks. It takes one argument, a hook name. The hook location is
@@ -2158,7 +2174,7 @@
=head3 call_hook(HOOK)
- $c->call_hook('pretemplate', @args);
+ $self->call_hook('pretemplate', @args);
The C<call_hook> method is used to executed the callbacks that have been registered
at the given hook. It is used in conjunction with the C<new_hook> method which
@@ -2181,8 +2197,8 @@
=cut
sub call_hook {
- my $c = shift;
- my $app_class = ref $c || $c;
+ my $self = shift;
+ my $app_class = ref $self || $self;
my $hook = lc shift;
my @args = @_;
@@ -2191,9 +2207,9 @@
my %executed_callback;
# First, run callbacks installed in the object
- foreach my $callback (@{ $c->{__INSTALLED_CALLBACKS}{$hook} }) {
+ foreach my $callback (@{ $self->{__INSTALLED_CALLBACKS}{$hook} }) {
next if $executed_callback{$callback};
- eval { $c->$callback(@args); };
+ eval { $self->$callback(@args); };
$executed_callback{$callback} = 1;
die "Error executing object callback in $hook stage: $@" if $@;
}
@@ -2201,10 +2217,10 @@
# Next, run callbacks installed in class hierarchy
# Cache this value as a performance boost
- $c->{__CALLBACK_CLASSES} ||= [ Class::ISA::self_and_super_path($app_class) ];
+ $self->{__CALLBACK_CLASSES} ||= [ Class::ISA::self_and_super_path($app_class) ];
# Get list of classes that the current app inherits from
- foreach my $class (@{ $c->{__CALLBACK_CLASSES} }) {
+ foreach my $class (@{ $self->{__CALLBACK_CLASSES} }) {
# skip those classes that contain no callbacks
next unless exists $INSTALLED_CALLBACKS{$hook}{$class};
@@ -2212,7 +2228,7 @@
# call all of the callbacks in the class
foreach my $callback (@{ $INSTALLED_CALLBACKS{$hook}{$class} }) {
next if $executed_callback{$callback};
- eval { $c->$callback(@args); };
+ eval { $self->$callback(@args); };
$executed_callback{$callback} = 1;
die "Error executing class callback in $hook stage: $@" if $@;
}
Added: branches/upstream/libcgi-application-perl/current/t/default_runmode.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcgi-application-perl/current/t/default_runmode.t?rev=26609&op=file
==============================================================================
--- branches/upstream/libcgi-application-perl/current/t/default_runmode.t (added)
+++ branches/upstream/libcgi-application-perl/current/t/default_runmode.t Mon Nov 3 20:52:35 2008
@@ -1,0 +1,31 @@
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+$ENV{'CGI_APP_RETURN_ONLY'} = 1; # don't print
+
+{
+ package WithStartIssue;
+
+ use base 'CGI::Application';
+
+ # register custom "start" run mode.
+ # this is what CAP::AutoRunmode and CAP::RunmodeDeclare do.
+ __PACKAGE__->add_callback('init' => sub {
+ shift->run_modes('start' => 'my_start');
+ }
+ );
+
+ sub my_start { return 'my start' }
+
+ # don't output a header
+ sub cgiapp_prerun {
+ shift->header_type('none');
+ }
+}
+
+my $issue = WithStartIssue->new;
+my $out = $issue->run;
+
+is $out, 'my start';
More information about the Pkg-perl-cvs-commits
mailing list