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