4 use Test::More tests => 84;
10 require_ok('Maypole');
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');
24 my $OK = Maypole::Constants::OK();
25 my $DECLINED = Maypole::Constants::DECLINED();
26 my $ERROR = Maypole::Constants::ERROR();
29 my @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
43 can_ok(Maypole => @API);
44 ok( UNIVERSAL::can(Maypole => 'is_applicable'), 'is_applicable() method' ); # added is_applicable back in
45 ok(Maypole->config->isa('Maypole::Config'), 'config is a Maypole::Config object');
46 ok(! Maypole->init_done, '... which is false by default');
47 is(Maypole->view_object, undef, '... which is undefined');
49 # simple test class that inherits from Maypole
52 @MyDriver::ISA = 'Maypole';
53 @MyDriver::VERSION = 1;
54 MyDriver->config->template_root('t/templates');
57 # back to package main;
58 my $driver_class = 'MyDriver';
61 # subclass inherits API
62 can_ok($driver_class => @API);
64 # Mock the model class
65 my (%required, @db_args, @adopted);
66 my $model_class = 'Maypole::Model::CDBI';
67 my $table_class = $driver_class . '::One';
69 my $mock_model = Test::MockModule->new($model_class);
71 require => sub {$required{+shift} = 1},
72 setup_database => sub {
74 $_[1]->{classes} = ["$model_class\::One", "$model_class\::Two"];
75 $_[1]->{tables} = [qw(one two)];
77 adopt => sub {push @adopted, \@_},
82 warn "Tests 15 to 21\n\n";
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
93 $driver_class->setup('dbi:foo');
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');
112 $driver_class->config->model($model_class);
117 warn "Tests 22 to 27\n\n";
118 # Mock the view class
119 my $view_class = 'Maypole::View::TT';
120 my $mock_view = Test::MockModule->new($view_class);
122 new => sub {bless{}, shift},
123 require => sub {$required{+shift} = 1},
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');
143 $driver_class->config->view($view_class);
146 my ($r, $req); # request objects
149 warn "tests 28 to 38\n\n";
156 my $mock_driver = Test::MockModule->new($driver_class, no_auto => 1);
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
164 send_output => sub {$called{send_output}++},
167 my $rv = $driver_class->handler();
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()");
177 ok($r->headers_out && $r->headers_out->isa('Maypole::Headers'),
178 '... populates headers_out() with a Maypole::Headers object');
180 # call again, testing other branches
181 $driver_class->init_done(0);
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');
188 $driver_class->handler();
189 ok($init && $driver_class->init_done, "... init() called if !init_done()");
194 warn "Tests 39 - 48\n\n";
195 # Testing handler_guts
200 @{$table_class . "::ISA"} = $model_class;
203 my ($applicable, %called);
205 my $mock_driver = new Test::MockModule($driver_class, no_auto => 1);
206 my $mock_table = new Test::MockModule($table_class, no_auto => 1);
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}++},
217 table_process => sub {push @{$called{process}},\@_},
221 class_of => sub {push @{$called{class_of}},\@_; $table_class},
222 process => sub {push @{$called{model_process}}, \@_},
226 process => sub {push @{$called{view_process}}, \@_; $OK}
232 $r->{path} = '/one/list';
235 my $status = $r->handler_guts();
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) );
240 warn "status : $status\n";
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');
247 local $TODO = "test needs fixing";
248 ok($called{model_process},
249 '... if_applicable, call model_class->process');
257 $r->{path} = '/one/list';
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) );
264 is($r->template, $r->path,
265 '... if ! is_applicable set template() to path()');
268 local $TODO = "test needs fixing";
269 ok(!$called{model_process},
270 '... !if_applicable, call model_class->process');
273 is_deeply($called{view_process}[0][1], $r,
274 ' ... view_object->process called');
275 is($status, $OK, '... return status = OK');
277 # pre-load some output
281 $r->{output} = 'test';
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) );
287 ok(!$called{view_process},
288 '... unless output, call view_object->process to get output');
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) );
296 is($status, $DECLINED,
297 '... return DECLINED unless call_authenticate == OK');
299 # ... TODO authentication error handling
300 # ... TODO model error handling
301 # ... TODO view processing error handling
305 warn "Tests 49 to 53\n\n";
306 # is_model_applicable()
309 local $TODO = "test needs fixing";
311 $r->config->display_tables([qw(one two)]);
312 $r->config->ok_tables(undef);
313 $r->model_class($table_class);
315 $r->action('unittest');
317 $mock_model->mock('is_public', sub {0});
318 my $true_false = $r->is_model_applicable;
320 '... returns 0 unless model_class->is_public(action)');
321 $mock_model->mock('is_public', sub {$is_public = \@_; 1});
322 $true_false = $r->is_model_applicable;
323 is($true_false, 1, '... returns 1 if table is in ok_tables');
324 is_deeply($is_public, [$r->model_class, 'unittest'],
325 '... calls model_class->is_public with request action');
326 is_deeply($r->config->ok_tables, {one => 1, two => 1},
327 '... config->ok_tables defaults to config->display_tables');
328 delete $r->config->ok_tables->{one};
329 $true_false = $r->is_model_applicable;
330 is($true_false, 0, '... returns 0 unless $r->table is in ok_tables');
335 warn "Tests 54 to 58\n\n";
336 my $mock_driver = new Test::MockModule($driver_class, no_auto => 1);
337 my $mock_table = new Test::MockModule($table_class, no_auto => 1);
338 # call_authenticate()
342 authenticate => sub {$auth_calls{model_auth} = \@_; $OK}
344 my $status = $r->call_authenticate;
345 is_deeply($auth_calls{model_auth}, [$table_class, $r],
346 '... calls model_class->authenticate if it exists'); # 54
347 is($status, $OK, '... and returns its status (OK)'); # 55
348 $mock_table->mock(authenticate => sub {$DECLINED});
349 $status = $r->call_authenticate;
350 is($status, $DECLINED, '... or DECLINED, as appropriate'); # 56
352 $mock_table->unmock('authenticate');
353 $mock_driver->mock(authenticate => sub {return $DECLINED});
354 $status = $r->call_authenticate;
355 is($status, $DECLINED, '... otherwise it calls authenticte()'); # 57
356 $mock_driver->unmock('authenticate');
357 $status = $r->call_authenticate;
358 is($status, $OK, '... the default authenticate is OK'); # 58
362 warn "Tests 59 to 63\n\n";
366 local $TODO = "test needs fixing";
370 exception => sub {$ex_calls{model_exception} = \@_; $OK}
373 exception => sub {$ex_calls{driver_exception} = \@_; 'X'}
375 my $status = $r->call_exception('ERR');
376 is_deeply($ex_calls{model_exception}, [$table_class, $r, 'ERR'],
377 '... calls model_class->exception if it exists');
378 is($status, $OK, '... and returns its status (OK)');
379 $mock_table->mock(exception => sub {$DECLINED});
380 $status = $r->call_exception('ERR');
381 is_deeply($ex_calls{driver_exception}, [$r, 'ERR'],
382 '... or calls driver->exception if model returns !OK');
383 is($status, 'X', '... and returns the drivers status');
385 $mock_table->unmock('exception');
386 $mock_driver->unmock('exception');
387 $status = $r->call_exception('ERR');
388 is($status, $ERROR, '... the default exception is ERROR');
395 is(Maypole->authenticate(), $OK, '... returns OK');
401 is(Maypole->exception(), $ERROR, '... returns ERROR');
405 warn "Tests 66 to 71\n\n";
411 is($r->path, 'frontpage', '... path() defaults to "frontpage"');
415 is($r->table, 'table', '... parses "table" from the first part of path');
416 ok(@{$r->args} == 0, '... "args" default to empty list');
418 $r->path('/table/action');
420 ok($r->table eq 'table' && $r->action eq 'action',
421 '... action is parsed from second part of path');
423 $r->path('/table/action/arg1/arg2');
425 is_deeply($r->args, [qw(arg1 arg2)],
426 '... "args" are populated from remaning components');
428 # ... action defaults to index
431 is($r->action, 'index', '... action defaults to index');
434 # make_uri() and make_path() - see pathtools.t
437 # get_template_root()
440 local $TODO = "test needs fixing";
441 is(Maypole->get_template_root(), '.', '... returns "."');
448 eval {Maypole->parse_location()};
449 like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden');
455 eval {Maypole->send_output};
456 like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden');
460 warn "Tests 75 to 84\n\n";
463 my $p = { foo => 'bar',
464 quux => [ qw/one two three/ ],
472 is_deeply( [keys %$p], [$r->param] ); # 75
474 cmp_ok( $r->param('foo'), eq => 'bar' ); # 76
475 cmp_ok( $r->param('num'), '==' => 3 ); # 77
476 cmp_ok( $r->param('zero'), '==' => 0 ); # 78
478 ok( ! defined $r->param('buz') ); # 79
480 # scalar context returns the 1st value, not a ref
481 cmp_ok( scalar $r->param('quux'), eq => 'one' ); # 80
482 is_deeply( [$r->param('quux')], [ qw/one two three/ ] ); # 81
484 $r->param(foo => 'booze');
485 cmp_ok( $r->param('foo'), 'eq', 'booze' ); # 82
487 $r->param(foo => undef);
488 ok( ! defined $r->param('foo') ); # 83
490 # cannot introduce new keys
491 $r->param(new => 'sox');
492 ok( ! defined $r->param('new') ); # 84