t/maypole.t

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 103;
   5 use Test::MockModule;
   6
   7 # module compilation
   8 require_ok('Maypole');
   9 my $OK       = Maypole::Constants::OK();
  10 my $DECLINED = Maypole::Constants::DECLINED();
  11 my $ERROR    = Maypole::Constants::ERROR();
  12
  13 ok($Maypole::VERSION, 'defines $VERSION');
  14 ok($INC{'Maypole/Config.pm'}, 'loads Maypole::Config');
  15 ok($INC{'UNIVERSAL/require.pm'}, 'loads UNIVERSAL::require');
  16 ok($INC{'Maypole/Constants.pm'}, 'loads Maypole::Constants');
  17 ok($INC{'Class/Accessor/Fast.pm'}, 'loads Class::Accessor::Fast');
  18 ok($INC{'Class/Data/Inheritable.pm'}, 'loads Class::Data::Inheritable');
  19 ok(Maypole->can('config'), 'defines a config attribute');
  20 ok(Maypole->config->isa('Maypole::Config'), 'config is a Maypole::Config object');
  21 ok(Maypole->can('init_done'), 'defines an init_done attribute');
  22 ok(! Maypole->init_done, '... which is false by default');
  23 ok(Maypole->can('view_object'), 'defines a view_object attribute');
  24 is(Maypole->view_object, undef, '... which is undefined');
  25 ok(Maypole->can('ar'), 'defines an "ar" accessor');
  26 ok(Maypole->can('params'), 'defines a "params" accessor');
  27 ok(Maypole->can('query'), 'defines a "query" accessor');
  28 ok(Maypole->can('objects'), 'defines an "objects" accessor');
  29 ok(Maypole->can('model_class'), 'defines a "model_class" accessor');
  30 ok(Maypole->can('template_args'), 'defines a "template_args" accessor');
  31 ok(Maypole->can('output'), 'defines an "output" accessor');
  32 ok(Maypole->can('path'), 'defines a "path" accessor');
  33 ok(Maypole->can('args'), 'defines an "args" accessor');
  34 ok(Maypole->can('action'), 'defines an "action" accessor');
  35 ok(Maypole->can('template'), 'defines a "template" accessor');
  36 ok(Maypole->can('error'), 'defines an "error" accessor');
  37 ok(Maypole->can('document_encoding'), 'defines a "document_encoding" accessor');
  38 ok(Maypole->can('content_type'), 'defines a "content_type" accessor');
  39 ok(Maypole->can('table'), 'defines a "table" accessor');
  40
  41 # simple test class that inherits from Maypole
  42 package MyDriver;
  43 @MyDriver::ISA = 'Maypole';
  44 @MyDriver::VERSION = 1;
  45 package main;
  46 my $driver_class = 'MyDriver';
  47
  48 # Mock the model class
  49 my (%required, @db_args, @adopted);
  50 my $model_class = 'Maypole::Model::CDBI';
  51 my $table_class = $driver_class . '::One';
  52 my $mock_model = Test::MockModule->new($model_class);
  53 $mock_model->mock(
  54     require        => sub {$required{+shift} = 1},
  55     setup_database => sub {
  56         push @db_args, \@_;
  57         $_[1]->{classes} = ["$model_class\::One", "$model_class\::Two"];
  58         $_[1]->{tables}  = [qw(one two)];
  59     },
  60     adopt          => sub {push @adopted, \@_},
  61 );
  62
  63 # setup()
  64 can_ok($driver_class => 'setup');
  65 my $handler = $driver_class->can('handler');
  66 is($handler, Maypole->can('handler'), 'calling package inherits handler()');
  67 $driver_class->setup('dbi:foo'); # call setup()
  68 isnt($handler, $driver_class->can('handler'), 'setup() installs new handler()');
  69 ok($required{$model_class}, '... requires model class');
  70 is($driver_class->config->model(),
  71    'Maypole::Model::CDBI', '... default model is CDBI');
  72 is(@db_args, 1, '... calls model->setup_database');
  73 like(join (' ', @{$db_args[0]}),
  74      qr/$model_class Maypole::Config=\S* $driver_class dbi:foo/,
  75      '... setup_database passed setup() args');
  76 is(@adopted, 2, '... calls model->adopt foreach class in the model');
  77 ok($adopted[0][0]->isa($model_class),
  78    '... sets up model subclasses to inherit from model');
  79 $driver_class->config->model('NonExistant::Model');
  80 eval {$driver_class->setup};
  81 like($@, qr/Couldn't load the model class/,
  82      '... dies if unable to load model class');
  83 $@ = undef; $driver_class->config->model($model_class);
  84
  85 # Mock the view class
  86 my $view_class = 'Maypole::View::TT';
  87 my $mock_view = Test::MockModule->new($view_class);
  88 $mock_view->mock(
  89     new     => sub {bless{}, shift},
  90     require => sub {$required{+shift} = 1},
  91 );
  92
  93 # init()
  94 can_ok($driver_class => 'init');
  95 $driver_class->init();
  96 ok($required{$view_class}, '... requires the view class');
  97 is($driver_class->config->view, $view_class, '... the default view class is TT');
  98 is(join(' ', @{$driver_class->config->display_tables}), 'one two',
  99    '... config->display_tables defaults to all tables');
 100 ok($driver_class->view_object->isa($view_class),
 101    '... creates an instance of the view object');
 102 ok($driver_class->init_done, '... sets init_done');
 103 $driver_class->config->view('NonExistant::View');
 104 eval {$driver_class->init};
 105 like($@, qr/Couldn't load the view class/,
 106      '... dies if unable to load view class');
 107 $@ = undef; $driver_class->config->view($view_class);
 108
 109
 110 my ($r, $req); # request objects
 111 {
 112     no strict 'refs';
 113     my $init = 0;
 114     my $status = 0;
 115     my %called;
 116     my $mock_driver = Test::MockModule->new($driver_class, no_auto => 1);
 117     $mock_driver->mock(
 118         init           => sub {$init++; shift->init_done(1)},
 119         get_request    => sub {($r, $req) = @_; $called{get_request}++},
 120         parse_location => sub {$called{parse_location}++},
 121         handler_guts   => sub {$called{handler_guts}++; $status},
 122         send_output    => sub {$called{send_output}++},
 123     );
 124
 125     # handler()
 126     can_ok($driver_class => 'handler');
 127     my $rv = $driver_class->handler();
 128     ok($r && $r->isa($driver_class), '... created $r');
 129     ok($called{get_request}, '... calls get_request()');
 130     ok($called{get_request}, '... calls parse_location');
 131     ok($called{get_request}, '... calls handler_guts()');
 132     ok($called{get_request}, '... call send_output');
 133     is($rv, 0, '... return status (should be ok?)');
 134     ok(!$init, "... doesn't call init() if init_done()");
 135     # call again, testing other branches
 136     $driver_class->init_done(0);
 137     $status = -1;
 138     $rv = $driver_class->handler();
 139     ok($called{handler_guts} == 2 && $called{send_output} == 1,
 140        '... returns early if handler_guts failed');
 141     is($rv, -1, '... returning the error code from handler_guts');
 142     $driver_class->handler();
 143     ok($init && $driver_class->init_done, "... init() called if !init_done()");
 144 }
 145
 146 {
 147     # handler_guts()
 148     {
 149         no strict 'refs';
 150         @{$table_class . "::ISA"} = $model_class;
 151     }
 152
 153     my ($applicable, %called, $status);
 154     my $mock_driver = new Test::MockModule($driver_class, no_auto => 1);
 155     my $mock_table  = new Test::MockModule($table_class, no_auto => 1);
 156     $mock_driver->mock(
 157         is_applicable   => sub {push @{$called{applicable}},\@_; $applicable},
 158         get_request     => sub {($r, $req) = @_},
 159         additional_data => sub {$called{additional_data}++},
 160     );
 161     $mock_table->mock(
 162         table_process   => sub {push @{$called{process}},\@_},
 163     );
 164     $mock_model->mock(
 165         class_of        => sub {push @{$called{class_of}},\@_; $table_class},
 166         process         => sub {push @{$called{model_process}}, \@_},
 167     );
 168     $mock_view->mock(
 169         process         => sub {push @{$called{view_process}}, \@_; $OK}
 170     );
 171     can_ok(Maypole => 'handler_guts');
 172
 173     $applicable = $OK;
 174     $r->{path} = '/table/action';    $r->parse_path;
 175     $status = $r->handler_guts();
 176
 177     is($r->model_class, $table_class, '... sets model_class from table()');
 178     ok($called{additional_data}, '... call additional_data()');
 179     is($status, $OK, '... return status = OK');
 180     ok($called{model_process},
 181        '... if_applicable, call model_class->process');
 182
 183     %called = ();
 184     $applicable = $DECLINED;
 185     $r->{path} = '/table/action';
 186     $r->parse_path;
 187     $status = $r->handler_guts();
 188     is($r->template, $r->path,
 189        '... if ! is_applicable set template() to path()');
 190     ok(!$called{model_process},
 191        '... !if_applicable, call model_class->process');
 192     is_deeply($called{view_process}[0][1], $r,
 193               ' ... view_object->process called');
 194     is($status, $OK, '... return status = OK');
 195
 196     %called = ();
 197     $r->parse_path;
 198     $r->{output} = 'test';
 199     $status = $r->handler_guts();
 200     ok(!$called{view_process},
 201        '... unless output, call view_object->process to get output');
 202
 203     $mock_driver->mock(call_authenticate => sub {$DECLINED});
 204     $status = $r->handler_guts();
 205     is($status, $DECLINED,
 206        '... return DECLINED unless call_authenticate == OK');
 207
 208     # ... TODO authentication error handling
 209     # ... TODO model error handling
 210     # ... TODO view processing error handling
 211 }
 212
 213 # is_applicable()
 214 can_ok(Maypole => 'is_applicable');
 215 $r->config->display_tables([qw(one two)]);
 216 $r->config->ok_tables(undef);
 217 $r->model_class($table_class);
 218 $r->table('one');
 219 $r->action('unittest');
 220 my $is_public;
 221 $mock_model->mock('is_public', sub {0});
 222 my $status = $r->is_applicable;
 223 is($status, $DECLINED,
 224    '... return DECLINED unless model_class->is_public(action)');
 225 $mock_model->mock('is_public', sub {$is_public = \@_; 1});
 226 $status = $r->is_applicable;
 227 is($status, $OK, '... returns OK if table is in ok_tables');
 228 is_deeply($is_public, [$r->model_class, 'unittest'],
 229           '... calls model_class->is_public with request action');
 230 is_deeply($r->config->ok_tables, {one => 1, two => 1},
 231           '... config->ok_tables defaults to config->display_tables');
 232 delete $r->config->ok_tables->{one};
 233 $status = $r->is_applicable;
 234 is($status, $DECLINED, '... return DECLINED unless $r->table is in ok_tables');
 235
 236 # call_authenticate()
 237 can_ok(Maypole => 'call_authenticate');
 238 my $mock_driver = new Test::MockModule($driver_class, no_auto => 1);
 239 my $mock_table  = new Test::MockModule($table_class, no_auto => 1);
 240 my %auth_calls;
 241 $mock_table->mock(
 242     authenticate => sub {$auth_calls{model_auth} = \@_; $OK}
 243 );
 244 $status = $r->call_authenticate;
 245 is_deeply($auth_calls{model_auth}, [$table_class, $r],
 246           '... calls model_class->authenticate if it exists');
 247 is($status, $OK, '... and returns its status (OK)');
 248 $mock_table->mock(authenticate => sub {$DECLINED});
 249 $status = $r->call_authenticate;
 250 is($status, $DECLINED, '... or DECLINED, as appropriate');
 251
 252 $mock_table->unmock('authenticate');
 253 $mock_driver->mock(authenticate => sub {return $DECLINED});
 254 $status = $r->call_authenticate;
 255 is($status, $DECLINED, '... otherwise it calls authenticte()');
 256 $mock_driver->unmock('authenticate');
 257 $status = $r->call_authenticate;
 258 is($status, $OK, '... the default authenticate is OK');
 259
 260 # call_exception()
 261 can_ok(Maypole => 'call_exception');
 262 my %ex_calls;
 263 $mock_table->mock(
 264     exception => sub {$ex_calls{model_exception} = \@_; $OK}
 265 );
 266 $mock_driver->mock(
 267     exception => sub {$ex_calls{driver_exception} = \@_; 'X'}
 268 );
 269 $status = $r->call_exception('ERR');
 270 is_deeply($ex_calls{model_exception}, [$table_class, $r, 'ERR'],
 271           '... calls model_class->exception if it exists');
 272 is($status, $OK, '... and returns its status (OK)');
 273 $mock_table->mock(exception => sub {$DECLINED});
 274 $status = $r->call_exception('ERR');
 275 is_deeply($ex_calls{driver_exception}, [$r, 'ERR'],
 276           '... or calls driver->exception if model returns !OK');
 277 is($status, 'X', '... and returns the drivers status');
 278
 279 $mock_table->unmock('exception');
 280 $mock_driver->unmock('exception');
 281 $status = $r->call_exception('ERR');
 282 is($status, $ERROR, '... the default exception is ERROR');
 283
 284 # additional_data()
 285 can_ok(Maypole => 'additional_data');
 286
 287 # authenticate()
 288 can_ok(Maypole => 'authenticate');
 289 is(Maypole->authenticate(), $OK, '... returns OK');
 290
 291 # exception()
 292 can_ok(Maypole => 'exception');
 293 is(Maypole->exception(), $ERROR, '... returns ERROR');
 294
 295 # parse_path()
 296 can_ok(Maypole => 'parse_path');
 297 $r->path(undef);
 298 $r->parse_path;
 299 is($r->path, 'frontpage', '... path() defaults to "frontpage"');
 300
 301 $r->path('/table');
 302 $r->parse_path;
 303 is($r->table, 'table', '... parses "table" from the first part of path');
 304 ok(!defined $r->action && @{$r->args} == 0,
 305    '... leaving "action" undefined, and "args" as empty list, if not present');
 306
 307 $r->path('/table/action');
 308 $r->parse_path;
 309 ok($r->table eq 'table' && $r->action eq 'action',
 310    '... action is parsed from second part of path');
 311
 312 $r->path('/table/action/arg1/arg2');
 313 $r->parse_path;
 314 is_deeply($r->args, [qw(arg1 arg2)],
 315    '... "args" are populated from remaning components');
 316
 317 # get_template_root()
 318 can_ok(Maypole => 'get_template_root');
 319 is(Maypole->get_template_root(), '.', '... returns "."');
 320
 321 # get_request()
 322 can_ok(Maypole => 'get_request');
 323
 324 # parse_location()
 325 can_ok(Maypole => 'parse_location');
 326 eval {Maypole->parse_location()};
 327 like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden');
 328
 329 # send_output()
 330 can_ok(Maypole=> 'send_output');
 331 eval {Maypole->send_output};
 332 like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden');