t/maypole.t

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