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