t/maypole.t

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