+2.15
+ 2007-06-20
+ * Fix some warning issues with the Recipe sample in App
+ * Cleanup require_auth interface in App (you will want to
+ double check if you have overwritten require_auth in your
+ application to make sure your implementation is still compatible)
+ * Require latest Template::Alloy
+
2.14
2007-06-12
* Moved CGI::Ex::Template to Template::Alloy
samples/benchmark/bench_conf_readers.pl
samples/benchmark/bench_conf_writers.pl
samples/benchmark/bench_jsondump.pl
-samples/benchmark/bench_method_calling.pl
-samples/benchmark/bench_operator_storage.pl
-samples/benchmark/bench_optree.pl
-samples/benchmark/bench_template.pl
-samples/benchmark/bench_template_tag_parser.pl
samples/benchmark/bench_validation.pl
-samples/benchmark/bench_various_templaters.pl
-samples/benchmark/bench_various_templaters.pl.out
samples/devel/dprof_conf.d
-samples/devel/dprof_template.d
samples/devel/dprof_validation.d
samples/generate_js.pl
samples/index.cgi
samples/js_validate_1.html
samples/js_validate_2.html
samples/js_validate_3.html
-samples/memory_template.pl
samples/yaml_js_1.html
samples/yaml_js_2.html
samples/yaml_js_3.html
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: CGI-Ex
-version: 2.14
+version: 2.15
version_from: lib/CGI/Ex.pm
installdirs: site
requires:
- Template::Alloy: 1.002
+ Template::Alloy: 1.003
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.30_01
VERSION_FROM => "lib/CGI/Ex.pm",
INSTALLDIRS => 'site',
PREREQ_PM => {
- 'Template::Alloy' => '1.002',
+ 'Template::Alloy' => '1.003',
},
dist => {
use base qw(Exporter);
BEGIN {
- $VERSION = '2.14';
+ $VERSION = '2.15';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
use vars qw($VERSION);
BEGIN {
- $VERSION = '2.14';
+ $VERSION = '2.15';
Time::HiRes->import('time') if eval {require Time::HiRes};
eval {require Scalar::Util};
$self->{'_time'} = time;
eval {
- ### allow for authentication
- my $ref = $self->require_auth;
- if ($ref && ! ref $ref) {
- return $self if ! $self->get_valid_auth;
- }
-
### a chance to do things at the very beginning
return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
### allow for an early return
return if $self->pre_loop($path); # a true value means to abort the navigate
- my $req_auth = ref($self->require_auth) ? $self->require_auth : undef;
-
### iterate on each step of the path
foreach ($self->{'path_i'} ||= 0;
$self->{'path_i'} <= $#$path;
$step = $1; # untaint
### allow for per-step authentication
- if ($req_auth
- && $req_auth->{$step}
- && ! $self->get_valid_auth) {
- return;
+ if (! $self->is_authed) {
+ my $req = $self->run_hook('require_auth', $step, 1);
+ if (ref($req) ? $req->{$step} : $req) { # in the hash - or true
+ return if ! $self->get_valid_auth;
+ }
}
### allow for becoming another package (allows for some steps in external files)
$self->morph($step);
### allow for mapping path_info pieces to form elements
- if (my $info = $ENV{'PATH_INFO'}) {
+ if (my $info = $self->path_info) {
my $maps = $self->run_hook('path_info_map', $step) || [];
croak 'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }'
if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY'));
if (! $self->{'path'}) {
my $path = $self->{'path'} = []; # empty path
- ### add initial items to the form hash from path_info
- if (my $info = $ENV{'PATH_INFO'}) {
+ ### add initial items to the form hash from path_info5B
+ if (my $info = $self->path_info) {
my $maps = $self->path_info_map_base || [];
croak 'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }'
if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY'));
$note .= ' - {}';
} elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
$note .= ' - []';
+ } elsif (! defined $resp) {
+ $note .= ' - undef';
} elsif (! ref $resp || ! $all) {
my $max = $self->{'history_max'} || 30;
if (length($resp) > $max) {
my ($self, $args) = @_;
$self = $self->new($args) if ! ref $self;
+ if ($self->can('require_auth') != \&CGI::Ex::App::require_auth) {
+ require Carp;
+ Carp::croak("The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting");
+ }
$self->require_auth(1);
return $self->navigate;
sub require_auth {
my $self = shift;
- $self->{'require_auth'} = shift if @_ == 1;
- return $self->{'require_auth'};
+ $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
+ return $self->{'require_auth'} || 0;
}
sub is_authed { shift->auth_data }
my $self = shift;
return 1 if $self->is_authed;
- ### augment the args with sensible defaults
my $args = $self->auth_args;
+
+ ### allow passed in args
+ if (my $extra = shift) {
+ $args = {%$args, %$extra};
+ }
+
+ ### augment the args with sensible defaults
+ $args->{'script_name'} ||= $self->script_name;
+ $args->{'path_info'} ||= $self->path_info;
$args->{'cgix'} ||= $self->cgix;
$args->{'form'} ||= $self->form;
$args->{'cookies'} ||= $self->cookies;
$args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
$args->{'login_print'} ||= sub {
my ($auth, $template, $hash) = @_;
- my $out = $self->run_hook('swap_template', '__login', $template, $hash);
- $self->run_hook('fill_template', '__login', \$out, $hash);
- $self->run_hook('print_out', '__login', $out);
+ my $step = '__login';
+ my $hash_base = $self->run_hook('hash_base', $step) || {};
+ my $hash_comm = $self->run_hook('hash_common', $step) || {};
+ my $hash_swap = $self->run_hook('hash_swap', $step) || {};
+ my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
+
+ my $out = $self->run_hook('swap_template', $step, $template, $swap);
+ $self->run_hook('fill_template', $step, \$out, $hash);
+ $self->run_hook('print_out', $step, \$out);
};
require CGI::Ex::Auth;
###----------------------------------------------------------------###
### a few standard base accessors
+sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
+
+sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' }
+
+sub cgix {
+ my $self = shift;
+ $self->{'cgix'} = shift if @_ == 1;
+ return $self->{'cgix'} ||= do {
+ require CGI::Ex;
+ CGI::Ex->new; # return of the do
+ };
+}
+
sub form {
my $self = shift;
$self->{'form'} = shift if @_ == 1;
return $self->{'cookies'} ||= $self->cgix->get_cookies;
}
-sub cgix {
- my $self = shift;
- $self->{'cgix'} = shift if @_ == 1;
- return $self->{'cgix'} ||= do {
- require CGI::Ex;
- CGI::Ex->new; # return of the do
- };
-}
-
sub vob {
my $self = shift;
$self->{'vob'} = shift if @_ == 1;
my $out = $self->run_hook('swap_template', $step, $file, $swap);
$self->run_hook('fill_template', $step, \$out, $fill);
-
- $self->run_hook('print_out', $step, $out);
+ $self->run_hook('print_out', $step, \$out);
}
sub print_out {
my ($self, $step, $out) = @_;
$self->cgix->print_content_type;
- print $out;
+ print ref($out) ? $$out : $out;
}
sub swap_template {
return $self->{'name_module'} ||= do {
# allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
- my $script = $ENV{'SCRIPT_NAME'} || $0;
+ my $script = $self->script_name;
$script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
$1; # return of the do
};
my $copy = $self;
eval {require Scalar::Util; Scalar::Util::weaken($copy)};
my $hash = {
- script_name => $ENV{'SCRIPT_NAME'} || $0,
- path_info => $ENV{'PATH_INFO'} || '',
+ script_name => $copy->script_name,
+ path_info => $copy->path_info,
js_validation => sub { $copy->run_hook('js_validation', $step, shift) },
form_name => sub { $copy->run_hook('form_name', $step) },
$self->step_key => $step,
### default to using this script as a handler
sub js_uri_path {
my $self = shift;
- my $script = $ENV{'SCRIPT_NAME'} || return '';
+ my $script = $self->script_name;
my $js_step = $self->js_step;
return ($self->can('path') == \&CGI::Ex::App::path)
? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
my $self = shift;
### make sure path info looks like /js/CGI/Ex/foo.js
- my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || '';
+ my $file = $self->form->{'js'} || $self->path_info;
$file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
$self->cgix->print_js($file);
foreach step of path {
+ ->require_auth (hook)
+ # exits nav_loop if true
+
->morph
# check ->allow_morph
# check ->allow_nested_morph
# Assuming /cgi-bin/my_app is the program being run
- URI: /cgi-bin/my_app
+ URI: /cgi-bin/my_app
STEP: main
FORM: {}
WHY: No other information is passed. The path method is
called which eventually calls ->default_step which
defaults to "main"
- URI: /cgi-bin/my_app?foo=bar
+ URI: /cgi-bin/my_app?foo=bar
STEP: main
FORM: {foo => "bar"}
WHY: Same as previous example except that QUERY_STRING
information was passed and placed in form.
- URI: /cgi-bin/my_app?step=my_step
+ URI: /cgi-bin/my_app?step=my_step
STEP: my_step
FORM: {step => "my_step"}
WHY: The path method is called which looks in $self->form
for the key ->step_key (which defaults to "step").
- URI: /cgi-bin/my_app?step=my_step&foo=bar
+ URI: /cgi-bin/my_app?step=my_step&foo=bar
STEP: my_step
FORM: {foo => "bar", step => "my_step"}
- WHY: Same as before but has other parameters were passed.
+ WHY: Same as before but another parameter was passed.
- URI: /cgi-bin/my_app/my_step
+ URI: /cgi-bin/my_app/my_step
STEP: my_step
FORM: {step => "my_step"}
WHY: The path method is called which called path_info_map_base
$self->form->{$self->step_key} for the initial step. See
the path_info_map_base method for more information.
- URI: /cgi-bin/my_app/my_step?foo=bar
+ URI: /cgi-bin/my_app/my_step?foo=bar
STEP: my_step
FORM: {foo => "bar", step => "my_step"}
WHY: Same as before but other parameters were passed.
- URI: /cgi-bin/my_app/my_step?step=other_step
+ URI: /cgi-bin/my_app/my_step?step=other_step
STEP: other_step
FORM: {step => "other_step"}
WHY: The same procedure took place, but when the PATH_INFO
];
}
- URI: /cgi-bin/my_app/my_step/bar
+ URI: /cgi-bin/my_app/my_step/bar
STEP: my_step
FORM: {foo => "bar"}
WHY: The step was matched as in previous examples using
and the corresponding matched value was placed into
the form using the keys specified following the regex.
- URI: /cgi-bin/my_app/my_step/bar/1234
+ URI: /cgi-bin/my_app/my_step/bar/1234
STEP: my_step
FORM: {foo => "bar", id => "1234"}
WHY: Same as the previous example, except that the first
order that will match the most data. The third regex
would also match this PATH_INFO.
- URI: /cgi-bin/my_app/my_step/some/other/type/of/data
+ URI: /cgi-bin/my_app/my_step/some/other/type/of/data
STEP: my_step
FORM: {anything_else => 'some/other/type/of/data'}
WHY: Same as the previous example, except that the third
regex matched.
- URI: /cgi-bin/my_app/my_step/bar?bling=blang
+ URI: /cgi-bin/my_app/my_step/bar?bling=blang
STEP: my_step
FORM: {foo => "bar", bling => "blang"}
- WHY: Same as the first step, but additional QUERY_STRING
+ WHY: Same as the first sample, but additional QUERY_STRING
information was passed.
- URI: /cgi-bin/my_app/my_step/one%20two?bar=three%20four
+ URI: /cgi-bin/my_app/my_step/one%20two?bar=three%20four
STEP: my_step
FORM: {anything_else => "one two", bar => "three four"}
WHY: The third path_info_map regex matched. Note that the
The default hash_validation hook returns an empty hashref. This means that passed
in data is all valid and the script will automatically call the step's finalize method.
-The following shows how to some contrived validation to a step called "my_step".
+The following shows how to add some contrived validation to a step called "my_step".
sub my_step_hash_validation {
return {
The default file_print hook will look for content on your file system,
but it can also be completely overridden to return a reference to a
-scalar containing the contents of your file. Actually it can return
+scalar containing the contents of your file (beginning with version 2.14
+string references can be cached which makes templates passed this way
+"first class" citizens). Actually it can return
anything that Template::Alloy (Template::Toolkit compatible) will
treat as input. This templated html is displayed to the user during
any step that enters the "print" phase.
debug: admin/Recipe.pm line 14
shift->dump_history = [
"Elapsed: 0.00562",
+ "view - require_auth - require_auth - 0.00001 - 0",
"view - run_step - run_step - 0.00488 - 1",
" view - pre_step - pre_step - 0.00003 - 0",
" view - skip - view_skip - 0.00004 - 0",
=item get_valid_auth (method)
-If require_auth is true at either the application level or at the
-step level, get_valid_auth will be called.
+If require_auth hook returns true on any given step then get_valid_auth will be called.
It will call auth_args to get some default args to pass to
CGI::Ex::Auth->new. It augments the args with sensible defaults that
=item navigate_authenticated (method)
-Same as the method navigate but sets require_auth(1) before
-running. See the require_auth method.
+Same as the method navigate but calls ->require_auth(1) before
+running. It will only work if the navigate_authenticated method
+has not been overwritten. See the require_auth method.
=item new (class method)
Arguments are the steps used to replace. Can be called any time.
Replaces the remaining steps (if any) of the current path.
-=item require_auth (method)
+=item require_auth (hook)
-Default undef. Can return either a true value or a hashref of step names.
+Defaults to self->{require_auth} which defaults to undef.
+If called as a method and passed a single value of 1, 0, or undef it will
+set the value of $self->{require_auth} to that value. If set to a true
+value then any subsequent step will require authentication (unless its
+hook has been overwritten).
-If a hashref of stepnames is returned, authentication will be turned on
-at the step level. In this mode if any step is accessed, the get_valid_auth
-method will be called. If it fails, then the nav_loop will be stopped
-(the post_navigate method will be called - use the is_authed method to perform
-different functions). Any step of the path not in the hash will not require
-authentication. For example, to add authentication to add authentication
-to the add, edit and delete steps you could do:
+Any of the following ways can be used to require authentication on
+every step.
- sub require_auth { {add => 1, edit => 1, delete => 1} }
+=over 4
-If a non-hash true value is returned from the require_auth method then
-authentication will take place before the pre_navigation or the nav_loop methods.
-If authentication fails the navigation process is exited (the post_navigate
-method will not be called).
+=item
sub require_auth { 1 }
-Alternatively you can also could do either of the following:
+=item
__PACKAGE__->navigate_authenticated; # instead of __PACKAGE__->navigate;
- # OR
+=item
+
+ __PACKAGE__->new({require_auth => 1}->navigate;
+
+=item
sub init { shift->require_auth(1) }
- # OR
+=back
- __PACKAGE__->new({require_auth => 1}->navigate;
+Because it is called as a hook, the current step is passed as the
+first argument. If the hook returns false, no authentication will be
+required on this step. If the hook returns a true, non-hashref value,
+authentication will be required via the get_valid_auth method. If the
+method returns a hashref of stepnames to require authentication on,
+the step will require authentication via the get_valid_auth method if
+the current step is in the hashref. If authentication is required and
+succeeds, the step will proceed. If authentication is required and
+fails at the step level the current step will be aborted,
+authentication will be asked for (the post_navigate method will still
+be called).
+
+For example you could add authentication to the add, edit, and delete
+steps in any of the following ways:
-If get_valid_auth returns true, in either case, the is_authed method will
-return true and the auth_data will contain the authenticated user's data.
-If it returns false, auth_data may possibly contain a defined but false
-data object with details as to why authentication failed.
+=over 4
-See the get_valid_auth method.
+=item
+
+ sub require_auth { {add => 1, edit => 1, delete => 1} }
+
+=item
+
+ sub add_require_auth { 1 }
+ sub edit_require_auth { 1 }
+ sub delete_require_auth { 1 }
+
+=item
+
+ sub require_auth {
+ my ($self, $step) = @_;
+ return 1 if $step && $step =~ /^(add|edit|delete)$/;
+ return 0;
+ }
+
+=back
+
+If however you wanted to require authentication on all but one or two methods
+(such as requiring authentication on all but a forgot_password step) you could do
+either of the following:
+
+=over 4
+
+=item
+
+ sub require_auth {
+ my ($self, $step) = @_;
+ return 0 if $step && $step eq 'forgot_password';
+ return 1; # require auth on all other steps
+ }
+
+=item
+
+ sub require_auth { 1 } # turn it on for all steps
+
+ sub forgot_password_require_auth { 0 } # turn it off
+
+=back
+
+See the get_valid_auth method for what occurs should authentication be required.
+
+There is one key difference from the 2.14 version of App. In 2.14 and
+previous versions, the pre_navigate and post_navigate methods would
+not be called if require_auth returned a true non-hashref value. In
+version 2.15 and later, the 2.15 pre_navigate and post_navigate
+methods are always called - even if authentication fails. Also in 2.15
+and later, the method is called as a hook meaning the step is passed in.
=item run_hook (method)
return 0;
}
- my $s = "UPDATE recipe SET title = ?, ingredients = ?, directions = ? WHERE id = ?";
+ $s = "UPDATE recipe SET title = ?, ingredients = ?, directions = ? WHERE id = ?";
$self->dbh->do($s, {}, $form->{'title'},
$form->{'ingredients'},
$form->{'directions'},
sub require_auth { {add => 1, edit => 1, delete => 1} }
+We could also enable authentication by using individual hooks as in:
+
+ sub add_require_auth { 1 }
+ sub edit_require_auth { 1 }
+ sub delete_require_auth { 1 }
+
+Or we could require authentication on everything - but let a few steps in:
+
+ sub require_auth { 1 } # turn authentication on for all
+ sub main_require_auth { 0 } # turn it off for main and view
+ sub view_require_auth { 0 }
+
That's it. The add, edit, and delete steps will now require authentication.
See the require_auth, get_valid_auth, and auth_args methods for more information.
Also see the L<CGI::Ex::Auth> perldoc.
The following corporation and individuals contributed in some part to
the original versions.
- Bizhosting.com - giving a problem that fit basic design patterns.
+ Bizhosting.com - giving a problem that fit basic design patterns.
+
+ Earl Cahill - pushing the idea of more generic frameworks.
- Earl Cahill - pushing the idea of more generic frameworks.
+ Adam Erickson - design feedback, bugfixing, feature suggestions.
- Adam Erickson - design feedback, bugfixing, feature suggestions.
+ James Lance - design feedback, bugfixing, feature suggestions.
- James Lance - design feedback, bugfixing, feature suggestions.
+ Krassimir Berov - feedback and some warnings issues with POD examples.
=head1 AUTHOR
use Digest::MD5 qw(md5_hex);
use CGI::Ex;
-$VERSION = '2.14';
+$VERSION = '2.15';
###----------------------------------------------------------------###
);
@EXPORT_OK = qw(conf_read conf_write in_cache);
-$VERSION = '2.14';
+$VERSION = '2.15';
$DEFAULT_EXT = 'conf';
use CGI::Ex::Dump qw(debug ctrace dex_html);
BEGIN {
- $VERSION = '2.14';
+ $VERSION = '2.15';
$SHOW_TRACE = 0 if ! defined $SHOW_TRACE;
$IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL;
$EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
use strict;
use Exporter;
-$VERSION = '2.14';
+$VERSION = '2.15';
@ISA = qw(Exporter);
@EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
@EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug);
use base qw(Exporter);
BEGIN {
- $VERSION = '2.14';
+ $VERSION = '2.15';
@EXPORT = qw(form_fill);
@EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
};
use base qw(Exporter);
BEGIN {
- $VERSION = '2.14';
+ $VERSION = '2.15';
@EXPORT = qw(JSONDump);
@EXPORT_OK = @EXPORT;
use strict;
use warnings;
-use Template::Alloy 1.002;
+use Template::Alloy 1.003;
use base qw(Template::Alloy);
use vars qw($VERSION
$QR_PRIVATE
$VOBJS
);
-$VERSION = '2.14';
+$VERSION = '2.15';
### install true symbol table aliases that can be localized
*QR_PRIVATE = *Template::Alloy::QR_PRIVATE;
@UNSUPPORTED_BROWSERS
);
-$VERSION = '2.14';
+$VERSION = '2.15';
$DEFAULT_EXT = 'val';
$QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
use strict;
use vars qw($PLACEHOLDER);
-use Benchmark qw(cmpthese);
+use Benchmark qw(cmpthese timethese);
use CGI::Ex::Conf;
use POSIX qw(tmpnam);
one8 => {key1 => "val8", key2 => "ralph"},
}';
+my $str = '[
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+ foo => [key1 => "bar", key2 => "ralph"],
+ pass => [key1 => "word", key2 => "ralph"],
+ garbage => [key1 => "can", key2 => "ralph"],
+ mighty => [key1 => "ducks", key2 => "ralph"],
+ quack => [key1 => "moo", key2 => "ralph"],
+ one1 => [key1 => "val1", key2 => "ralph"],
+ one2 => [key1 => "val2", key2 => "ralph"],
+ one3 => [key1 => "val3", key2 => "ralph"],
+ one4 => [key1 => "val4", key2 => "ralph"],
+ one5 => [key1 => "val5", key2 => "ralph"],
+ one6 => [key1 => "val6", key2 => "ralph"],
+ one7 => [key1 => "val7", key2 => "ralph"],
+ one8 => [key1 => "val8", key2 => "ralph"],
+]';
+
###----------------------------------------------------------------###
# Rate yaml yaml2 xml g_conf pl sto sto2 yaml3
$files{pl} = $file;
### do a generic conf_write
-my $file2 = tmpnam(). '.g_conf';
-&generic_conf_write($file2, $conf);
-local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read;
-$TESTS{g_conf} = sub {
- my $hash = $cob->read_ref($file2);
-};
-$files{g_conf} = $file2;
+#my $file2 = tmpnam(). '.g_conf';
+#&generic_conf_write($file2, $conf);
+#local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read;
+#$TESTS{g_conf} = sub {
+# my $hash = $cob->read_ref($file2);
+#};
+#$files{g_conf} = $file2;
if (eval {require JSON}) {
print "$key => $files{$key}\n";
}
-cmpthese($n, \%TESTS);
+cmpthese timethese ($n, \%TESTS);
### comment out this line to inspect files
unlink $_ foreach values %files;
These tests are extremely stripped down to test the basic path flow. Normally
unit tests are useful for garnering information about a module. For CGI::Ex::App
-it is suggested to stick to live use cases or the CGI::Ex::App perldoc.
+it is suggested to stick to live use cases or the CGI::Ex::App perldoc - though
+we do try to put it through most paces.
=cut
-use Test::More tests => 9;
+use Test::More tests => 20;
use strict;
{
- package Foo;
+ package Foo;
- use base qw(CGI::Ex::App);
- use vars qw($test_stdout);
+ use base qw(CGI::Ex::App);
+ use vars qw($test_stdout);
- sub ready_validate { 1 }
+ sub init { $test_stdout = '' }
- sub print_out {
- my $self = shift;
- my $step = shift;
- $test_stdout = shift;
- }
+ sub ready_validate { 1 }
- sub swap_template {
- my ($self, $step, $file, $swap) = @_;
- my $out = ref($file) ? $$file : "No filenames allowed during test mode";
- $self->cgix->swap_template(\$out, $swap);
- return $out;
- }
+ sub print_out {
+ my $self = shift;
+ my $step = shift;
+ my $str = shift;
+ $test_stdout = ref($str) ? $$str : $str;
+ }
- ###----------------------------------------------------------------###
+ sub swap_template {
+ my ($self, $step, $file, $swap) = @_;
+ my $out = ref($file) ? $$file : "No filenames allowed during test mode";
+ $self->cgix->swap_template(\$out, $swap);
+ return $out;
+ }
- sub main_info_complete { 0 }
+ sub auth_args { {login_template => \q{Login Form}} }
- sub main_file_print { return \ "Main Content" }
+ ###----------------------------------------------------------------###
- sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} }
+ sub main_info_complete { 0 }
- sub step2_path_info_map { [[qr{^/step2/(\w+)$}, 'wow']] }
+ sub main_file_print { return \ "Main Content" }
- sub step2_file_print { return \ "Some step2 content ([% foo %], [% one %]) <input type=text name=wow>[% wow_error %]" }
+ sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} }
- sub step2_hash_swap { return {foo => 'bar', one => 'two'} }
+ sub step2_path_info_map { [[qr{^/step2/(\w+)$}x, 'wow']] }
- sub step2_hash_fill { return {wow => 'wee'} }
+ sub step2_file_print { return \ "Some step2 content ([% foo %], [% one %]) <input type=text name=wow>[% wow_error %]" }
- sub step2_finalize { shift->append_path('step3') }
+ sub step2_hash_swap { return {foo => 'bar', one => 'two'} }
- sub step3_info_complete { 0 }
+ sub step2_hash_fill { return {wow => 'wee'} }
- sub step3_file_print { return \ "All good" }
+ sub step2_finalize { shift->append_path('step3') }
+ sub step3_info_complete { 0 }
+ sub step3_file_print { return \ "All good" }
}
###----------------------------------------------------------------###
#$ENV{'QUERY_STRING'} = '';
Foo->new({
- form => {},
+ form => {},
})->navigate;
ok($Foo::test_stdout eq "Main Content", "Got the right output");
#$ENV{'QUERY_STRING'} = 'step=step2';
Foo->new({
- form => {step => 'step2'},
+ form => {step => 'step2'},
})->navigate;
ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required", "Got the right output");
#$ENV{'QUERY_STRING'} = 'step=step2&wow=something';
Foo->new({
- form=> {step => 'step2', wow => 'something'},
+ form=> {step => 'step2', wow => 'something'},
})->navigate;
ok($Foo::test_stdout eq "All good", "Got the right output");
local $ENV{'PATH_INFO'} = '/step2';
Foo->new({
- form=> {},
+ form=> {},
})->navigate;
ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required", "Got the right output");
local $ENV{'PATH_INFO'} = '/step2';
my $f = Foo->new({
- form=> {wow => 'something'},
+ form=> {wow => 'something'},
})->navigate;
ok($Foo::test_stdout eq "All good", "Got the right output");
ok($f->form->{'step'} eq 'step2', "Got the right variable set in form");
local $ENV{'PATH_INFO'} = '/step2/something';
$f = Foo->new({
- form => {},
+ form => {},
})->navigate;
ok($Foo::test_stdout eq "All good", "Got the right output");
ok($f->form->{'step'} eq 'step2', "Got the right variable set in form");
ok($f->form->{'wow'} eq 'something', "Got the right variable set in form");
###----------------------------------------------------------------###
+
+local $ENV{'PATH_INFO'} = '';
+local $ENV{'SCRIPT_NAME'} = '';
+
+Foo->new({
+ form => {},
+ require_auth => 1,
+})->navigate;
+ok($Foo::test_stdout eq "Login Form", "Got the right output");
+
+###----------------------------------------------------------------###
+
+Foo->new({
+ form => {},
+})->navigate_authenticated;
+ok($Foo::test_stdout eq "Login Form", "Got the right output");
+
+###----------------------------------------------------------------###
+
+{
+ package Bar;
+ @Bar::ISA = qw(Foo);
+ sub require_auth { 1 }
+}
+
+Bar->new({
+ form => {},
+})->navigate;
+ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar");
+
+###----------------------------------------------------------------###
+
+{
+ package Bar1;
+ @Bar1::ISA = qw(Foo);
+ sub require_auth { 1 }
+}
+
+my $ok = eval { Bar1->new({
+ form => {},
+})->navigate_authenticated; 1 }; # can't call navigate_authenticated with overwritten require_auth
+ok(! $ok, "Got the right output for Bar1");
+
+###----------------------------------------------------------------###
+
+{
+ package Bar2;
+ @Bar2::ISA = qw(Foo);
+ sub main_require_auth { 1 }
+}
+
+Bar2->new({
+ form => {},
+})->navigate;
+ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar2");
+
+###----------------------------------------------------------------###
+
+{
+ package Bar3;
+ @Bar3::ISA = qw(Foo);
+ sub require_auth { 1 }
+ sub main_require_auth { 0 }
+}
+
+Bar3->new({
+ form => {},
+})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Bar3");
+
+###----------------------------------------------------------------###
+
+Foo->new({
+ form => {},
+ require_auth => {main => 0},
+})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output");
+
+###----------------------------------------------------------------###
+
+Foo->new({
+ form => {},
+ require_auth => {main => 1},
+})->navigate;
+ok($Foo::test_stdout eq "Login Form", "Got the right output");
+
+###----------------------------------------------------------------###
+
+{
+ package Bar4;
+ @Bar4::ISA = qw(Foo);
+ sub pre_navigate { shift->require_auth(0); 0 }
+}
+
+Bar4->new({
+ form => {},
+})->navigate_authenticated;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Bar4");
+
+###----------------------------------------------------------------###
+
+{
+ package Bar5;
+ @Bar5::ISA = qw(Foo);
+ sub pre_navigate { shift->require_auth(1); 0 }
+}
+
+Bar5->new({
+ form => {},
+})->navigate;
+ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar5 ($@)");
+
+###----------------------------------------------------------------###
+
+{
+ package Bar6;
+ @Bar6::ISA = qw(Foo);
+ sub pre_navigate { shift->require_auth({main => 1}); 0 }
+}
+
+Bar6->new({
+ form => {},
+})->navigate;
+ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar6 ($@)");
projects / chaz / p5-CGI-Ex / commitdiff
