1#!/usr/bin/perl 2use strict; 3use warnings; 4use Test::More tests => 84; 5use Test::MockModule; 6use Data::Dumper; 7 8# module compilation 9# Test 1 10require_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 24my $OK = Maypole::Constants::OK(); 25my $DECLINED = Maypole::Constants::DECLINED(); 26my $ERROR = Maypole::Constants::ERROR(); 27 28# Maypole API 29my @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 43can_ok(Maypole => @API); 44ok( UNIVERSAL::can(Maypole => 'is_applicable'), 'is_applicable() method' ); # added is_applicable back in 45ok(Maypole->config->isa('Maypole::Config'), 'config is a Maypole::Config object'); 46ok(! Maypole->init_done, '... which is false by default'); 47is(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; 58my $driver_class = 'MyDriver'; 59 60# Test 14 61# subclass inherits API 62can_ok($driver_class => @API); 63 64# Mock the model class 65my (%required, @db_args, @adopted); 66my $model_class = 'Maypole::Model::CDBI'; 67my $table_class = $driver_class . '::One'; 68 69my $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 82warn "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 117warn "Tests 22 to 27\n\n"; 118# Mock the view class 119my $view_class = 'Maypole::View::TT'; 120my $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 146my ($r, $req); # request objects 147 148# Tests 28 - 38 149warn "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 194warn "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 305warn "Tests 49 to 53\n\n"; 306# is_model_applicable() 307{ 308TODO: { 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 334warn "Tests 54 to 58\n\n"; 335my $mock_driver = new Test::MockModule($driver_class, no_auto => 1); 336my $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 361warn "Tests 59 to 63\n\n"; 362# call_exception() 363{ 364TODO: { 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 404warn "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{ 438TODO: { 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 459warn "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 494