File Coverage

blib/lib/Moonshine/Test.pm
Criterion Covered Total %
statement 22 24 91.6
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 30 32 93.7


line stmt bran cond sub pod time code
1             package Moonshine::Test;
2              
3 1     1   22327 use strict;
  1         4  
  1         36  
4 1     1   6 use warnings;
  1         2  
  1         38  
5 1     1   5 use Test::More;
  1         11  
  1         7  
6 1     1   268 use Scalar::Util qw/blessed/;
  1         1  
  1         113  
7 1     1   758 use Params::Validate qw/:all/;
  1         10672  
  1         266  
8 1     1   9 use B qw/svref_2object/;
  1         2  
  1         60  
9 1     1   7 use Exporter 'import';
  1         2  
  1         34  
10 1     1   328 use Acme::AsciiEmoji;
  0            
  0            
11              
12             our @EMO = @Acme::AsciiEmoji::EXPORT_OK;
13             our @EXPORT = qw/render_me moon_test moon_test_one sunrise/;
14             our @EXPORT_OK = (qw/render_me moon_test moon_test_one sunrise/, @EMO);
15             our %EXPORT_TAGS = (
16             all => [qw/render_me moon_test moon_test_one sunrise/, @EMO],
17             element => [qw/render_me sunrise/],
18             emo => [@EMO],
19             );
20              
21             use feature qw/switch/;
22             no if $] >= 5.017011, warnings => 'experimental::smartmatch';
23              
24             =head1 NAME
25              
26             Moonshine::Test - Test!
27              
28             =head1 VERSION
29              
30             Version 0.14
31              
32             =cut
33              
34             our $VERSION = '0.14';
35              
36             =head1 SYNOPSIS
37              
38             use Moonshine::Test qw/:all/;
39              
40             moon_test_one(
41             test => 'scalar',
42             meth => \&Moonshine::Util::append_str,
43             args => [
44             'first', 'second'
45             ],
46             args_list => 1,
47             expected => 'first second',
48             );
49              
50             sunrise(1);
51              
52             =head1 EXPORT
53              
54             =head2 all
55              
56             =over
57              
58             =item moon_test
59              
60             =item moon_test_one
61              
62             =item render_me
63              
64             =item done_testing
65              
66             =back
67              
68             =head2 element
69              
70             =over
71              
72             =item render_me
73              
74             =item done_testing
75              
76             =back
77              
78             =head1 SUBROUTINES/METHODS
79              
80             =head2 moon_test_one
81              
82             moon_test_one(
83             test => 'render_me',
84             instance => Moonshine::Component->new(),
85             func => 'button',
86             args => {
87             data => '...'
88             },
89             expected => '',
90             );
91              
92             =head2 Instructions
93              
94             Valid instructions moon_test_one accepts
95              
96             =head3 test/expected
97              
98             test => 'like'
99             expected => 'a horrible death'
100             ....
101             like($test_outcome, qr/$expected/, "function: $func is like - $expected");
102              
103             moon_test_one can currently run the following tests.
104              
105             =over
106              
107             =item ok - ok - a true value
108              
109             =item ref - is_deeply - expected [] or {}
110              
111             =item scalar - is - expected '',
112              
113             =item hash - is_deeply - expected {},
114              
115             =item array - is_deeply - expected [],
116              
117             =item obj - isa_ok - expected '',
118              
119             =item like - like - '',
120              
121             =item true - is - 1,
122              
123             =item false - is - 0,
124              
125             =item undef - is - undef
126              
127             =item ref_key_scalar - is - '' (requires key)
128              
129             =item ref_key_ref - is_deeply - [] or {} (requires key)
130              
131             =item ref_key_like - like - ''
132              
133             =item ref_index_scalar - is - '' (requires index)
134              
135             =item ref_index_ref - is_deeply - [] or {} (required index)
136              
137             =item ref_index_like - like - ''
138              
139             =item ref_index_obj - isa_ok - ''
140              
141             =item list_key_scalar - is - '' (requires key)
142              
143             =item list_key_ref - is_deeply - [] or {} (requires key)
144              
145             =item list_key_like - like - ''
146              
147             =item list_index_scalar - is - '' (requires index)
148              
149             =item list_index_ref - is_deeply - [] or {} (required index)
150              
151             =item list_index_obj - isa_ok - ''
152              
153             =item list_index_like - like - ''
154              
155             =item count - is - ''
156              
157             =item count_ref - is - ''
158              
159             =item skip - ok(1)
160              
161             =back
162              
163             =head3 catch
164              
165             when you want to catch exceptions....
166              
167             catch => 1,
168              
169             defaults the instruction{test} to like.
170              
171             =head3 instance
172              
173             my $instance = Moonshine::Element->new();
174             instance => $instance,
175              
176             =head3 func
177              
178             call a function from the instance
179              
180             instance => $instance,
181             func => 'render'
182              
183             =head3 meth
184              
185             meth => \&Moonshine::Element::render,
186              
187             =head3 args
188              
189             {} or []
190              
191             =head3 args_list
192              
193             args => [qw/one, two/],
194             args_list => 1,
195              
196             =head3 index
197              
198             index - required when testing - ref_index_*
199              
200             =head3 key
201              
202             key - required when testing - ref_key_*
203              
204             =cut
205              
206             sub moon_test_one {
207             my %instruction = validate_with(
208             params => \@_,
209             spec => {
210             instance => 0,
211             meth => 0,
212             func => 0,
213             args => { default => {} },
214             args_list => 0,
215             test => 0,
216             expected => 0,
217             catch => 0,
218             key => 0,
219             index => 0,
220             built => 0,
221             }
222             );
223              
224             my @test = ();
225             my $test_name = '';
226             my @expected = $instruction{expected};
227              
228             if ( $instruction{catch} ) {
229             $test_name = 'catch';
230             exists $instruction{test} or $instruction{test} = 'like';
231             eval { _run_the_code( \%instruction ) };
232             @test = $@;
233             }
234             else {
235             @test = _run_the_code( \%instruction );
236             $test_name = shift @test;
237             }
238              
239             if ( not exists $instruction{test} ) {
240             ok(0);
241             diag 'No instruction{test} passed to moon_test_one';
242             return;
243             }
244              
245             given ( $instruction{test} ) {
246             when ('ref') {
247             return is_deeply( $test[0], $expected[0],
248             "$test_name is ref - is_deeply" );
249             }
250             when ('ref_key_scalar') {
251             return exists $instruction{key}
252             ? is(
253             $test[0]->{ $instruction{key} },
254             $expected[0],
255             "$test_name is ref - has scalar key: $instruction{key} - is - $expected[0]"
256             )
257             : ok(
258             0,
259             "No key passed to test - ref_key_scalar - testing - $test_name"
260             );
261             }
262             when ('ref_key_like') {
263             return exists $instruction{key}
264             ? like(
265             $test[0]->{ $instruction{key} },
266             qr/$expected[0]/,
267             "$test_name is ref - has scalar key: $instruction{key} - like - $expected[0]"
268             )
269             : ok( 0,
270             "No key passed to test - ref_key_like - testing - $test_name" );
271             }
272             when ('ref_key_ref') {
273             return exists $instruction{key}
274             ? is_deeply(
275             $test[0]->{ $instruction{key} },
276             $expected[0],
277             "$test_name is ref - has ref key: $instruction{key} - is_deeply - ref"
278             )
279             : ok( 0,
280             "No key passed to test - ref_key_ref - testing - $test_name" );
281             }
282             when ('ref_index_scalar') {
283             return exists $instruction{index}
284             ? is(
285             $test[0]->[ $instruction{index} ],
286             $expected[0],
287             "$test_name is ref - has scalar index: $instruction{index} - is - $expected[0]"
288             )
289             : ok(
290             0,
291             "No index passed to test - ref_index_scalar - testing - $test_name"
292             );
293             }
294             when ('ref_index_ref') {
295             return exists $instruction{index}
296             ? is_deeply(
297             $test[0]->[ $instruction{index} ],
298             $expected[0],
299             "$test_name is ref - has ref index: $instruction{index} - is_deeply - ref"
300             )
301             : ok(
302             0,
303             "No index passed to test - ref_index_ref - testing - $test_name"
304             );
305             }
306             when ('ref_index_like') {
307             return exists $instruction{index}
308             ? like(
309             $test[0]->[ $instruction{index} ],
310             qr/$expected[0]/,
311             "$test_name is ref - has scalar index: $instruction{index} - like - $expected[0]"
312             )
313             : ok(
314             0,
315             "No index passed to test - ref_index_like - testing - $test_name"
316             );
317             }
318             when ('ref_index_obj') {
319             return exists $instruction{index}
320             ? isa_ok(
321             $test[0]->[ $instruction{index} ],
322             $expected[0],
323             "$test_name is ref - has obj index: $instruction{index} - isa_ok - $expected[0]"
324             )
325             : ok(
326             0,
327             "No index passed to test - ref_index_obj - testing - $test_name"
328             );
329             }
330             when ('list_index_scalar') {
331             return exists $instruction{index}
332             ? is(
333             $test[ $instruction{index} ],
334             $expected[0],
335             "$test_name is list - has scalar index: $instruction{index} - is - $expected[0]"
336             )
337             : ok(
338             0,
339             "No index passed to test - list_index_scalar - testing - $test_name"
340             );
341             }
342             when ('list_index_ref') {
343             return exists $instruction{index}
344             ? is_deeply(
345             $test[ $instruction{index} ],
346             $expected[0],
347             "$test_name is list - has ref index: $instruction{index} - is_deeply - ref"
348             )
349             : ok(
350             0,
351             "No index passed to test - list_index_ref - testing - $test_name"
352             );
353             }
354             when ('list_index_like') {
355             return exists $instruction{index}
356             ? like(
357             $test[ $instruction{index} ],
358             qr/$expected[0]/,
359             "$test_name is list - has scalar index: $instruction{index} - like - $expected[0]"
360             )
361             : ok(
362             0,
363             "No index passed to test - list_index_like - testing - $test_name"
364             );
365             }
366             when ('list_index_obj') {
367             return exists $instruction{index}
368             ? isa_ok(
369             $test[ $instruction{index} ],
370             $expected[0],
371             "$test_name is list - has obj index: $instruction{index} - isa_ok - $expected[0]"
372             )
373             : ok(
374             0,
375             "No index passed to test - list_index_obj - testing - $test_name"
376             );
377             }
378             when ('list_key_scalar') {
379             return exists $instruction{key}
380             ? is(
381             {@test}->{ $instruction{key} },
382             $expected[0],
383             "$test_name is list - has scalar key: $instruction{key} - is - $expected[0]"
384             )
385             : ok(
386             0,
387             "No key passed to test - list_key_scalar - testing - $test_name"
388             );
389             }
390             when ('list_key_ref') {
391             return exists $instruction{key}
392             ? is_deeply(
393             {@test}->{ $instruction{key} },
394             $expected[0],
395             "$test_name is list - has ref key: $instruction{key} - is_deeply - ref"
396             )
397             : ok( 0,
398             "No key passed to test - list_key_ref - testing - $test_name" );
399             }
400             when ('list_key_like') {
401             return exists $instruction{key}
402             ? like(
403             {@test}->{ $instruction{key} },
404             qr/$expected[0]/,
405             "$test_name is list - has scalar key: $instruction{key} - like - $expected[0]"
406             )
407             : ok(
408             0,
409             "No key passed to test - list_key_like - testing - $test_name"
410             );
411             }
412             when ('count') {
413             return is(
414             scalar @test,
415             $expected[0],
416             "$test_name is list - count - is - $expected[0]"
417             );
418             }
419             when ('count_ref') {
420             return is(
421             scalar @{ $test[0] },
422             $expected[0],
423             "$test_name is ref - count - is - $expected[0]"
424             );
425             }
426             when ('scalar') {
427             return is( $test[0], $expected[0], sprintf "%s is scalar - is - %s",
428             $test_name, $expected[0] );
429             }
430             when ('hash') {
431             return is_deeply( {@test}, $expected[0],
432             "$test_name is hash - reference - is_deeply" );
433             }
434             when ('array') {
435             return is_deeply( \@test, $expected[0],
436             "$test_name is array - reference - is_deeply" );
437             }
438             when ('obj') {
439             return isa_ok( $test[0], $expected[0],
440             "$test_name is Object - blessed - is - $expected[0]" );
441             }
442             when ('like') {
443             return like( $test[0], qr/$expected[0]/,
444             "$test_name is like - $expected[0]" );
445             }
446             when ('true') {
447             return is( $test[0], 1, "$test_name is true - 1" );
448             }
449             when ('false') {
450             return is( $test[0], 0, "$test_name is false - 0" );
451             }
452             when ('undef') {
453             return is( $test[0], undef, "$test_name is undef" );
454             }
455             when ('render') {
456             return render_me(
457             instance => $test[0],
458             expected => $expected[0],
459             );
460             }
461             when ('ok') {
462             return ok(@test, "$test_name is ok");
463             }
464             when ('skip') {
465             return ok(1, "$test_name - skip");
466             }
467             default {
468             ok(0);
469             diag "Unknown instruction{test}: $_ passed to moon_test_one";
470             return;
471             }
472             }
473             }
474              
475             =head2 moon_test
476            
477             moon_test(
478             name => 'Checking Many Things'
479             build => {
480             class => 'Moonshine::Element',
481             args => {
482             tag => 'p',
483             text => 'hello'
484             }
485             },
486             instructions => [
487             {
488             test => 'scalar',
489             func => 'tag',
490             expected => 'p',
491             },
492             {
493             test => 'scalar',
494             action => 'text',
495             expected => 'hello',
496             },
497             {
498             test => 'render'
499             expected => '

hello

'
500             },
501             ],
502             );
503              
504             =head3 name
505              
506             The tests name
507              
508             name => 'I rule the world',
509              
510             =head3 instance
511              
512             my $instance = My::Object->new();
513             instance => $instance,
514              
515             =head3 build
516              
517             Build an instance
518              
519             build => {
520             class => 'My::Object',
521             args => { },
522             },
523              
524             =head3 instructions
525              
526             instructions => [
527             {
528             test => 'scalar',
529             func => 'tag',
530             expected => 'hello',
531             },
532             {
533             test => 'scalar',
534             action => 'text',
535             expected => 'hello',
536             },
537             {
538             test => 'render'
539             expected => '

hello

'
540             },
541             ],
542              
543             =head3 subtest
544              
545             instructions => [
546             {
547             test => 'obj',
548             func => 'glyphicon',
549             args => { switch => 'search' },
550             subtest => [
551             {
552             test => 'scalar',
553             func => 'class',
554             expected => 'glyphicon glyphicon-search',
555             },
556             ...
557             ]
558             }
559             ]
560              
561             =cut
562              
563             sub moon_test {
564             my %instruction = validate_with(
565             params => \@_,
566             spec => {
567             build => { type => HASHREF, optional => 1, },
568             instance => { optional => 1, },
569             instructions => { type => ARRAYREF },
570             name => { type => SCALAR },
571             }
572             );
573              
574             my $instance =
575             $instruction{build}
576             ? _build_me( $instruction{build} )
577             : $instruction{instance};
578              
579             my %test_info = (
580             fail => 0,
581             tested => 0,
582             );
583              
584             foreach my $test ( @{ $instruction{instructions} } ) {
585             $test_info{tested}++;
586             if ( my $subtests = delete $test->{subtest} ) {
587             my ( $test_name, $new_instance ) = _run_the_code(
588             {
589             instance => $instance,
590             %{$test}
591             }
592             );
593              
594             $test_info{fail}++
595             unless moon_test_one(
596             instance => $new_instance,
597             test => $test->{test},
598             expected => $test->{expected},
599             );
600              
601              
602             my $new_instructions = {
603             instance => $new_instance,
604             instructions => $subtests,
605             name => "Subtest -> $instruction{name} -> $test_name",
606             };
607            
608             moon_test(%{$new_instructions});
609             next;
610             }
611              
612             $test_info{fail}++
613             unless moon_test_one(
614             instance => $instance,
615             %{$test}
616             );
617             }
618              
619             $test_info{ok} = $test_info{fail} ? 0 : 1;
620             return ok(
621             $test_info{ok},
622             sprintf(
623             "moon_test: %s - tested %d instructions - success: %d - failure: %d",
624             $instruction{name}, $test_info{tested},
625             ( $test_info{tested} - $test_info{fail} ), $test_info{fail},
626             )
627             );
628             }
629              
630             sub _build_me {
631             my %instruction = validate_with(
632             params => \@_,
633             spec => {
634             class => 1,
635             new => { default => 'new' },
636             args => { optional => 1, type => HASHREF },
637             }
638             );
639              
640             my $new = $instruction{new};
641             return $instruction{args}
642             ? $instruction{class}->$new( $instruction{args} )
643             : $instruction{class}->$new;
644             }
645              
646             =head2 render_me
647              
648             Test render directly on a Moonshine::Element.
649              
650             render_me(
651             instance => $element,
652             expected => '
echo
'
653             );
654              
655             Or test a function..
656              
657             render_me(
658             instance => $instance,
659             func => 'div',
660             args => { data => 'echo' },
661             expected => '
echo
',
662             );
663              
664             =cut
665              
666             sub render_me {
667             my %instruction = validate_with(
668             params => \@_,
669             spec => {
670             instance => 0,
671             func => 0,
672             meth => 0,
673             args => { default => {} },
674             expected => { type => SCALAR },
675             }
676             );
677              
678             my ( $test_name, $instance ) = _run_the_code( \%instruction );
679              
680             return is( $instance->render,
681             $instruction{expected}, "render $test_name: $instruction{expected}" );
682             }
683              
684             sub _run_the_code {
685             my $instruction = shift;
686              
687             my $test_name;
688             if ( my $func = $instruction->{func} ) {
689             $test_name = "function: ${func}";
690            
691             return defined $instruction->{args}
692             ? defined $instruction->{args_list}
693             ? (
694             $test_name,
695             $instruction->{instance}->$func( @{ $instruction->{args} } )
696             )
697             : (
698             $test_name, $instruction->{instance}->$func( $instruction->{args} // {})
699             )
700             : ( $test_name, $instruction->{instance}->$func );
701             }
702             elsif ( my $meth = $instruction->{meth} ) {
703             my $meth_name = svref_2object($meth)->GV->NAME;
704             $test_name = "method: ${meth_name}";
705             return
706             defined $instruction->{args_list}
707             ? ( $test_name, $meth->( @{ $instruction->{args} } ) )
708             : ( $test_name, $meth->( $instruction->{args} ) );
709             }
710             elsif ( exists $instruction->{instance} ) {
711             $test_name = 'instance';
712             return ( $test_name, $instruction->{instance} );
713             }
714              
715             die(
716             'instruction passed to _run_the_code must have a func, meth or instance'
717             );
718             }
719              
720             =head2 sunrise
721              
722             sunrise(); # done_testing();
723              
724             =cut
725              
726             sub sunrise {
727             my $done_testing = done_testing(shift);
728             diag explain $done_testing;
729             diag sprintf( '
730             %s
731             ^^ @@@@@@@@@
732             ^^ ^^ @@@@@@@@@@@@@@@
733             @@@@@@@@@@@@@@@@@@ ^^
734             @@@@@@@@@@@@@@@@@@@@
735             ---- -- ----- -------- -- &&&&&&&&&&&&&&&&&&&& ------- ----------- ---
736             - -- - - -------------------- - -- -- -
737             - -- -- -- -- ------------- ---- - --- - --- - --
738             - -- - - ------ -- --- -- - -- -- -
739             - - - - - -- ------ - -- - --
740             - - - - -- - -',
741             shift // ' \o/ ' );
742             return $done_testing;
743             }
744              
745             =head1 AUTHOR
746              
747             LNATION, C<< >>
748              
749             =head1 BUGS
750              
751             Please report any bugs or feature requests to C, or through
752             the web interface at L. I will be notified, and then you'll
753             automatically be notified of progress on your bug as I make changes.
754              
755             =head1 SUPPORT
756              
757             You can find documentation for this module with the perldoc command.
758              
759             perldoc Moonshine::Test
760              
761             You can also look for information at:
762              
763             =over 4
764              
765             =item * RT: CPAN's request tracker (report bugs here)
766              
767             L
768              
769             =item * AnnoCPAN: Annotated CPAN documentation
770              
771             L
772              
773             =item * CPAN Ratings
774              
775             L
776              
777             =item * Search CPAN
778              
779             L
780              
781             =back
782              
783             =head1 ACKNOWLEDGEMENTS
784              
785             =head1 LICENSE AND COPYRIGHT
786              
787             Copyright 2017 Robert Acock.
788              
789             This program is free software; you can redistribute it and/or modify it
790             under the terms of the the Artistic License (2.0). You may obtain a
791             copy of the full license at:
792              
793             L
794              
795             Any use, modification, and distribution of the Standard or Modified
796             Versions is governed by this Artistic License. By using, modifying or
797             distributing the Package, you accept this license. Do not use, modify,
798             or distribute the Package, if you do not accept this license.
799              
800             If your Modified Version has been derived from a Modified Version made
801             by someone other than you, you are nevertheless required to ensure that
802             your Modified Version complies with the requirements of this license.
803              
804             This license does not grant you the right to use any trademark, service
805             mark, tradename, or logo of the Copyright Holder.
806              
807             This license includes the non-exclusive, worldwide, free-of-charge
808             patent license to make, have made, use, offer to sell, sell, import and
809             otherwise transfer the Package with respect to any patent claims
810             licensable by the Copyright Holder that are necessarily infringed by the
811             Package. If you institute patent litigation (including a cross-claim or
812             counterclaim) against any party alleging that the Package constitutes
813             direct or contributory patent infringement, then this Artistic License
814             to you shall terminate on the date that such litigation is filed.
815              
816             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
817             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
818             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
819             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
820             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
821             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
822             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
823             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
824              
825             =cut
826              
827             1; # End of Moonshine::Test