Dogcows Code - chaz/p5-CGI-Ex/blob - t/4_app_00_base.t

   1 # -*- Mode: Perl; -*-
   2
   3 =head1 NAME
   4
   5 4_app_00_base.t - Check for the basic functionality of CGI::Ex::App.
   6
   7 =head1 NOTE
   8
   9 These tests are extremely stripped down to test the basic path flow.  Normally
  10 unit tests are useful for garnering information about a module.  For CGI::Ex::App
  11 it is suggested to stick to live use cases or the CGI::Ex::App perldoc - though
  12 we do try to put it through most paces.
  13
  14 =cut
  15
  16 use Test::More tests => 234;
  17 use strict;
  18 use warnings;
  19 use CGI::Ex::Dump qw(debug);
  20
  21 {
  22     package Foo;
  23
  24     use base qw(CGI::Ex::App);
  25     use vars qw($test_stdout);
  26
  27     sub init { $test_stdout = '' }
  28
  29     sub print_out {
  30         my $self = shift;
  31         my $step = shift;
  32         my $str  = shift;
  33         $test_stdout = ref($str) ? $$str : $str;
  34     }
  35
  36     sub swap_template {
  37         my ($self, $step, $file, $swap) = @_;
  38         die "No filenames allowed during test mode" if ! ref($file);
  39         return $self->SUPER::swap_template($step, $file, $swap);
  40     }
  41
  42     sub auth_args { {login_template => \q{Login Form}, key_user => 'user', key_pass => 'pass', key_cookie => 'user', set_cookie => sub {}} }
  43
  44     sub get_pass_by_user { '123qwe' }
  45
  46     ###----------------------------------------------------------------###
  47
  48     sub main_info_complete { 0 }
  49
  50     sub main_file_print { return \ "Main Content [%~ extra %]" }
  51
  52     sub main_path_info_map { shift->{'main_path_info_map'} }
  53
  54     sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} }
  55
  56     sub step2_path_info_map { [[qr{^/step2/(\w+)$}x, 'wow']] }
  57
  58     sub step2_file_print { return \ "Some step2 content ([% foo %], [% one %]) <input type=text name=wow>[% wow_error %]" }
  59
  60     sub step2_hash_swap { return {foo => 'bar', one => 'two'} }
  61
  62     sub step2_hash_fill { return {wow => 'wee'} }
  63
  64     sub step2_finalize { shift->append_path('step3') }
  65
  66     sub step3_info_complete { 0 }
  67
  68     sub step3_file_print { return \ "All good [%~ extra %]" }
  69
  70     sub step4_file_val { return {wow => {required => 1, required_error => 'wow is required'}} }
  71
  72     sub step4_path_info_map { [[qr{^/step4/(\w+)$}x, 'wow']] }
  73
  74     sub step4_file_print { return \ "Some step4 content ([% foo %], [% one %]) <form><input type=text name=wow>[% wow_error %]</form>[% js_validation %]" }
  75
  76     sub step4_hash_swap { return {foo => 'bar', one => 'two'} }
  77
  78     sub step4_hash_fill { return {wow => 'wee'} }
  79
  80     sub step4_finalize { shift->append_path('step3') }
  81
  82     sub step5__part_a_file_print { return \ "Step 5 Nested ([% step %])" }
  83
  84     sub step5__part_a_info_complete { 0 }
  85
  86 }
  87
  88 ###----------------------------------------------------------------###
  89 ###----------------------------------------------------------------###
  90 print "#-----------------------------------------\n";
  91 print "### Test some basic returns ###\n";
  92
  93 ok(! eval { CGI::Ex::App::new()  }, "Invalid new");
  94 ok(! eval { CGI::Ex::App::new(0) }, "Invalid new");
  95
  96 my $app = CGI::Ex::App->new({script_name => '/cgi-bin/foo_bar'});
  97 ok($app->script_name eq '/cgi-bin/foo_bar', "Can pass in script_name");
  98 ok($app->name_module eq 'foo_bar', "Can pass in script_name");
  99
 100 $app = CGI::Ex::App->new({script_name => '/cgi-bin/foo_bar.pl'});
 101 ok($app->script_name eq '/cgi-bin/foo_bar.pl', "Can pass in script_name");
 102 ok($app->name_module eq 'foo_bar', "Can pass in script_name");
 103
 104 ok(Foo->new(name_module => 'foo')->name_module eq 'foo', "Got the name_module");
 105 ok(! eval { Foo->new(script_name => '%####$')->name_module } && $@, "Bad script_name");
 106 ok(! eval { Foo->new(script_name => '%####$')->name_module('foo') } && $@, "Bad script_name");
 107
 108 ok(! eval { $app->morph_package } && $@,                     "Can't get a good morph_package");
 109 ok($app->morph_package('foo') eq 'CGI::Ex::App::Foo',        "Got a good morph_package");
 110 ok($app->morph_package('foo_bar') eq 'CGI::Ex::App::FooBar', "Got a good morph_package");
 111
 112 ok(ref($app->path), "Got a good path");
 113 ok(@{ $app->path } == 0, "Got a good path");
 114 is($app->default_step,   'main',        "Got a good default_step");
 115 is($app->login_step,     '__login',     "Got a good login_step");
 116 is($app->error_step,     '__error',     "Got a good error_step");
 117 is($app->forbidden_step, '__forbidden', "Got a good forbidden_step");
 118 is($app->js_step,        'js',          "Got a good js_step");
 119
 120 # check for different step types
 121 is($app->run_hook('file_print', '__leading_underbars'), 'foo_bar/__leading_underbars.html', 'file_print - __ is preserved at beginning of step');
 122 is($app->run_hook('file_print', 'central__underbars'), 'foo_bar/central/underbars.html', 'file_print - __ is used in middle of step');
 123 my $ref = ref($app);
 124 is($app->run_hook('morph_package', '__leading_underbars'), "${ref}::LeadingUnderbars", 'morph_package - __ is works at beginning of step');
 125 is($app->run_hook('morph_package', 'central__underbars'), "${ref}::Central::Underbars", 'morph_package - __ is used in middle of step');
 126
 127 ###----------------------------------------------------------------###
 128 ###----------------------------------------------------------------###
 129 print "#-----------------------------------------\n";
 130 print "### Test basic step selection/form input/validation/filling/template swapping methods ###\n";
 131
 132 #$ENV{'REQUEST_METHOD'} = 'GET';
 133 #$ENV{'QUERY_STRING'}   = '';
 134
 135 Foo->new({
 136     form => {},
 137 })->navigate;
 138 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo");
 139
 140 {
 141     package Foo2;
 142     our @ISA = qw(Foo);
 143     sub form { {} }
 144 }
 145 Foo2->navigate;
 146 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2");
 147
 148 ###----------------------------------------------------------------###
 149
 150 {
 151     package Foo2_1;
 152     our @ISA = qw(Foo);
 153     sub pre_navigate { 1 }
 154 }
 155 Foo2_1->navigate;
 156 ok($Foo::test_stdout eq "", "Got the right output for Foo2_1");
 157
 158 Foo2_1->new({_no_pre_navigate => 1})->navigate;
 159 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2_1");
 160
 161 {
 162     package Foo2_2;
 163     our @ISA = qw(Foo);
 164     sub pre_loop { 1 }
 165 }
 166 Foo2_2->navigate;
 167 ok($Foo::test_stdout eq "", "Got the right output for Foo2_2");
 168
 169 {
 170     package Foo2_3;
 171     our @ISA = qw(Foo);
 172     sub post_loop { 1 }
 173 }
 174 Foo2_3->navigate;
 175 ok($Foo::test_stdout eq "", "Got the right output for Foo2_3");
 176
 177 {
 178     package Foo2_4;
 179     our @ISA = qw(Foo);
 180     sub post_navigate { $Foo::test_stdout .= " post"; 1 }
 181 }
 182 Foo2_4->navigate;
 183 ok($Foo::test_stdout eq "Main Content post", "Got the right output for Foo2_4");
 184
 185 Foo2_4->new({_no_post_navigate => 1})->navigate;
 186 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2_4");
 187
 188 my $f;
 189
 190 ###----------------------------------------------------------------###
 191
 192 local $ENV{'REQUEST_METHOD'} = 'POST';
 193 #$ENV{'QUERY_STRING'}   = 'step=step2';
 194
 195 Foo->new({
 196     form => {step => 'step2'},
 197 })->navigate;
 198 ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required", "Got the right output for Foo");
 199
 200 Foo->new({
 201     form => {step => 'step4'},
 202 })->navigate;
 203 ok($Foo::test_stdout =~ /Some step4 content.*wow is required.*<script>/s, "Got the right output for Foo (step4)");
 204
 205 $f = Foo->new({
 206     form => {step => 'step5/part_a'},
 207 })->navigate;
 208 is($Foo::test_stdout, 'Step 5 Nested (step5__part_a)', "Got the right output for Foo (step5__part_a)");
 209
 210 $f = Foo->new({
 211     form => {step => 'step5__part_a'},
 212 })->navigate;
 213 is($Foo::test_stdout, 'Step 5 Nested (step5__part_a)', "Got the right output for Foo (step5__part_a)");
 214
 215 {
 216     package Foo3;
 217     our @ISA = qw(Foo);
 218     sub main_info_complete { 1 }
 219 }
 220 eval { Foo3->navigate };
 221 ok($Foo::test_stdout =~ /recurse_limit \(15\)/, "Got the right output for Foo3");
 222
 223 eval { Foo3->new({recurse_limit => 10})->navigate };
 224 ok($Foo::test_stdout =~ /recurse_limit \(10\)/, "Got the right output for Foo3");
 225
 226 ###----------------------------------------------------------------###
 227
 228 #$ENV{'REQUEST_METHOD'} = 'GET';
 229 #$ENV{'QUERY_STRING'}   = 'step=step2&wow=something';
 230
 231 Foo->new({
 232     form=> {step => 'step2', wow => 'something'},
 233 })->navigate;
 234 ok($Foo::test_stdout eq "All good", "Got the right output for Foo");
 235
 236 ###----------------------------------------------------------------###
 237
 238 #$ENV{'REQUEST_METHOD'} = 'GET';
 239 #$ENV{'QUERY_STRING'}   = 'step=step2&wow=something';
 240
 241 Foo->new({
 242     form=> {step => '_bling'},
 243 })->navigate;
 244 ok($Foo::test_stdout =~ /Denied/i, "Got the right output for Foo");
 245
 246 {
 247     package Foo4;
 248     our @ISA = qw(Foo);
 249     sub path { shift->{'path'} ||= ['3foo'] }
 250 }
 251 Foo4->new({form => {}})->navigate;
 252 ok($Foo::test_stdout =~ /Denied/i, "Got the right output for Foo4");
 253
 254 ###----------------------------------------------------------------###
 255
 256 #$ENV{'REQUEST_METHOD'} = 'GET';
 257 #$ENV{'QUERY_STRING'}   = '';
 258 local $ENV{'PATH_INFO'} = '/step2';
 259
 260 Foo->new({
 261     form=> {},
 262 })->navigate;
 263 ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required", "Got the right output");
 264
 265 Foo->new({
 266     path_info_map_base => [],
 267 })->navigate;
 268 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
 269
 270 Foo->new({
 271     path_info_map_base => [[qr{(?!)}, 'foo']],
 272 })->navigate;
 273 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
 274
 275 eval { Foo->new({
 276     path_info_map_base => {},
 277 })->navigate };
 278 ok($Foo::test_stdout eq "", "Got the right output for Foo");
 279
 280 eval { Foo->new({
 281     path_info_map_base => [{}],
 282 })->navigate };
 283 ok($Foo::test_stdout eq "", "Got the right output for Foo");
 284
 285 {
 286     package Foo5;
 287     our @ISA = qw(Foo);
 288     sub path_info_map_base {}
 289 }
 290 Foo5->navigate;
 291 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo5");
 292
 293 local $ENV{'PATH_INFO'} = '/blah';
 294
 295 eval { Foo->new({
 296     path_info_map_base => [],
 297     main_path_info_map => {},
 298 })->navigate };
 299 ok($Foo::test_stdout =~ /fatal error.+path_info_map/, "Got the right output for Foo");
 300
 301 eval { Foo->new({
 302     path_info_map_base => [],
 303     main_path_info_map => [{}],
 304 })->navigate };
 305 ok($Foo::test_stdout =~ /fatal error.+path_info_map/, "Got the right output for Foo");
 306
 307 ###----------------------------------------------------------------###
 308
 309 local $ENV{'PATH_INFO'} = '/whatever';
 310 $f = Foo->new({
 311     path_info_map_base => [[qr{(.+)}, sub { my ($form, $m1) = @_; $form->{'step'} = 'step3'; $form->{'extra'} = $m1 }]],
 312 })->navigate;
 313 is($Foo::test_stdout, 'All good/whatever', "Got the right output path_info_map_base with a code ref");
 314
 315 ###----------------------------------------------------------------###
 316
 317 #$ENV{'REQUEST_METHOD'} = 'GET';
 318 #$ENV{'QUERY_STRING'}   = 'wow=something';
 319 local $ENV{'PATH_INFO'} = '/step2';
 320
 321 $f = Foo->new({
 322     form=> {wow => 'something'},
 323 })->navigate;
 324 ok($Foo::test_stdout eq "All good", "Got the right output");
 325 ok($f->form->{'step'} eq 'step2', "Got the right variable set in form");
 326
 327 ###----------------------------------------------------------------###
 328
 329 #$ENV{'REQUEST_METHOD'} = 'GET';
 330 #$ENV{'QUERY_STRING'}   = '';
 331 local $ENV{'PATH_INFO'} = '/step2/something';
 332
 333 $f = Foo->new({
 334     form => {},
 335 })->navigate;
 336 ok($Foo::test_stdout eq "All good", "Got the right output");
 337 ok($f->form->{'step'} eq 'step2',     "Got the right variable set in form");
 338 ok($f->form->{'wow'}  eq 'something', "Got the right variable set in form");
 339
 340 ###----------------------------------------------------------------###
 341
 342 local $ENV{'PATH_INFO'} = '/step5/part_a';
 343 $f = Foo->new({
 344     path_info_map_base => [[qr{(.+)}, 'step']],
 345 })->navigate;
 346 is($Foo::test_stdout, 'Step 5 Nested (step5__part_a)', "Got the right output for Foo (step5/part_a)");
 347
 348 ###----------------------------------------------------------------###
 349
 350 local $ENV{'PATH_INFO'} = '';
 351
 352 {
 353     package Foo6;
 354     our @ISA = qw(Foo);
 355     sub valid_steps { {step2 => 1} }
 356     sub js_run_step { $Foo::test_stdout = 'JS' }
 357 }
 358 Foo6->navigate;
 359 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo6");
 360
 361 Foo6->new({form => {step => 'main'}})->navigate;
 362 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo6");
 363
 364 Foo6->new({form => {step => 'step3'}})->navigate;
 365 ok($Foo::test_stdout =~ /denied/i, "Got the right output for Foo6");
 366
 367 Foo6->new({form => {step => 'step2'}})->navigate;
 368 ok($Foo::test_stdout =~ /step2/i, "Got the right output for Foo6");
 369
 370 Foo6->new({form => {step => Foo6->new->js_step}})->navigate;
 371 ok($Foo::test_stdout eq 'JS', "Got the right output for Foo6");
 372
 373
 374
 375 ###----------------------------------------------------------------###
 376 ###----------------------------------------------------------------###
 377 ###----------------------------------------------------------------###
 378 ###----------------------------------------------------------------###
 379 print "#-----------------------------------------\n";
 380 print "### Test Authorization Methods ###\n";
 381
 382 local $ENV{'PATH_INFO'}   = '';
 383 local $ENV{'SCRIPT_NAME'} = '/foo';
 384
 385 Foo->new({
 386     form => {},
 387     require_auth => 1,
 388 })->navigate;
 389 is($Foo::test_stdout, "Login Form", "Got the right output");
 390
 391 Foo->new({
 392     form => {},
 393     cookies => {user => 'foo/123qwe'},
 394     require_auth => 1,
 395 })->navigate;
 396 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
 397
 398 ok(Foo->new({
 399     form => {},
 400     cookies => {user => 'foo/123qwe'},
 401 })->check_valid_auth, "Ran check_valid_auth");
 402
 403 my $cva = Foo->new({form => {}, cookies => {user => 'foo/123qwe'}});
 404 ok($cva->check_valid_auth && $cva->check_valid_auth, "Can run twice");
 405
 406
 407
 408 ok(! Foo->new({
 409     form => {},
 410 })->check_valid_auth, "Ran check_valid_auth");
 411
 412 Foo->new({
 413     form => {},
 414     auth_data => {user => 'foo'},
 415     require_auth => 1,
 416 })->navigate;
 417 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
 418
 419 ###----------------------------------------------------------------###
 420
 421 Foo->new({
 422     form => {},
 423 })->navigate_authenticated;
 424 ok($Foo::test_stdout eq "Login Form", "Got the right output");
 425
 426 ###----------------------------------------------------------------###
 427
 428 {
 429     package Bar;
 430     our @ISA = qw(Foo);
 431     sub require_auth { 1 }
 432 }
 433
 434 Bar->new({
 435     form => {},
 436 })->navigate;
 437 ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar");
 438
 439 ###----------------------------------------------------------------###
 440
 441 {
 442     package Bar1;
 443     our @ISA = qw(Foo);
 444     sub require_auth { 1 }
 445 }
 446
 447 my $ok = eval { Bar1->new({
 448     form => {},
 449 })->navigate_authenticated; 1 }; # can't call navigate_authenticated with overwritten require_auth
 450 ok(! $ok, "Got the right output for Bar1");
 451
 452 ###----------------------------------------------------------------###
 453
 454 {
 455     package Bar2;
 456     our @ISA = qw(Foo);
 457     sub main_require_auth { 1 }
 458 }
 459
 460 Bar2->new({
 461     form => {},
 462 })->navigate;
 463 ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar2");
 464
 465 ###----------------------------------------------------------------###
 466
 467 {
 468     package Bar3;
 469     our @ISA = qw(Foo);
 470     sub require_auth { 1 }
 471     sub main_require_auth { 0 }
 472 }
 473
 474 Bar3->new({
 475     form => {},
 476 })->navigate;
 477 ok($Foo::test_stdout eq "Main Content", "Got the right output for Bar3");
 478
 479 ###----------------------------------------------------------------###
 480
 481 Foo->new({
 482     form => {},
 483     require_auth => {main => 0},
 484 })->navigate;
 485 ok($Foo::test_stdout eq "Main Content", "Got the right output");
 486
 487 ###----------------------------------------------------------------###
 488
 489 Foo->new({
 490     form => {},
 491     require_auth => {main => 1},
 492 })->navigate;
 493 ok($Foo::test_stdout eq "Login Form", "Got the right output");
 494
 495 ###----------------------------------------------------------------###
 496
 497 {
 498     package Bar4;
 499     our @ISA = qw(Foo);
 500     sub pre_navigate { shift->require_auth(0); 0 }
 501 }
 502
 503 Bar4->new({
 504     form => {},
 505 })->navigate_authenticated;
 506 ok($Foo::test_stdout eq "Main Content", "Got the right output for Bar4");
 507
 508 ###----------------------------------------------------------------###
 509
 510 {
 511     package Bar5;
 512     our @ISA = qw(Foo);
 513     sub pre_navigate { shift->require_auth(1); 0 }
 514 }
 515
 516 Bar5->new({
 517     form => {},
 518 })->navigate;
 519 ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar5 ($@)");
 520
 521 ###----------------------------------------------------------------###
 522
 523 {
 524     package Bar6;
 525     our @ISA = qw(Foo);
 526     sub pre_navigate { shift->require_auth({main => 1}); 0 }
 527 }
 528
 529 Bar6->new({
 530     form => {},
 531 })->navigate;
 532 ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar6 ($@)");
 533
 534 ###----------------------------------------------------------------###
 535 ###----------------------------------------------------------------###
 536 ###----------------------------------------------------------------###
 537 ###----------------------------------------------------------------###
 538 print "#-----------------------------------------\n";
 539 print "### Test Configuration methods ###\n";
 540
 541 {
 542     package Conf1;
 543     our @ISA = qw(Foo);
 544     sub name_module { my $self = shift; defined($self->{'name_module'}) ? $self->{'name_module'} : 'conf_1' }
 545 }
 546
 547 my $file = Conf1->new->conf_file;
 548 ok($file && $file eq 'conf_1.pl', "Got a conf_file ($file)");
 549
 550 ok(! eval { Conf1->new(name_module => '')->conf_file } && $@, "Couldn't get conf_file");
 551
 552 $file = Conf1->new({ext_conf => 'ini'})->conf_file;
 553 ok($file && $file eq 'conf_1.ini', "Got a conf_file ($file)");
 554
 555 eval { Conf1->new({
 556     load_conf => 1,
 557 })->navigate };
 558 my $err = $@;
 559 ok($err, "Got an error");
 560 chomp $err;
 561 ok($Foo::test_stdout eq "", "Got the right output for Conf1");
 562
 563 Conf1->new({
 564     load_conf => 1,
 565     conf => {
 566         form => {step => 'step3'},
 567     },
 568 })->navigate;
 569 ok($Foo::test_stdout eq "All good", "Got the right output for Conf1");
 570
 571 Conf1->new({
 572     load_conf => 1,
 573     conf_file => {form => {step => 'step3'}},
 574 })->navigate;
 575 ok($Foo::test_stdout eq "All good", "Got the right output for Conf1");
 576
 577 Conf1->new({
 578     load_conf => 1,
 579     conf_file => {form => {step => 'step3'}},
 580     conf_validation => {form => {required => 1}},
 581 })->navigate;
 582 ok($Foo::test_stdout eq "All good", "Got the right output for Conf1");
 583
 584 eval { Conf1->new({
 585     load_conf => 1,
 586     conf_file => {},
 587     conf_validation => {form => {required => 1}},
 588 })->navigate };
 589 ok($Foo::test_stdout eq "" && $@, "Got a conf_validation error");
 590
 591 ###----------------------------------------------------------------###
 592 ###----------------------------------------------------------------###
 593 ###----------------------------------------------------------------###
 594 ###----------------------------------------------------------------###
 595 print "#-----------------------------------------\n";
 596 print "### Various other coverage tests\n";
 597
 598 ok(Conf1->new->conf_obj, "Got a conf_obj");
 599 ok(Conf1->new(conf_args => {paths => './', directive => 'merge'})->conf_obj, "Got a conf_obj");
 600 ok(Conf1->new->val_obj, "Got a val_obj");
 601 ok(Conf1->new(val_args => {cgix => Conf1->new->cgix})->val_obj, "Got a val_obj");
 602 ok(Conf1->new->load_conf(1), "Ran load_conf");
 603
 604 ok(Foo2->navigate->clear_app, "clear_app works");
 605
 606 my $dh = Foo2->navigate;
 607 push @{ $dh->history }, "A string", ['A non ref'], {key => 'No elapsed key'};
 608 push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 2, response => {}};
 609 push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 2, response => {hi => 'there'}};
 610 push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => []};
 611 push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => ['hi']};
 612 push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => 'a'};
 613 push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => 'a'x100};
 614 ok($dh->dump_history, "Can call dump_history");
 615 ok($dh->dump_history('all'), "Can call dump_history");
 616 $dh->{'history_max'} = 10;
 617 ok($dh->dump_history('all'), "Can call dump_history");
 618
 619 {
 620     package Foo7;
 621     our @ISA = qw(Foo);
 622     sub hash_base {}
 623     sub hash_common {}
 624     sub hash_form {}
 625     sub hash_fill {}
 626     sub hash_swap {}
 627     sub hash_errors {}
 628     sub find_hook { my ($self, $hook, $step) = @_; return $self->SUPER::find_hook($hook, $step) if $step eq 'main'; return ["non_code",1] }
 629 }
 630 Foo7->new({no_history => 1})->navigate;
 631 ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo7 ($Foo::test_stdout)");
 632
 633 ok(  eval {  Foo->new->run_hook('hash_base', 'main') }, "Can run_hook main hash_base on Foo");
 634 ok(! eval {  Foo->new->run_hook('bogus',     'main') }, "Can't run_hook main bogus on Foo");
 635 ok(! eval { Foo7->new->run_hook('hash_base', 'bogus') }, "Can't run_hook bogus hash_base on Foo7 for other reasons");
 636
 637 foreach my $meth (qw(auth_args conf_args template_args val_args)) {
 638     ok(! CGI::Ex::App->new->$meth, "Got a good $meth");
 639     ok(CGI::Ex::App->new($meth => {a=>'A'})->$meth->{'a'} eq 'A', "Got a good $meth");
 640 }
 641
 642 ### test read only
 643 foreach my $meth (qw(charset
 644                      conf_die_on_fail
 645                      conf_obj
 646                      conf_path
 647                      conf_validation
 648                      default_step
 649                      error_step
 650                      forbidden_step
 651                      js_step
 652                      login_step
 653                      mimetype
 654                      path_info
 655                      path_info_map_base
 656                      script_name
 657                      step_key
 658                      template_obj
 659                      template_path
 660                      val_obj
 661                      val_path
 662                      )) {
 663     ok(CGI::Ex::App->new($meth => 'blah')->$meth eq 'blah', "I can set $meth");
 664 }
 665
 666 ### test read/write
 667 foreach my $meth (qw(base_dir_abs
 668                      base_dir_rel
 669                      cgix
 670                      conf
 671                      conf_file
 672                      cookies
 673                      ext_conf
 674                      ext_print
 675                      ext_val
 676                      form
 677                      )) {
 678     ok(CGI::Ex::App->new($meth => 'blah')->$meth eq 'blah', "I can set $meth");
 679     my $c = CGI::Ex::App->new;
 680     $c->$meth('blah');
 681     ok($c->$meth eq 'blah', "I can set $meth");
 682 }
 683
 684 foreach my $type (qw(base
 685                      common
 686                      errors
 687                      fill
 688                      form
 689                      swap
 690                      )) {
 691     my $meth = "hash_$type";
 692     ok(CGI::Ex::App->new("hash_$type" => {bing => 'bang'})->$meth->{'bing'} eq 'bang', "Can initialize $meth")
 693         if $type ne 'form';
 694
 695     my $meth2 = "add_to_$type";
 696     my $c = CGI::Ex::App->new;
 697     $c->$meth2({bing => 'bang'});
 698     $c->$meth2(bong => 'beng');
 699
 700     if ($type eq 'errors') {
 701         $c->$meth2({bing => "wow"});
 702         ok($c->$meth->{"bing_error"} eq "bang<br>wow", "$meth2 works");
 703         ok($c->$meth->{"bong_error"} eq 'beng', "$meth2 works");
 704
 705         ok($c->has_errors, "has_errors works") if $type eq 'errors';
 706     } else {
 707         ok($c->$meth->{'bing'} eq 'bang', "$meth2 works");
 708         ok($c->$meth->{'bong'} eq 'beng', "$meth2 works");
 709     }
 710 }
 711
 712 ok(! eval { CGI::Ex::App->new->get_pass_by_user } && $@, "Got a good error for get_pass_by_user");
 713 ok(! eval { CGI::Ex::App->new->find_hook } && $@, "Got a good error for find_hook");
 714
 715 ###----------------------------------------------------------------###
 716 print "#-----------------------------------------\n";
 717 print "### Some morph tests ###\n";
 718
 719 {
 720     package Foo8;
 721     our @ISA = qw(Foo);
 722
 723     sub blah1_pre_step { $Foo::test_stdout = 'blah1_pre'; 1 }
 724     sub blah2_skip { 1 }
 725     sub blah3_info_complete { 1 }
 726     sub blah3_post_step { $Foo::test_stdout = 'blah3_post'; 1 }
 727
 728     sub blah4_prepare { 0 }
 729     sub blah4_file_print { \ 'blah4_file_print' }
 730
 731     sub blah5_finalize { 0 }
 732     sub blah5_info_complete { 1 }
 733     sub blah5_file_print { \ 'blah5_file_print' }
 734
 735     sub blah8_morph_package { 'Foo8' }
 736     sub blah8_info_complete { 0 }
 737     sub blah8_file_print { \ 'blah8_file_print' }
 738
 739     sub blah6_allow_morph { 1 }
 740     package Foo8::Blah6;
 741     our @ISA = qw(Foo8);
 742     sub info_complete { 0 }
 743     sub file_print { \ 'blah6_file_print' }
 744     sub early_exit_run_step { $Foo::test_stdout = 'early'; shift->exit_nav_loop }
 745
 746     sub blah7_allow_morph { 1 }
 747     package Foo8::Blah6::Blah7;
 748     our @ISA = qw(Foo8::Blah6);
 749     sub info_complete { 0 }
 750     sub file_print { \ 'blah7_file_print' }
 751
 752     package Foo8::Blah9;
 753     our @ISA = qw(Foo8);
 754     sub info_complete { 0 }
 755     sub file_print { \ 'blah9_file_print' }
 756
 757     package Foo8;
 758     sub __error_allow_morph { 0 }
 759     sub __error_file_print { \ '[% error_step %] - [% error %]' }
 760     $INC{'Foo8/Blah10.pm'} = 'internal'; # fake require - not a real App package
 761
 762     package Foo8;
 763     sub blah11_morph_package { 'Not::Exists::Blah11' }
 764 }
 765
 766 Foo8->new({form => {step => 'blah1'}})->navigate;
 767 is($Foo::test_stdout, 'blah1_pre', "Got the right output for Foo8");
 768
 769 Foo8->new({form => {step => 'blah1'}, allow_morph => 1})->navigate;
 770 is($Foo::test_stdout, 'blah1_pre', "Got the right output for Foo8");
 771
 772 Foo8->new({form => {step => 'blah2'}})->navigate;
 773 is($Foo::test_stdout, 'Main Content', "Got the right output for Foo8");
 774
 775 Foo8->new({form => {step => 'blah3'}})->navigate;
 776 is($Foo::test_stdout, 'blah3_post', "Got the right output for Foo8");
 777
 778 Foo8->new({form => {step => 'blah4'}})->navigate;
 779 is($Foo::test_stdout, 'blah4_file_print', "Got the right output for Foo8");
 780
 781 Foo8->new({form => {step => 'blah5'}})->navigate;
 782 is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8");
 783
 784 Foo8->new({form => {step => 'blah5'}, allow_morph => 1})->navigate;
 785 is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8");
 786
 787 Foo8->new({form => {step => 'blah5'}, allow_morph => 0})->navigate;
 788 is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8");
 789
 790 Foo8->new({form => {step => 'blah5'}, allow_morph => {}})->navigate;
 791 is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8");
 792
 793 Foo8->new({form => {step => 'blah5'}, allow_morph => {blah5 => 1}})->navigate;
 794 is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8");
 795
 796 Foo8->new({form => {step => 'blah6'}})->navigate;
 797 is($Foo::test_stdout, 'blah6_file_print', "Got the right output for Foo8");
 798
 799 Foo8->new({form => {step => 'blah8'}, allow_morph => 1})->navigate;
 800 is($Foo::test_stdout, 'blah8_file_print', "Got the right output for Foo8 ($Foo::test_stdout)");
 801
 802 my $foo8 = Foo8->new({form => {step => 'blah7'}});
 803 $foo8->morph('blah6');
 804 $foo8->navigate;
 805 is($Foo::test_stdout, 'blah7_file_print', "Got the right output for Foo8");
 806
 807 $foo8 = Foo8->new({form => {step => 'early_exit'}, no_history => 1});
 808 $foo8->morph('blah6');
 809 $foo8->navigate;
 810 ok($Foo::test_stdout eq 'early', "Got the right output for Foo8");
 811 is(ref($foo8), 'Foo8::Blah6', 'Still is unmorphed right');
 812
 813 $foo8 = Foo8->new;
 814 $foo8->morph;
 815 ok(ref($foo8) eq 'Foo8', 'Got the right class');
 816 $foo8->morph('blah6');
 817 eval { $foo8->exit_nav_loop }; # coverage
 818 ok($@, "Got the die from exit_nav_loop");
 819
 820 Foo8->new({form => {step => 'blah9'}, allow_morph => 2})->navigate;
 821 is($Foo::test_stdout, 'blah9_file_print', "Got the right output for Foo8::Blah9 ($Foo::test_stdout)");
 822
 823 $foo8 = Foo8->new({form => {step => 'blah10'}, allow_morph => 2});
 824 eval { $foo8->navigate };
 825 #use CGI::Ex::Dump qw(debug);
 826 #debug $foo8->dump_history;
 827 ok($Foo::test_stdout =~ /^blah10 -/, "Got the right output for Foo8::Blah10");
 828 ok($Foo::test_stdout =~ m|Found package Foo8::Blah10|, "Got the right output for Foo8::Blah10") || diag $Foo::test_stdout;
 829
 830 $foo8 = Foo8->new({form => {step => 'blah11'}, allow_morph => 2});
 831 eval { $foo8->navigate };
 832 #use CGI::Ex::Dump qw(debug);
 833 #debug $foo8->dump_history;
 834 ok($Foo::test_stdout =~ /^blah11 -/, "Got the right output for Foo8::Blah11");
 835 ok($Foo::test_stdout =~ m|Not/Exists/Blah11.pm.*\@INC|, "Got the right output for Foo8::Blah11") || diag $Foo::test_stdout;
 836
 837
 838 $foo8 = Foo8->new;
 839 $foo8->run_hook('morph', 'blah6', 1);
 840 is(ref($foo8), 'Foo8::Blah6', "Right package");
 841
 842 $foo8->run_hook_as('run_step', 'blah7', 'Foo8::Blah6::Blah7');
 843 is($Foo::test_stdout, 'blah7_file_print', "Got the right output for Foo8::Blah6::Blah7");
 844 is(ref($foo8), 'Foo8::Blah6', "Right package");
 845
 846 $foo8->run_hook_as('run_step', 'main', 'Foo8');
 847 is($Foo::test_stdout, 'Main Content', "Got the right output for Foo8");
 848 is(ref($foo8), 'Foo8::Blah6', "Right package");
 849
 850 $foo8->run_hook_as('run_step', 'blah6', 'Foo8::Blah6');
 851 is($Foo::test_stdout, 'blah6_file_print', "Got the right output for Foo8::Blah6");
 852 $foo8->run_hook('unmorph', 'blah6');
 853 #use CGI::Ex::Dump qw(debug);
 854 #debug $foo8->dump_history;
 855
 856
 857
 858 {
 859     package Baz;
 860     our @ISA = qw(Foo);
 861     sub default_step { 'bazmain' }
 862     sub info_complete { 0 }
 863     sub file_print { my ($self, $step) = @_; return \qq{\u$step Content} }
 864     sub allow_morph { 1 }
 865
 866     package Baz::Bstep1;
 867     our @ISA = qw(Baz);
 868
 869     package Baz::Bstep2;
 870     our @ISA = qw(Baz);
 871     sub hash_swap { shift->goto_step('bstep3') } # hijack it here
 872
 873     package Baz::Bstep3;
 874     our @ISA = qw(Baz);
 875 }
 876
 877 Baz->navigate;
 878 is($Foo::test_stdout, 'Bazmain Content', "Got the right output for Foo8::Blah6");
 879 Baz->navigate({form => {step => 'bstep1'}});
 880 is($Foo::test_stdout, 'Bstep1 Content', "Got the right output for Foo8::Blah6");
 881
 882 my $baz = Baz->new({form => {step => 'bstep2'}});
 883 eval { $baz->navigate };
 884 is($Foo::test_stdout, 'Bstep3 Content', "Got the right output for Foo8::Blah6");
 885 is(ref($baz), 'Baz', "And back to the correct object type");
 886 #debug $baz->dump_history;
 887
 888 ###----------------------------------------------------------------###
 889 print "#-----------------------------------------\n";
 890 print "### Some path tests ###\n";
 891
 892 {
 893     package Foo9;
 894     our @ISA = qw(Foo);
 895     sub file_print {
 896         my $self = shift;
 897         my $str = "First(".$self->first_step.") Previous(".$self->previous_step.") Current(".$self->current_step.") Next(".$self->next_step.") Last(".$self->last_step.")";
 898         return \$str;
 899     }
 900     sub one_skip { 1 }
 901     sub two_skip { 1 }
 902     sub info_complete { 0 }
 903     sub invalid_run_step { shift->goto_step('::') }
 904 }
 905 ok(Foo9->new->previous_step eq '', 'No previous step if not navigating');
 906
 907 my $c = Foo9->new(form => {step => 'one'});
 908 $c->add_to_path('three', 'four', 'five');
 909 $c->insert_path('one', 'two');
 910 $c->navigate;
 911 is($Foo::test_stdout, 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9");
 912 ok(! eval { $c->set_path("more") }, "Can't call set_path after nav started");
 913
 914 $c = Foo9->new(form => {step => 'five'});
 915 $c->set_path('one', 'two', 'three', 'four', 'five');
 916 $c->navigate;
 917 is($Foo::test_stdout, 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9");
 918
 919 $c = Foo9->new;
 920 $c->append_path('one');
 921 eval { $c->goto_step('FIRST') };
 922 is($Foo::test_stdout, 'Main Content', "Can jump without nav_loop started");
 923
 924 $c = Foo9->new;
 925 $c->set_path('one');
 926 eval { $c->goto_step('main') };
 927 is($Foo::test_stdout, 'Main Content', "Can jump to step not on the path");
 928
 929 ###----------------------------------------------------------------###
 930
 931 {
 932     package Foo10;
 933     our @ISA = qw(Foo);
 934
 935     sub join_path {
 936         my $self = shift;
 937         my $s = join "", @{ $self->path };
 938         substr($s, $self->{'path_i'}, 0, '(');
 939         substr($s, $self->{'path_i'} + 2, 0, ')');
 940         return $s;
 941     }
 942
 943     #sub run_hook {
 944     #    my ($self, $hook, $step) = @_;
 945     #    print "Into $step: ".$self->join_path."\n" if $hook eq 'run_step';
 946     #    return $self->SUPER::run_hook($hook, $step);
 947     #}
 948
 949     sub a_run_step {
 950         my $self = shift;
 951         if ($self->join_path eq '(a)') {
 952             $self->append_path('b', 'c', 'd', 'e');
 953             $self->jump('CURRENT');
 954         } elsif ($self->join_path eq 'a(a)bcde') {
 955             $self->jump('NEXT');
 956         } elsif ($self->join_path eq 'aab(a)bcde') {
 957             $self->jump(1);
 958         } elsif ($self->join_path eq 'aabab(a)ababcde') {
 959             $self->jump('c');
 960         } elsif ($self->join_path eq 'aababacd(a)ababacde') {
 961             $self->jump('LAST');
 962         } else {
 963             die "Shouldn't get here";
 964         }
 965     }
 966
 967     sub b_run_step {
 968         my $self = shift;
 969         if ($self->join_path eq 'aa(b)cde') {
 970             $self->jump('PREVIOUS');
 971         } elsif ($self->join_path eq 'aaba(b)cde') {
 972             $self->jump(-10);
 973         } else {
 974             die "Shouldn't get here";
 975         }
 976     }
 977
 978     sub c_run_step { 0 }
 979
 980     sub d_run_step { shift->jump('FIRST') }
 981
 982     sub e_run_step {
 983         my $self = shift;
 984         $self->replace_path(); # truncate
 985         $self->jump(1);
 986     }
 987
 988     sub default_step { 'z' }
 989
 990     sub z_run_step { 1 }
 991
 992     sub __error_run_step { 1 }
 993 }
 994
 995 my $Foo10 = Foo10->new(form => {step => 'a'});
 996 $Foo10->navigate;
 997 is($Foo10->join_path, 'aababacdae(z)', 'Followed good path');
 998
 999 ###----------------------------------------------------------------###
1000 print "#-----------------------------------------\n";
1001 print "### Integrated validation tests ###\n";
1002
1003 {
1004     package Foo11;
1005     our @ISA = qw(Foo);
1006     sub step1_skip { 1 }
1007     sub step1_next_step { 'step6' }
1008     sub step6_file_print { \ 'step6_file_print' }
1009     sub step2_name_step { '' }
1010     sub step3_name_step { 'foo.htm' }
1011
1012     package Foo12;
1013     our @ISA = qw(Foo11);
1014     sub val_path { '' }
1015 }
1016
1017 local $ENV{'SCRIPT_NAME'} = '/cgi/ralph.pl';
1018 ok(Foo11->new->file_print("george") eq 'ralph/george.html', 'file_print: '. Foo11->new->file_print("george"));
1019 ok(Foo11->new->file_val("george") =~ m|\Q/ralph/george.val\E|, 'file_val: '. Foo11->new->file_val("george"));
1020 ok(ref(Foo12->new->file_val("george")) eq 'HASH', 'file_val: no such path');
1021 ok(Foo11->new(val_path => '../'        )->file_val("george") eq '../ralph/george.val', 'file_val');
1022 ok(Foo11->new(val_path => sub {'../'}  )->file_val("george") eq '../ralph/george.val', 'file_val');
1023 ok(Foo11->new(val_path => ['../']      )->file_val("george") eq '../ralph/george.val', 'file_val');
1024 ok(Foo11->new(val_path => ['../', './'])->file_val("george") eq '../ralph/george.val', 'file_val');
1025
1026 ok(! eval { Foo11->new->file_print("step2") } && $@, 'Bad name_step');
1027 ok(! eval { Foo11->new->file_val("step2") } && $@, 'Bad name_step');
1028
1029 ok(Foo11->new->file_print("step3") eq 'ralph/foo.htm', 'file_print: '. Foo11->new->file_print("step3"));
1030 ok(Foo11->new->file_val("step3") =~ m|\Q/ralph/foo.val\E|, 'file_val: '. Foo11->new->file_val("step3"));
1031
1032
1033 local $ENV{'REQUEST_METHOD'} = 'POST';
1034
1035 Foo11->new(form => {step => 'step1'})->navigate;
1036 ok($Foo::test_stdout eq 'step6_file_print', "Refine Path and set_ready_validate work ($Foo::test_stdout)");
1037
1038 $f = Foo11->new;
1039 $f->set_ready_validate(1);
1040 ok($f->ready_validate, "Is ready to validate");
1041 $f->set_ready_validate(0);
1042 ok(! $f->ready_validate, "Not ready to validate");
1043 $f->set_ready_validate(1);
1044 ok($f->ready_validate, "Is ready to validate");
1045 $f->set_ready_validate('somestep', 0);
1046 ok(! $f->ready_validate, "Not ready to validate");
1047
1048 ###----------------------------------------------------------------###
1049
1050 {
1051     package Foo13;
1052     our @ISA = qw(Foo);
1053     sub step0_ready_validate { 1 }
1054     sub step0_hash_validation { {foo => {required => 1}} }
1055
1056     sub step1_ready_validate { 1 }
1057     sub step1_form_name       { shift->{'step1_form_name'} }
1058     sub step1_hash_validation { shift->{'step1_hash_validation'} }
1059     sub step1_file_print { \ 'step1_file_print [% has_errors %]' }
1060 }
1061
1062 ok(Foo13->new(ext_val => 'html')->navigate, 'Ran Foo13');
1063 ok($Foo::test_stdout eq 'Main Content', "Got the right content on Foo13 ($Foo::test_stdout)");
1064
1065 Foo13->new(form => {step => 'step1'})->navigate->js_validation('step1');
1066 ok($Foo::test_stdout eq 'Main Content', "Got the right content on Foo13");
1067
1068 ok(Foo13->new->js_validation('step1')            eq '', "No validation found");
1069 ok(Foo13->new->js_validation('step1', 'foo')     eq '', "No validation found");
1070 ok(Foo13->new->js_validation('step1', 'foo', {}) eq '', "No validation found");
1071 ok(Foo13->new->js_validation('step1', 'foo', {foo => {required => 1}}), "Validation found");
1072
1073 ###----------------------------------------------------------------###
1074 print "#-----------------------------------------\n";
1075 print "### Header tests ###\n";
1076
1077 {
1078     package CGIX;
1079     sub new { bless {}, __PACKAGE__ }
1080     sub get_form { {} }
1081     sub print_js {
1082         my ($self, $file) = @_;
1083         $Foo::test_stdout = "Print JS: $file";
1084     }
1085     sub print_content_type {
1086         my $self = shift;
1087         my $mime = shift || 'text/html';
1088         my $char = shift || '';
1089         $mime .= "; charset=$char" if $char && $char =~ m|^[\w\-\.\:\+]+$|;
1090         $Foo::test_stdout = "Print: $mime";
1091     }
1092 }
1093
1094 CGI::Ex::App->new(cgix => CGIX->new)->js_run_step;
1095 ok($Foo::test_stdout eq 'Print JS: ', "Ran js_run_step: $Foo::test_stdout");
1096
1097 CGI::Ex::App->new(cgix => CGIX->new, form => {js => 'CGI/Ex/validate.js'})->js_run_step;
1098 ok($Foo::test_stdout eq 'Print JS: CGI/Ex/validate.js', "Ran js_run_step: $Foo::test_stdout");
1099
1100 CGI::Ex::App->new(cgix => CGIX->new, path_info => '/js/CGI/Ex/validate.js')->js_run_step;
1101 ok($Foo::test_stdout eq 'Print JS: CGI/Ex/validate.js', "Ran js_run_step: $Foo::test_stdout");
1102
1103 CGI::Ex::App->new(cgix => CGIX->new)->print_out('foo', "# the output\n");
1104 ok($Foo::test_stdout eq 'Print: text/html', "Got right header: $Foo::test_stdout");
1105 CGI::Ex::App->new(cgix => CGIX->new, mimetype => 'img/gif')->print_out('foo', "# the output\n");
1106 ok($Foo::test_stdout eq 'Print: img/gif', "Got right header: $Foo::test_stdout");
1107 CGI::Ex::App->new(cgix => CGIX->new, charset => 'ISO-foo')->print_out('foo', "# the output\n");
1108 ok($Foo::test_stdout eq 'Print: text/html; charset=ISO-foo', "Got right header: $Foo::test_stdout");
1109
1110 CGI::Ex::App->new(cgix => CGIX->new)->print_out('foo', \ "# the output\n");
1111 ok($Foo::test_stdout eq 'Print: text/html', "Got right header: $Foo::test_stdout");
1112
1113 ###----------------------------------------------------------------###\
1114 print "#-----------------------------------------\n";