File Coverage

blib/lib/Test/Stream.pm
Criterion Covered Total %
statement 117 119 98.3
branch 49 56 87.5
condition 14 17 82.3
subroutine 14 14 100.0
pod 0 5 0.0
total 194 211 91.9


line stmt bran cond sub pod time code
1             package Test::Stream;
2 102     102   58828 use strict;
  102         190  
  102         2872  
3 102     102   497 use warnings;
  102         178  
  102         3177  
4 102     102   480 use vars qw/$VERSION/;
  102         173  
  102         6878  
5              
6             $Test::Stream::VERSION = '1.302025';
7             $VERSION = eval $VERSION;
8              
9 102     102   494 use Carp qw/croak/;
  102         183  
  102         6848  
10 102     102   533 use Scalar::Util qw/reftype/;
  102         170  
  102         9491  
11              
12 102     102   55064 use Test::Stream::Sync;
  102         250  
  102         3529  
13              
14 102     102   582 use Test::Stream::Util qw/try pkg_to_file/;
  102         180  
  102         591  
15              
16             sub default {
17 1     1 0 171 croak "No plugins or bundles specified (Maybe try '-Classic'?)"
18             }
19              
20             sub import {
21 121     121   1535 my $class = shift;
22 121         468 my @caller = caller;
23              
24 121 100       545 push @_ => $class->default unless @_;
25              
26 120         483 $class->load(\@caller, @_);
27              
28 118         130293 1;
29             }
30              
31             sub load {
32 156     156 0 323 my $class = shift;
33 156         273 my $caller = shift;
34              
35 156         318 my @order;
36             my %args;
37 0         0 my %skip;
38              
39 156         682 while (my $arg = shift @_) {
40 1745   100     7317 my $type = reftype($arg) || "";
41              
42 1745 100       3683 if ($type eq 'CODE') {
43 113         260 push @order => $arg;
44 113         429 next;
45             }
46              
47             # Strip off the '+', which may be combined with ':' or '-' at the
48             # start.
49 1632 100       3698 my $full = ($arg =~ s/^([!:-]?)\+/$1/) ? 1 : 0;
50              
51             # Disallowed plugin
52 1632 100       4210 if ($arg =~ m/^!(.*)$/) {
53 3 100       11 my $pkg = $full ? $1 : "Test::Stream::Plugin::$1";
54 3         6 $skip{$pkg}++;
55 3         8 next;
56             }
57              
58             # Bundle
59 1629 100       3718 if ($arg =~ m/^-(.*)$/) {
60 162 100       762 my $pkg = $full ? $1 : "Test::Stream::Bundle::$1";
61 162         655 my $file = pkg_to_file($pkg);
62 162         83746 require $file;
63 162         1187 unshift @_ => $pkg->plugins;
64 162         812 next;
65             }
66              
67             # Local Bundle
68 1467 100       3108 if ($arg =~ m/^:(.*)$/) {
69 2 50       10 my $pkg = $full ? $1 : "Test::Stream::Bundle::$1";
70 2         19 my $file = pkg_to_file($pkg);
71              
72             local @INC = (
73             ($ENV{TS_LB_PATH} ? split(':', $ENV{TS_LB_PATH}) : ()),
74             't/lib',
75             'lib',
76             sub {
77 1     1   3 my ($me, $fname) = @_;
78 1 50       4 return unless $fname eq $file;
79 1         19 die "Could not load LOCAL PROJECT bundle '$pkg' (Do you need to set TS_LB_PATH?)\n";
80             },
81 2 50       85 @INC,
82             );
83              
84 2         502 require $file;
85 1         10 unshift @_ => $pkg->plugins;
86 1         13 next;
87             }
88              
89 1465 100       3856 if ($arg =~ m/^[a-z]/) {
90 7         18 my $method = "opt_$arg";
91              
92 7 100       90 die "'$arg' is not a valid option for '$class' (Did you intend to use the '" . ucfirst($arg) . "' plugin?) at $caller->[1] line $caller->[2].\n"
93             unless $class->can($method);
94              
95 6         148 $class->$method(list => \@_, order => \@order, args => \%args, skip => \%skip);
96 6         52 next;
97             }
98              
99             # Load the plugin
100 1458 100       4429 $arg = 'Test::Stream::Plugin::' . $arg unless $full;
101              
102             # Get the value
103 1458         1988 my $val;
104              
105             # Arg is specified
106 1458 100 66     9189 $val = shift @_ if @_ && (ref($_[0]) || ($_[0] && $_[0] eq '*'));
      66        
107              
108             # Special Cases
109 1458 50 100     3920 $val = $val eq '*' ? ['-all'] : [$val]
    100          
110             if defined($val) && !ref($val);
111              
112             # Make sure we only list it in @order once.
113 1458 100       3981 push @order => $arg unless $args{$arg};
114              
115             # Override any existing value, last wins.
116 1458 100       5751 $args{$arg} = $val if defined $val;
117             }
118              
119 154         366 for my $arg (@order) {
120 1567   100     8992 my $type = reftype($arg) || "";
121 1567 100       7529 if ($type eq 'CODE') {
122 113         452 $arg->($caller);
123 113         250 next;
124             }
125              
126 1454 100       3755 next if $skip{$arg};
127              
128 1450         2756 my $import = $args{$arg};
129 1450         2020 my $mod = $arg;
130              
131 1450         4712 my $file = pkg_to_file($mod);
132 1450 100       2630 unless (eval { require $file; 1 }) {
  1450         676925  
  1448         6150  
133 2   50     8 my $error = $@ || 'unknown error';
134 2         3 my $file = __FILE__;
135 2         3 my $line = __LINE__ - 3;
136 2         37 $error =~ s/ at \Q$file\E line $line.*//;
137 2         271 croak "Could not load Test::Stream plugin '$arg': $error";
138             }
139              
140 1448 100       16422 if ($mod->can('load_ts_plugin')) {
    50          
    0          
141 542         2294 $mod->load_ts_plugin($caller, @$import);
142             }
143             elsif (my $meta = Test::Stream::Exporter::Meta->get($mod)) {
144 906         3084 Test::Stream::Exporter::export_from($mod, $caller->[0], $import);
145             }
146             elsif (@$import) {
147 0         0 croak "Module '$mod' does it implement 'load_ts_plugin()', nor does it export using Test::Stream::Exporter."
148             }
149             }
150              
151 139         1000 Test::Stream::Sync->loaded(1);
152             }
153              
154             sub opt_class {
155 5     5 0 24 shift;
156 5         19 my %params = @_;
157 5         9 my $list = $params{list};
158 5         8 my $args = $params{args};
159 5         10 my $order = $params{order};
160              
161 5         9 my $class = shift @$list;
162              
163 3         9 push @{$params{order}} => 'Test::Stream::Plugin::Class'
164 5 100       19 unless $args->{'Test::Stream::Plugin::Class'};
165              
166 5         20 $args->{'Test::Stream::Plugin::Class'} = [$class];
167             }
168              
169             sub opt_skip_without {
170 4     4 0 20 shift;
171 4         17 my %params = @_;
172 4         8 my $list = $params{list};
173 4         8 my $args = $params{args};
174 4         5 my $order = $params{order};
175              
176 4         10 my $class = shift @$list;
177              
178 3         7 push @{$params{order}} => 'Test::Stream::Plugin::SkipWithout'
179 4 100       12 unless $args->{'Test::Stream::Plugin::SkipWithout'};
180              
181 4   100     24 $args->{'Test::Stream::Plugin::SkipWithout'} ||= [];
182 4         4 push @{$args->{'Test::Stream::Plugin::SkipWithout'}} => $class;
  4         16  
183             }
184              
185             sub opt_srand {
186 2     2 0 18 shift;
187 2         9 my %params = @_;
188 2         4 my $list = $params{list};
189 2         4 my $args = $params{args};
190 2         4 my $order = $params{order};
191              
192 2         4 my $seed = shift @$list;
193              
194 1         3 push @{$params{order}} => 'Test::Stream::Plugin::SRand'
195 2 100       7 unless $args->{'Test::Stream::Plugin::SRand'};
196              
197 2         9 $args->{'Test::Stream::Plugin::SRand'} = [$seed];
198             }
199              
200             1;
201              
202             __END__