File Coverage

blib/lib/Sub/Genius/Util.pm
Criterion Covered Total %
statement 9 102 8.8
branch 0 26 0.0
condition 0 25 0.0
subroutine 3 12 25.0
pod 0 5 0.0
total 12 170 7.0


line stmt bran cond sub pod time code
1             package Sub::Genius::Util;
2              
3 1     1   905 use strict;
  1         2  
  1         29  
4 1     1   5 use warnings;
  1         2  
  1         27  
5              
6 1     1   475 use parent q{Sub::Genius};
  1         304  
  1         7  
7              
8             # dispatch for invocation method
9             my $invocation = {
10             any => \&_as_any, # invoke plan with run_any
11             all => \&_as_all, # invoke plan with loop using `next` + run_once
12             once => \&_as_once, # invoke plan without dependency on Sub::Genius
13             };
14              
15             sub _as_once {
16 0     0     return qq{
17             ## initialize Sub::Genius (caching 'on' by default)
18             my \$sq = Sub::Genius->new(preplan => qq{\$preplan} );
19             \$sq->init_plan;
20             my \$final_scope = \$sq->run_once( scope => {}, ns => q{main}, verbose => 1);};
21             }
22              
23             sub _as_any {
24 0     0     return qq{
25             ## initialize Sub::Genius (caching 'on' by default)
26             my \$final_state = Sub::Genius->new(preplan => qq{\$preplan})->run_any( scope => {}, ns => q{main}, verbose => 1);};
27             }
28              
29             sub _as_all {
30 0     0     return qq/
31             ## initialize Sub::Genius (caching 'on' by default)
32             my \$sq = Sub::Genius->new(preplan => qq{\$preplan} );
33             \$sq->init_plan;
34             do {
35             my \$final_scope = \$sq->run_once( scope => {}, ns => q{main}, verbose => 1);
36             }
37             while (\$sq->next);
38             /
39             }
40              
41             sub export_as {
42 0     0 0   my ( $self, %opts ) = @_;
43              
44 0 0 0       die qq{'preplan' and 'prefile' are mutually exclusive\n} if ( $opts{preplan} and $opts{prefile} );
45              
46 0 0         if ( defined $opts{prefile} ) {
47 0           local $/ = undef;
48 0   0       open my $ph, q{<}, $opts{prefile} || die $!;
49 0           $opts{preplan} = <$ph>;
50 0           close $ph;
51             }
52              
53 0           my $sq = $self->new(%opts);
54 0           $sq->init_plan;
55 0           print $sq->dfa->as_graphviz; # this is a minimal DFA
56              
57 0           return;
58             }
59              
60             sub list {
61 0     0 0   my ( $self, %opts ) = @_;
62              
63 0 0 0       die qq{'preplan' and 'prefile' are mutually exclusive\n} if ( $opts{preplan} and $opts{prefile} );
64              
65 0 0         if ( defined $opts{prefile} ) {
66 0           local $/ = undef;
67 0   0       open my $ph, q{<}, $opts{prefile} || die $!;
68 0           $opts{preplan} = <$ph>;
69 0           close $ph;
70             }
71              
72 0           my $sq = $self->new(%opts);
73 0           $sq->init_plan;
74              
75 0           while (my $preplan = $sq->next) {
76 0           print qq{$preplan\n};
77             }
78              
79 0           return;
80             }
81              
82             sub subs2perl {
83 0     0 0   my ( $self, %opts ) = @_;
84              
85 0 0 0       die qq{'preplan' and 'prefile' are mutually exclusive\n} if ( $opts{preplan} and $opts{prefile} );
86              
87 0 0         if ( defined $opts{prefile} ) {
88 0           local $/ = undef;
89 0   0       open my $ph, q{<}, $opts{prefile} || die $!;
90 0           $opts{preplan} = <$ph>;
91 0           close $ph;
92             }
93              
94             # PRE is parsed, but not converted to validate it
95 0           my $sq = $self->new(%opts);
96              
97 0           my @subs = split /[^\w]/, $opts{preplan};
98 0           my @pre_tokens = ();
99 0           my @perlsubpod = ();
100              
101             # make sure subs are not repeated
102 0           my %uniq = ();
103 0           foreach my $sub ( @subs ) {
104 0           ++$uniq{$sub};
105             }
106              
107             SUBS:
108 0           foreach my $sub ( keys %uniq ) {
109 0 0         next SUBS if $sub =~ m/^ *$/;
110 0           push @subs, $sub;
111 0           push @pre_tokens, $sub;
112 0           push @perlsubpod, qq{ =item * C<$sub>\n};
113             }
114              
115 0           my $perlsub = $self->_dump_subs( \@subs );
116 0           my $perlpre = $opts{preplan};
117 0           $perlpre =~ s/\n$//;
118 0           $perlpre =~ s/^/ /gm;
119 0           my $perlsubpod = join( qq{\n}, @perlsubpod );
120 0           my $invokemeth = $invocation->{ $opts{q{with-run}} }->();
121              
122 0           my $perl = qq{#!/usr/bin/env perl
123             use strict;
124             use warnings;
125             use feature 'state';
126              
127             use Sub::Genius ();
128              
129             my \$preplan = q{
130             $perlpre
131             };
132              
133             ## intialize hash ref as container for global memory
134             my \$GLOBAL = {};
135            
136             $invokemeth
137              
138             $perlsub
139             exit;
140             __END__
141              
142             =head1 NAME
143              
144             nameMe - something click bait worthy for CPAN
145              
146             =head1 SYNAPSIS
147              
148             ..pithy example of use
149              
150             =head1 DESCRIPTION
151              
152             ..extended wordings on what this thing does
153              
154             =head1 METHODS
155              
156             =over 4
157              
158             $perlsubpod
159             =back
160              
161             =head1 SEE ALSO
162              
163             L, L
164              
165             =head1 COPYRIGHT AND LICENSE
166              
167             Same terms as perl itself.
168              
169             =head1 AUTHOR
170              
171             Rosie Tay Robert Ertr\@example.tldE
172             };
173 0           $perl =~ s/^ //gm;
174 0           return $perl;
175             }
176              
177             sub _dump_subs {
178 0     0     my ( $self, $subs ) = @_;
179              
180 0           my $perl = q{
181             #
182             # S U B R O U T I N E S
183             #
184             };
185              
186             DUMPSUBS:
187 0           foreach my $sub (@$subs) {
188 0 0         if ($sub =~ m/::/g) {
189 0           warn qq{'$sub' appears to be a call to a fully qualified method from an external package. Skipping subroutine stub...\n};
190 0           next DUMPSUBS;
191             }
192 0           $perl .= qq/
193             #TODO - implement the logic!
194             sub $sub {
195             my \$scope = shift; # execution context passed by Sub::Genius::run_once
196             state \$mystate = {}; # sticks around on subsequent calls
197             my \$myprivs = {}; # reaped when execution is out of sub scope
198            
199             #-- begin subroutine implementation here --#
200             print qq{Sub $sub: ELOH! Replace me, I am just placeholder!\\n};
201            
202             # return \$scope, which will be passed to next subroutine
203             return \$scope;
204             }
205             /;
206             }
207 0           return $perl;
208             }
209              
210             #
211             # ####
212             #
213              
214             sub plan2nodeps {
215 0     0 0   my ( $self, %opts ) = @_;
216              
217 0 0 0       die qq{'preplan' and 'prefile' are mutually exclusive\n} if ( $opts{preplan} and $opts{prefile} );
218              
219 0 0         if ( defined $opts{prefile} ) {
220 0           local $/ = undef;
221 0   0       open my $ph, q{<}, $opts{prefile} || die $!;
222 0           $opts{preplan} = <$ph>;
223 0           close $ph;
224             }
225            
226 0           my $sq = $self->new(%opts);
227              
228 0           my $preplan = $sq->original_preplan;
229 0           $preplan =~ s/^/# /gm;
230 0           $preplan =~ s/\n$//g;
231              
232 0           my $perl = qq{ #!/usr/bin/env perl
233             use strict;
234             use warnings;
235             use feature 'state';
236              
237             # Sub::Genius is not used, but this call list has been generated
238             # using Sub::Genius::Util::plan2nodeps,
239             #
240             ## intialize hash ref as container for global memory
241             # The following sequence of calls is consistent with the original preplan,
242             # my \$preplan = q{
243             $preplan
244             # };
245              
246             my \$GLOBAL = {};
247             my \$scope = { thing => 0, };
248             };
249              
250             # init (compiles to DFA)
251 0           $sq->init_plan;
252              
253             # gets serialized execution plan
254 0           my @subs = split / /, $sq->next;
255              
256             # generate shot callers, 50" blades on the empala's
257 0           foreach my $sub (@subs) {
258 0           $perl .= qq{\$scope = $sub(\$scope);\n};
259             }
260              
261             # get uniq list of subs for sub stub generation
262 0           my %uniq = map { $_ => 1 } @subs;
  0            
263              
264 0           $perl .= $self->_dump_subs( [ keys %uniq ] );
265              
266 0           $perl =~ s/^ //gm;
267              
268 0           return $perl;
269             }
270              
271             sub precache {
272 0     0 0   my ( $self, %opts ) = @_;
273              
274 0 0 0       die qq{'preplan' and 'prefile' are mutually exclusive\n} if ( $opts{preplan} and $opts{prefile} );
275              
276             # clean %opts, otherwise Sub::Genius will disable caching
277             # the others are safely ignored
278 0 0         delete $opts{cachedir} if not defined $opts{cachedir};
279              
280 0 0         if ( defined $opts{prefile} ) {
281 0           local $/ = undef;
282 0   0       open my $ph, q{<}, $opts{prefile} || die $!;
283 0           $opts{preplan} = <$ph>;
284 0           close $ph;
285             }
286 0           my $sq = $self->new(%opts)->init_plan;
287 0           return $sq;
288             }
289              
290             1;
291              
292             =head1 NAME
293              
294             Sub::Genius::Util - Helper module for dumping Perl code
295              
296             =head1 SYNOPSIS
297              
298             This is implemented for use with L, please look at that script
299             to see how it's used. This module is lightly documented, to say the least.
300              
301             =head1 DESCRIPTION
302              
303             Useful for dumping a Perl code for starting a module or script that
304             implements the subroutines that are involved in the execution of a C.
305              
306             Given a PRE, dumps a Perl script with the subroutines implied by the
307             symbols in the PREs as subroutines. It might be most effective when called
308             as a one liner,
309              
310             This could get unweildy if you have a concurrent model in place, but
311             anyone reviewing this POD should be able to figure out the best way to
312             leverage C.
313              
314             Each subroutine takes the approximate form,
315              
316             sub C {
317             my $scope = shift; # execution context passed by Sub::Genius::run_once
318             state $mystate = {}; # sticks around on subsequent calls
319             my $myprivs = {}; # reaped when execution is out of sub scope
320            
321             #-- begin subroutine implementation here --#
322             print qq{Sub C: ELOH! Replace me, I am just placeholder!\n};
323            
324             # return $scope, which will be passed to next subroutine
325             return $scope;
326             }
327              
328             =head1 METHODS
329              
330             C
331              
332             Implemented to support the accompanying utility used for initialing a script with
333             L.
334              
335             C
336              
337             Given a PRE, dumps a Perl script that can be run without loading L
338             by providing explicit calls, that also pass along a C<$scope> variable.
339              
340             $ perl -MSub::Genius::Util -e 'print Sub::Genius::Util->plan2nodeps(plan => q{A&B&C&D&E&F&G})' > my-script.pl
341            
342             # does explicitly what Sub::Genius::run_once does, give a sequentialized plan
343             # generated from the PRE, 'A&B&C&D&E&F&G'
344            
345             my $scope = { };
346             $scope = G($scope);
347             $scope = D($scope);
348             $scope = F($scope);
349             $scope = B($scope);
350             $scope = E($scope);
351             $scope = H($scope);
352             $scope = C($scope);
353             $scope = A($scope);
354              
355             C
356              
357             Accepts various parameters for invoking L's caching feature
358             and options. Returns a necessarily initialized Sub::Genius instance. Since
359             this uses Sub::Genius' native handling of caching, the PRE will not be
360             repeatedly cached unless forced.
361              
362             =head1 SEE ALSO
363              
364             L
365              
366             =head1 COPYRIGHT AND LICENSE
367              
368             Same terms as perl itself.
369              
370             =head1 AUTHOR
371              
372             OODLER 577 Eoodler@cpan.orgE
373