t/maypole.t

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 84;
   5 use Test::MockModule;
   6 use Data::Dumper;
   7
   8 # module compilation
   9 # Test 1
  10 require_ok('Maypole');
  11
  12 # loaded modules
  13 # Tests 2 - 8
  14 {
  15     ok($Maypole::VERSION, 'defines $VERSION');
  16     ok($INC{'Maypole/Config.pm'}, 'loads Maypole::Config');
  17     ok($INC{'UNIVERSAL/require.pm'}, 'loads UNIVERSAL::require');
  18     ok($INC{'Maypole/Constants.pm'}, 'loads Maypole::Constants');
  19     ok($INC{'Maypole/Headers.pm'}, 'loads Maypole::Headers');
  20     ok($INC{'Class/Accessor/Fast.pm'}, 'loads Class::Accessor::Fast');
  21     ok($INC{'Class/Data/Inheritable.pm'}, 'loads Class::Data::Inheritable');
  22 }
  23
  24 my $OK       = Maypole::Constants::OK();
  25 my $DECLINED = Maypole::Constants::DECLINED();
  26 my $ERROR    = Maypole::Constants::ERROR();
  27
  28 # Maypole API
  29 my @API = qw/ config init_done view_object params query param objects model_class
  30               template_args output path args action template error document_encoding
  31               content_type table headers_in headers_out
  32               is_model_applicable setup setup_model init handler handler_guts
  33               call_authenticate call_exception additional_data
  34               authenticate exception parse_path make_path
  35               make_uri get_template_root get_request
  36               parse_location send_output
  37               start_request_hook
  38               get_session
  39           get_user
  40               /;
  41
  42 # Tests 9 to 13
  43 can_ok(Maypole => @API);
  44 ok( UNIVERSAL::can(Maypole => 'is_applicable'), 'is_applicable() method' ); # added is_applicable back in
  45 ok(Maypole->config->isa('Maypole::Config'), 'config is a Maypole::Config object');
  46 ok(! Maypole->init_done, '... which is false by default');
  47 is(Maypole->view_object, undef, '... which is undefined');
  48
  49 # simple test class that inherits from Maypole
  50 {
  51     package MyDriver;
  52     @MyDriver::ISA = 'Maypole';
  53     @MyDriver::VERSION = 1;
  54     MyDriver->config->template_root('t/templates');
  55 }
  56
  57 # back to package main;
  58 my $driver_class = 'MyDriver';
  59
  60 # Test 14
  61 # subclass inherits API
  62 can_ok($driver_class => @API);
  63
  64 # Mock the model class
  65 my (%required, @db_args, @adopted);
  66 my $model_class = 'Maypole::Model::CDBI';
  67 my $table_class = $driver_class . '::One';
  68
  69 my $mock_model = Test::MockModule->new($model_class);
  70 $mock_model->mock(
  71     require        => sub {$required{+shift} = 1},
  72     setup_database => sub {
  73         push @db_args, \@_;
  74         $_[1]->{classes} = ["$model_class\::One", "$model_class\::Two"];
  75         $_[1]->{tables}  = [qw(one two)];
  76     },
  77     adopt          => sub {push @adopted, \@_},
  78 );
  79
  80
  81 # Tests 15 - 21
  82 warn "Tests 15 to 21\n\n";
  83 # setup
  84 {
  85     # 2.11 - removed tests to check the installed handler was a different ref after setup().
  86     # The handler tests were testing Maypole's old (pre 2.11) method of importing handler()
  87     # into the subclass - it works via standard inheritance now, by setting the 'method'
  88     # attribute on Maypole::handler(). The reason the handlers were different
  89     # was because setup() would create a new anonymous ref to Maypole::handler(), and install
  90     # that - i.e. it installed the same code, but in a different ref, so they tested unequal
  91     # although they referred to the same code
  92
  93     $driver_class->setup('dbi:foo');
  94
  95     ok($required{$model_class}, '... requires model class');
  96     is($driver_class->config->model(),
  97         'Maypole::Model::CDBI', '... default model is CDBI');
  98     is(@db_args, 1, '... calls model->setup_database');
  99     like(join (' ', @{$db_args[0]}),
 100         qr/$model_class Maypole::Config=\S* $driver_class dbi:foo/,
 101         '... setup_database passed setup() args');
 102     is(@adopted, 2, '... calls model->adopt foreach class in the model');
 103     ok($adopted[0][0]->isa($model_class),
 104     '... sets up model subclasses to inherit from model');
 105     $driver_class->config->model('NonExistant::Model');
 106     eval {$driver_class->setup};
 107     like($@, qr/Couldn't load the model class/,
 108         '... dies if unable to load model class');
 109
 110     # cleanup
 111     $@ = undef;
 112     $driver_class->config->model($model_class);
 113 }
 114
 115
 116 # Tests 22 - 27
 117 warn "Tests 22 to 27\n\n";
 118 # Mock the view class
 119 my $view_class = 'Maypole::View::TT';
 120 my $mock_view = Test::MockModule->new($view_class);
 121 $mock_view->mock(
 122     new     => sub {bless{}, shift},
 123     require => sub {$required{+shift} = 1},
 124 );
 125
 126 # init()
 127 {
 128     $driver_class->init();
 129     ok($required{$view_class}, '... requires the view class');
 130     is($driver_class->config->view, $view_class, '... the default view class is TT');
 131     is(join(' ', @{$driver_class->config->display_tables}), 'one two',
 132         '... config->display_tables defaults to all tables');
 133     ok($driver_class->view_object->isa($view_class),
 134         '... creates an instance of the view object');
 135     ok($driver_class->init_done, '... sets init_done');
 136     $driver_class->config->view('NonExistant::View');
 137     eval {$driver_class->init};
 138     like($@, qr/Couldn't load the view class/,
 139         '... dies if unable to load view class');
 140
 141     # cleanup
 142     $@ = undef;
 143     $driver_class->config->view($view_class);
 144 }
 145
 146 my ($r, $req); # request objects
 147
 148 # Tests 28 - 38
 149 warn "tests 28 to 38\n\n";
 150 # handler()
 151 {
 152     my $init = 0;
 153     my $status = 0;
 154     my %called;
 155
 156     my $mock_driver = Test::MockModule->new($driver_class, no_auto => 1);
 157     $mock_driver->mock(
 158         init           => sub {$init++; shift->init_done(1)},
 159         get_request    => sub {($r, $req) = @_; $called{get_request}++},
 160         parse_location => sub {$called{parse_location}++},
 161         handler_guts   => sub {
 162                                 $called{handler_guts}++; $status
 163                               },
 164         send_output    => sub {$called{send_output}++},
 165     );
 166
 167     my $rv = $driver_class->handler();
 168
 169     ok($r && $r->isa($driver_class), '... created $r');
 170     ok($called{get_request}, '... calls get_request()');
 171     ok($called{parse_location}, '... calls parse_location');
 172     ok($called{handler_guts}, '... calls handler_guts()');
 173     ok($called{send_output}, '... call send_output');
 174     is($rv, 0, '... return status (should be ok?)');
 175     ok(!$init, "... doesn't call init() if init_done()");
 176
 177     ok($r->headers_out && $r->headers_out->isa('Maypole::Headers'),
 178        '... populates headers_out() with a Maypole::Headers object');
 179
 180     # call again, testing other branches
 181     $driver_class->init_done(0);
 182     $status = -1;
 183     $rv = $driver_class->handler();
 184     ok($called{handler_guts} == 2 && $called{send_output} == 1,
 185        '... returns early if handler_guts failed');
 186     is($rv, -1, '... returning the error code from handler_guts');
 187
 188     $driver_class->handler();
 189     ok($init && $driver_class->init_done, "... init() called if !init_done()");
 190 }
 191
 192
 193 # Tests 39 - 48
 194 warn "Tests 39 - 48\n\n";
 195 # Testing handler_guts
 196 {
 197     # handler_guts()
 198     {
 199         no strict 'refs';
 200         @{$table_class . "::ISA"} = $model_class;
 201     }
 202
 203     my ($applicable, %called);
 204
 205     my $mock_driver = new Test::MockModule($driver_class, no_auto => 1);
 206     my $mock_table  = new Test::MockModule($table_class, no_auto => 1);
 207
 208     $mock_driver->mock(
 209         is_applicable   => sub {push @{$called{applicable}},\@_; $applicable},
 210         is_model_applicable   =>
 211             sub {push @{$called{applicable}},\@_; $applicable},
 212         get_request     => sub {($r, $req) = @_},
 213         additional_data => sub {$called{additional_data}++},
 214     );
 215
 216     $mock_table->mock(
 217         table_process   => sub {push @{$called{process}},\@_},
 218     );
 219
 220     $mock_model->mock(
 221         class_of        => sub {push @{$called{class_of}},\@_; $table_class},
 222         process         => sub {push @{$called{model_process}}, \@_},
 223     );
 224
 225     $mock_view->mock(
 226         process         => sub {push @{$called{view_process}}, \@_; $OK}
 227     );
 228
 229     # allow request
 230     $applicable = 1;
 231
 232     $r->{path} = '/one/list';
 233     $r->parse_path;
 234
 235     my $status = $r->handler_guts();
 236
 237     # set model_class (would be done in handler_guts, but hard to mock earlier)
 238     $r->model_class( $r->config->model->class_of($r, $r->table) );
 239
 240     warn "status : $status\n";
 241
 242     is($r->model_class, $table_class, '... sets model_class from table()');
 243     ok($called{additional_data}, '... call additional_data()');
 244     is($status, $OK, '... return status = OK');
 245
 246     TODO: {
 247         local $TODO = "test needs fixing";
 248         ok($called{model_process},
 249         '... if_applicable, call model_class->process');
 250     }
 251
 252     # decline request
 253     %called = ();
 254
 255     $applicable = 0;
 256
 257     $r->{path} = '/one/list';
 258     $r->parse_path;
 259
 260     $status = $r->handler_guts();
 261     # set model_class (would be done in handler_guts, but hard to mock earlier)
 262     $r->model_class( $r->config->model->class_of($r, $r->table) );
 263
 264     is($r->template, $r->path,
 265        '... if ! is_applicable set template() to path()');
 266
 267     TODO: {
 268         local $TODO = "test needs fixing";
 269     ok(!$called{model_process},
 270        '... !if_applicable, call model_class->process');
 271     }
 272
 273     is_deeply($called{view_process}[0][1], $r,
 274               ' ... view_object->process called');
 275     is($status, $OK, '... return status = OK');
 276
 277     # pre-load some output
 278     %called = ();
 279
 280     $r->parse_path;
 281     $r->{output} = 'test';
 282
 283     $status = $r->handler_guts();
 284     # set model_class (would be done in handler_guts, but hard to mock earlier)
 285     $r->model_class( $r->config->model->class_of($r, $r->table) );
 286
 287     ok(!$called{view_process},
 288        '... unless output, call view_object->process to get output');
 289
 290     # fail authentication
 291     $mock_driver->mock(call_authenticate => sub {$DECLINED});
 292     $status = $r->handler_guts();
 293     # set model_class (would be done in handler_guts, but hard to mock earlier)
 294     $r->model_class( $r->config->model->class_of($r, $r->table) );
 295
 296     is($status, $DECLINED,
 297        '... return DECLINED unless call_authenticate == OK');
 298
 299     # ... TODO authentication error handling
 300     # ... TODO model error handling
 301     # ... TODO view processing error handling
 302 }
 303
 304 # Tests 49 - 53
 305 warn "Tests 49 to 53\n\n";
 306 # is_model_applicable()
 307 {
 308 TODO: {
 309     local $TODO = "test needs fixing";
 310     $r->config->ok_tables([qw(one two)]);
 311     $r->config->display_tables([qw(one two)]);
 312     $r->model_class($table_class);
 313     $r->table('one');
 314     $r->action('unittest');
 315     my $is_public;
 316     $mock_model->mock('is_public', sub {0});
 317     my $true_false = $r->is_model_applicable;
 318     is($true_false, 0,
 319        '... returns 0 unless model_class->is_public(action)');
 320     $mock_model->mock('is_public', sub {$is_public = \@_; 1});
 321     $true_false = $r->is_model_applicable;
 322     is($true_false, 1, '... returns 1 if table is in ok_tables');
 323     is_deeply($is_public, [$r->model_class, 'unittest'],
 324               '... calls model_class->is_public with request action');
 325     is_deeply($r->config->ok_tables, {one => 1, two => 1},
 326               '... config->ok_tables defaults to config->display_tables');
 327     delete $r->config->ok_tables->{one};
 328     $true_false = $r->is_model_applicable;
 329     is($true_false, 0, '... returns 0 unless $r->table is in ok_tables');
 330   }
 331 }
 332
 333 # Tests 54 - 58
 334 warn "Tests 54 to 58\n\n";
 335 my $mock_driver = new Test::MockModule($driver_class, no_auto => 1);
 336 my $mock_table  = new Test::MockModule($table_class, no_auto => 1);
 337 # call_authenticate()
 338 {
 339     my %auth_calls;
 340     $mock_table->mock(
 341         authenticate => sub {$auth_calls{model_auth} = \@_; $OK}
 342     );
 343     my $status = $r->call_authenticate;
 344     is_deeply($auth_calls{model_auth}, [$table_class, $r],
 345             '... calls model_class->authenticate if it exists'); # 54
 346     is($status, $OK, '... and returns its status (OK)'); # 55
 347     $mock_table->mock(authenticate => sub {$DECLINED});
 348     $status = $r->call_authenticate;
 349     is($status, $DECLINED, '... or DECLINED, as appropriate'); # 56
 350
 351     $mock_table->unmock('authenticate');
 352     $mock_driver->mock(authenticate => sub {return $DECLINED});
 353     $status = $r->call_authenticate;
 354     is($status, $DECLINED, '... otherwise it calls authenticte()'); # 57
 355     $mock_driver->unmock('authenticate');
 356     $status = $r->call_authenticate;
 357     is($status, $OK, '... the default authenticate is OK'); # 58
 358 }
 359
 360 # Tests 59 - 63
 361 warn "Tests 59 to 63\n\n";
 362 # call_exception()
 363 {
 364 TODO: {
 365        local $TODO = "test needs fixing";
 366
 367     my %ex_calls;
 368     $mock_table->mock(
 369         exception => sub {$ex_calls{model_exception} = \@_; $OK}
 370     );
 371     $mock_driver->mock(
 372         exception => sub {$ex_calls{driver_exception} = \@_; 'X'}
 373     );
 374     my $status = $r->call_exception('ERR');
 375     is_deeply($ex_calls{model_exception}, [$table_class, $r, 'ERR'],
 376             '... calls model_class->exception if it exists');
 377     is($status, $OK, '... and returns its status (OK)');
 378     $mock_table->mock(exception => sub {$DECLINED});
 379     $status = $r->call_exception('ERR');
 380     is_deeply($ex_calls{driver_exception}, [$r, 'ERR'],
 381             '... or calls driver->exception if model returns !OK');
 382     is($status, 'X', '... and returns the drivers status');
 383
 384     $mock_table->unmock('exception');
 385     $mock_driver->unmock('exception');
 386     $status = $r->call_exception('ERR');
 387     is($status, $ERROR, '... the default exception is ERROR');
 388     }
 389 }
 390
 391 # Test 64
 392 # authenticate()
 393 {
 394     is(Maypole->authenticate(), $OK, '... returns OK');
 395 }
 396
 397 # Test 65
 398 # exception()
 399 {
 400     is(Maypole->exception(), $ERROR, '... returns ERROR');
 401 }
 402
 403 # Tests 66 to 71
 404 warn "Tests 66 to 71\n\n";
 405 # parse_path()
 406 {
 407     $r->path(undef);
 408
 409     $r->parse_path;
 410     is($r->path, 'frontpage', '... path() defaults to "frontpage"');
 411
 412     $r->path('/table');
 413     $r->parse_path;
 414     is($r->table, 'table', '... parses "table" from the first part of path');
 415     ok(@{$r->args} == 0, '... "args" default to empty list');
 416
 417     $r->path('/table/action');
 418     $r->parse_path;
 419     ok($r->table eq 'table' && $r->action eq 'action',
 420     '... action is parsed from second part of path');
 421
 422     $r->path('/table/action/arg1/arg2');
 423     $r->parse_path;
 424     is_deeply($r->args, [qw(arg1 arg2)],
 425     '... "args" are populated from remaning components');
 426
 427     # ... action defaults to index
 428     $r->path('/table');
 429     $r->parse_path;
 430     is($r->action, 'index', '... action defaults to index');
 431 }
 432
 433 # make_uri() and make_path() - see pathtools.t
 434
 435 # Test 72
 436 # get_template_root()
 437 {
 438 TODO: {
 439        local $TODO = "test needs fixing";
 440        is(Maypole->get_template_root(), '.', '... returns "."');
 441        }
 442 }
 443
 444 # Test 73
 445 # parse_location()
 446 {
 447     eval {Maypole->parse_location()};
 448     like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden');
 449 }
 450
 451 # Test 74
 452 # send_output()
 453 {
 454     eval {Maypole->send_output};
 455     like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden');
 456 }
 457
 458 # Tests 75 - 84
 459 warn "Tests 75 to 84\n\n";
 460 # param()
 461 {
 462         my $p = { foo => 'bar',
 463                   quux => [ qw/one two three/ ],
 464                   buz => undef,
 465                   num => 3,
 466                   zero => 0,
 467                   };
 468
 469         $r->{params} = $p;
 470
 471         is_deeply( [keys %$p], [$r->param] ); # 75
 472
 473         cmp_ok( $r->param('foo'), eq => 'bar' ); # 76
 474         cmp_ok( $r->param('num'), '==' => 3 ); # 77
 475         cmp_ok( $r->param('zero'), '==' => 0 ); # 78
 476
 477         ok( ! defined $r->param('buz') ); # 79
 478
 479         # scalar context returns the 1st value, not a ref
 480         cmp_ok( scalar $r->param('quux'), eq => 'one' ); # 80
 481         is_deeply( [$r->param('quux')], [ qw/one two three/ ] ); # 81
 482
 483         $r->param(foo => 'booze');
 484         cmp_ok( $r->param('foo'), 'eq', 'booze' ); # 82
 485
 486         $r->param(foo => undef);
 487         ok( ! defined $r->param('foo') ); # 83
 488
 489         # cannot introduce new keys
 490         $r->param(new => 'sox');
 491         ok( ! defined $r->param('new') ); # 84
 492 }
 493