File Coverage

blib/lib/Test2/Tools/LoadModule.pm
Criterion Covered Total %
statement 212 216 98.1
branch 65 72 90.2
condition 27 30 90.0
subroutine 45 45 100.0
pod 7 7 100.0
total 356 370 96.2


line stmt bran cond sub pod time code
1             package Test2::Tools::LoadModule;
2              
3 10     10   2081382 use 5.008001;
  10         90  
4              
5 10     10   54 use strict;
  10         22  
  10         266  
6 10     10   65 use warnings;
  10         27  
  10         384  
7              
8             # OK, the following is probably paranoia. But if Perl 7 decides to
9             # change this particular default I'm ready. Unless they eliminate $].
10 10     10   6829 no if $] ge '5.020', feature => qw{ signatures };
  10         147  
  10         68  
11              
12 10     10   1765 use Carp;
  10         25  
  10         616  
13 10     10   65 use Exporter 5.567; # Comes with Perl 5.8.1.
  10         207  
  10         402  
14             # use File::Find ();
15             # use File::Spec ();
16             # use Getopt::Long 2.34; # Comes with Perl 5.8.1.
17 10     10   56 use Test2::API 1.302096 ();
  10         205  
  10         316  
18 10     10   60 use Test2::API::Context 1.302096 (); # for pass_and_release().
  10         196  
  10         255  
19 10     10   60 use Test2::Util 1.302096 ();
  10         263  
  10         247  
20              
21 10     10   55 use base qw{ Exporter };
  10         40  
  10         2707  
22              
23             our $VERSION = '0.007_01';
24             $VERSION =~ s/ _ //smxg;
25              
26             {
27             my @test2 = qw{
28             all_modules_tried_ok
29             clear_modules_tried
30             load_module_ok
31             load_module_or_skip
32             load_module_or_skip_all
33             };
34              
35             my @more = qw{
36             require_ok
37             use_ok
38             };
39              
40             my @private = qw{
41             __build_load_eval
42             __get_hint_hash
43             DEFAULT_LOAD_ERROR
44             ERR_IMPORT_BAD
45             ERR_MODULE_UNDEF
46             ERR_OPTION_BAD
47             ERR_SKIP_NUM_BAD
48             ERR_VERSION_BAD
49             HINTS_AVAILABLE
50             TEST_MORE_ERROR_CONTEXT
51             TEST_MORE_LOAD_ERROR
52             };
53              
54             our @EXPORT_OK = ( @test2, @more, @private );
55              
56             our %EXPORT_TAGS = (
57             all => [ @test2, @more ],
58             default => \@test2,
59             more => \@more,
60             private => \@private,
61             test2 => \@test2,
62             );
63              
64             our @EXPORT = @{ $EXPORT_TAGS{default} }; ## no critic (ProhibitAutomaticExportation)
65             }
66              
67 10     10   84 use constant ARRAY_REF => ref [];
  10         23  
  10         971  
68 10     10   68 use constant HASH_REF => ref {};
  10         21  
  10         614  
69              
70 10     10   65 use constant CALLER_HINT_HASH => 10;
  10         24  
  10         537  
71              
72 10     10   65 use constant DEFAULT_LOAD_ERROR => '%s';
  10         19  
  10         546  
73              
74 10         527 use constant ERR_IMPORT_BAD =>
75 10     10   64 'Import list must be an array reference, or undef';
  10         29  
76 10     10   60 use constant ERR_MODULE_UNDEF => 'Module name must be defined';
  10         51  
  10         543  
77 10     10   63 use constant ERR_OPTION_BAD => 'Bad option';
  10         25  
  10         623  
78 10         577 use constant ERR_SKIP_NUM_BAD =>
79 10     10   68 'Number of skipped tests must be an unsigned integer';
  10         22  
80 10     10   73 use constant ERR_VERSION_BAD => q/Version '%s' is invalid/;
  10         25  
  10         685  
81              
82 10     10   70 use constant HINTS_AVAILABLE => $] ge '5.010';
  10         21  
  10         1566  
83              
84             # The following cribbed shamelessly from version::regex 0.9924,
85             # after being munged to suit by tools/version_regex 0.000_010.
86             # This technical debt is incurred to avoid having to require a version
87             # of the version module large enough to export the is_lax() subroutine.
88 10         724 use constant LAX_VERSION => qr/(?x: (?x:
89             v (?-x:[0-9]+) (?-x: (?-x:\.[0-9]+)+ (?-x:_[0-9]+)? )?
90             |
91             (?-x:[0-9]+)? (?-x:\.[0-9]+){2,} (?-x:_[0-9]+)?
92             ) | (?x: (?-x:[0-9]+) (?-x: (?-x:\.[0-9]+) | \. )? (?-x:_[0-9]+)?
93             |
94             (?-x:\.[0-9]+) (?-x:_[0-9]+)?
95 10     10   90 ) )/;
  10         19  
96              
97 10     10   185 use constant TEST_MORE_ERROR_CONTEXT => q/Tried to %s '%s'./;
  10         24  
  10         726  
98 10     10   75 use constant TEST_MORE_LOAD_ERROR => 'Error: %s';
  10         29  
  10         567  
99 10         8562 use constant TEST_MORE_OPT => {
100             load_error => TEST_MORE_LOAD_ERROR,
101             require => 1,
102 10     10   61 };
  10         19  
103              
104             {
105             my %module_tried;
106              
107             sub load_module_ok (@) { ## no critic (RequireArgUnpacking)
108 16     16 1 49538 my @arg = _validate_args( 0, @_ );
109              
110             # We do this now in case _load_module_ok() throws an uncaught
111             # exception, just so we have SOME record we tried.
112 12         36 $module_tried{ $arg[1] } = undef;
113              
114 12         38 my $ctx = Test2::API::context();
115              
116 12         1109 my $rslt = _load_module_ok( @arg );
117              
118 12         1928 $module_tried{ $arg[1] } = $rslt;
119              
120 12         41 $ctx->release();
121              
122 12         298 return $rslt;
123             }
124              
125             sub all_modules_tried_ok (@) {
126 3     3 1 6633 my @where = @_;
127             @where
128 3 50       12 or @where = ( 'blib/lib', 'blib/arch' );
129              
130 3         22 require File::Find;
131 3         12 require File::Spec;
132              
133 3         6 my @not_tried;
134 3         6 foreach my $d ( @where ) {
135             File::Find::find( sub {
136 15 100   15   1038 m/ [.] pm \z /smx
137             or return;
138 3         310 my ( undef, $dir, $name ) = File::Spec->splitpath(
139             File::Spec->abs2rel( $File::Find::name, $d ) );
140 3         28 my @dir = File::Spec->splitdir( $dir );
141 3 50       12 $dir[-1]
142             or pop @dir;
143 3         20 ( my $module = join '::', @dir, $name ) =~ s/ [.] pm //smx;
144 3 100       152 exists $module_tried{$module}
145             or push @not_tried, $module;
146 6         411 }, $d );
147             }
148              
149 3 100       18 if ( @not_tried ) {
150              
151 2         9 my $ctx = Test2::API::context();
152              
153 2         198 $ctx->fail( "Module $_ not tried" ) for sort @not_tried;
154              
155 2         401 $ctx->release();
156              
157 2         63 return 0;
158             }
159             }
160              
161             sub clear_modules_tried () {
162 1     1 1 645 %module_tried = ();
163 1         3 return;
164             }
165             }
166              
167             sub _load_module_ok {
168 21     21   68 my ( $opt, $module, $version, $import, $name, @diag ) = @_;
169              
170 21         43 local $@ = undef;
171              
172 21         66 my $eval = __build_load_eval( $opt, $module, $version, $import );
173              
174 21 100       61 defined $name
175             or $name = $eval;
176              
177 21         50 my $ctx = Test2::API::context();
178              
179 21 100       1411 _eval_in_pkg( $eval, $ctx->trace()->call() )
180             and return $ctx->pass_and_release( $name );
181              
182 10         40 chomp $@;
183              
184             $opt->{load_error}
185 10 100       62 and push @diag, sprintf $opt->{load_error}, $@;
186              
187 10         56 return $ctx->fail_and_release( $name, @diag );
188             }
189              
190             sub load_module_or_skip (@) { ## no critic (RequireArgUnpacking,RequireFinalReturn)
191 11     11 1 32515 my ( $opt, $module, $version, $import, $name, $num ) = _validate_args( 5, @_ );
192              
193 6 100       20 _load_module( $opt, $module, $version, $import )
194             and return;
195              
196 4 50       40 defined $name
197             or $name = sprintf 'Unable to %s',
198             __build_load_eval( $opt, $module, $version, $import );
199 4 100 100     139 defined $num
200             and $num =~ m/ [^0-9] /smx
201             and croak ERR_SKIP_NUM_BAD;
202              
203 3         11 my $ctx = Test2::API::context();
204 3   100     329 $num ||= 1;
205 3         18 $ctx->skip( 'skipped test', $name ) for 1 .. $num;
206              
207 3         1086 $ctx->release();
208 10     10   88 no warnings qw{ exiting };
  10         23  
  10         18907  
209 3         82 last SKIP;
210             }
211              
212             sub load_module_or_skip_all (@) { ## no critic (RequireArgUnpacking)
213 10     10 1 28061 my ( $opt, $module, $version, $import, $name ) = _validate_args( 4, @_ );
214              
215 5 100       13 _load_module( $opt, $module, $version, $import )
216             and return;
217              
218 3 50       17 defined $name
219             or $name = sprintf 'Unable to %s',
220             __build_load_eval( $opt, $module, $version, $import );
221              
222 3         12 my $ctx = Test2::API::context();
223 3         326 $ctx->plan( 0, SKIP => $name );
224 0         0 $ctx->release();
225              
226 0         0 return;
227             }
228              
229             sub _load_module {
230 11     11   33 my ( $opt, $module, $version, $import ) = @_;
231              
232 11         20 local $@ = undef;
233              
234 11         31 my $eval = __build_load_eval( $opt, $module, $version, $import );
235              
236 11         86 return _eval_in_pkg( $eval, _get_call_info() )
237             }
238              
239             {
240             my $psr;
241              
242             # Because we want to work with Perl 5.8.1 we are limited to
243             # Getopt::Long 2.34, and therefore getoptions(). So we expect the
244             # arguments to be in a suitably-localized @ARGV. The optional
245             # argument is a reference to a hash into which we place the option
246             # values. If omitted, we create a reference to a new hash. Either
247             # way the hash reference gets returned.
248             sub _parse_opts {
249 50     50   118 my ( $opt ) = @_;
250 50   50     168 $opt ||= {};
251             {
252 50 100       84 unless ( $psr ) {
  50         153  
253 9         6930 require Getopt::Long;
254 9         98192 Getopt::Long->VERSION( 2.34 );
255 9         221 $psr = Getopt::Long::Parser->new();
256 9         216 $psr->configure( qw{ posix_default } );
257             }
258              
259 50         776 my $opt_err;
260 50     3   314 local $SIG{__WARN__} = sub { $opt_err = $_[0] };
  3         782  
261             $psr->getoptions( $opt, qw{
262             load_error=s
263             require|req!
264             },
265 50 100       200 ) or do {
266 3 50       182 if ( defined $opt_err ) {
267 3         8 chomp $opt_err;
268 3         343 croak $opt_err;
269             } else {
270 0         0 croak ERR_OPTION_BAD;
271             }
272             };
273             }
274 47 100       14743 if ( $opt->{load_error} ) {
275             $opt->{load_error} =~ m/ ( %+ ) [ #0+-]* [0-9]* s /smx
276             and length( $1 ) % 2
277 34 100 66     336 or $opt->{load_error} = '%s';
278             }
279 47         117 return $opt;
280             }
281             }
282              
283             sub import { ## no critic (RequireArgUnpacking,ProhibitBuiltinHomonyms)
284 18     18   11504 ( my $class, local @ARGV ) = @_; # See _parse_opts
285 18 100       82 if ( @ARGV ) {
286 13         27 my %opt;
287 13         53 _parse_opts( \%opt );
288 13         26 if ( HINTS_AVAILABLE ) {
289 13         91 $^H{ _make_pragma_key() } = $opt{$_} for keys %opt;
290             } else {
291             keys %opt
292             and carp "Import options ignored under Perl $]";
293             }
294             @ARGV
295 13 100       5224 or return;
296             }
297 14         5712 return $class->export_to_level( 1, $class, @ARGV );
298             }
299              
300             sub require_ok ($) {
301 4     4 1 23818 my ( $module ) = @_;
302 4 100       105 defined $module
303             or croak ERR_MODULE_UNDEF;
304 3         8 my $ctx = Test2::API::context();
305 3         264 my $rslt = _load_module_ok( TEST_MORE_OPT,
306             $module, undef, undef, "require $module;",
307             sprintf( TEST_MORE_ERROR_CONTEXT, require => $module ),
308             );
309 3         552 $ctx->release();
310 3         85 return $rslt;
311             }
312              
313             sub use_ok ($;@) {
314 7     7 1 21727 my ( $module, @arg ) = @_;
315 7 100       104 defined $module
316             or croak ERR_MODULE_UNDEF;
317 6 100 100     68 my $version = ( defined $arg[0] && $arg[0] =~ LAX_VERSION ) ?
318             shift @arg : undef;
319 6         16 my $ctx = Test2::API::context();
320 6         504 my $rslt = _load_module_ok( TEST_MORE_OPT,
321             $module, $version, \@arg, undef,
322             sprintf( TEST_MORE_ERROR_CONTEXT, use => $module ),
323             );
324 6         1172 $ctx->release();
325 6         160 return $rslt;
326             }
327              
328             sub _make_pragma_key {
329 4     4   30 return join '', __PACKAGE__, '/', $_;
330             }
331              
332             sub _caller_class {
333 4     4   12 my ( $lvl ) = @_;
334 4   50     29 my ( $pkg ) = caller( $lvl || 1 );
335 4 100       415 my $code = $pkg->can( 'CLASS' )
336             or croak ERR_MODULE_UNDEF;
337 1         9 return $code->();
338             }
339              
340             {
341              
342             my %default_hint = (
343             load_error => DEFAULT_LOAD_ERROR,
344             );
345              
346             sub __get_hint_hash {
347 42     42   722 my ( $level ) = @_;
348 42   100     132 $level ||= 0;
349 42         262 my $hint_hash = ( caller( $level ) )[ CALLER_HINT_HASH ];
350 42         177 my %rslt = %default_hint;
351 42         76 if ( HINTS_AVAILABLE ) {
352 42         69 foreach ( keys %{ $hint_hash } ) {
  42         142  
353 4         37 my ( $hint_pkg, $hint_key ) = split qr< / >smx;
354             __PACKAGE__ eq $hint_pkg
355 4 50       22 and $rslt{$hint_key} = $hint_hash->{$_};
356             }
357             }
358 42         184 return \%rslt;
359             }
360             }
361              
362             sub __build_load_eval {
363 73     73   28887 my @arg = @_;
364 73 100       268 HASH_REF eq ref $arg[0]
365             or unshift @arg, {};
366 73         184 my ( $opt, $module, $version, $import ) = @arg;
367 73         201 my @eval = "use $module";
368              
369 73 100       187 defined $version
370             and push @eval, $version;
371              
372 73 100 100     413 if ( $import && @{ $import } ) {
  29 100 100     124  
373 19         43 push @eval, "qw{ @{ $import } }";
  19         63  
374             } elsif ( defined $import xor not $opt->{require} ) {
375             # Do nothing.
376             } else {
377 12         31 push @eval, '()';
378             }
379              
380 73         518 return "@eval;";
381             }
382              
383             sub _validate_args {
384 37     37   132 ( my $max_arg, local @ARGV ) = @_;
385 37         94 my $opt = _parse_opts( __get_hint_hash( 2 ) );
386              
387 34 100 100     134 if ( $max_arg && @ARGV > $max_arg ) {
388 2         18 ( my $sub_name = ( caller 1 )[3] ) =~ s/ .* :: //smx;
389 2         210 croak sprintf '%s() takes at most %d arguments', $sub_name, $max_arg;
390             }
391              
392 32         96 my ( $module, $version, $import, $name, @diag ) = @ARGV;
393              
394 32 100       89 defined $module
395             or $module = _caller_class( 2 );
396              
397 29 100       69 if ( defined $version ) {
398 7 100       391 $version =~ LAX_VERSION
399             or croak sprintf ERR_VERSION_BAD, $version;
400             }
401              
402 26 100 100     491 not defined $import
403             or ARRAY_REF eq ref $import
404             or croak ERR_IMPORT_BAD;
405              
406 23         106 return ( $opt, $module, $version, $import, $name, @diag );
407             }
408              
409             sub _eval_in_pkg {
410 32     32   291 my ( $eval, $pkg, $file, $line ) = @_;
411              
412 32         126 my $e = <<"EOD";
413             package $pkg;
414             #line $line "$file"
415             $eval;
416             1;
417             EOD
418              
419             # We need the stringy eval() so we can mess with Perl's concept of
420             # what the current file and line number are for the purpose of
421             # formatting the exception, AND as a convenience to get symbols
422             # imported.
423 32         2185 my $rslt = eval $e; ## no critic (ProhibitStringyEval)
424              
425 32         5552 return $rslt;
426             }
427              
428             sub _get_call_info {
429 11     11   21 my $lvl = 0;
430 11         129 while ( my @info = caller $lvl++ ) {
431 33 100       208 __PACKAGE__ eq $info[0]
432             and next;
433 11 50       112 $info[1] =~ m/ \A [(] eval \b /smx # )
434             or return @info;
435             }
436 0           confess 'Bug - Unable to determine caller';
437             }
438              
439             1;
440              
441             __END__