t/maypole.t

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