File Coverage

blib/lib/Sub/Genius.pm
Criterion Covered Total %
statement 133 148 89.8
branch 44 58 75.8
condition 9 19 47.3
subroutine 25 27 92.5
pod 10 17 58.8
total 221 269 82.1


line stmt bran cond sub pod time code
1             package Sub::Genius;
2              
3 9     9   8201 use strict;
  9         20  
  9         282  
4 9     9   46 use warnings;
  9         17  
  9         230  
5 9     9   4628 use FLAT::PFA;
  9         1381148  
  9         336  
6 9     9   89 use FLAT::Regex::WithExtraOps;
  9         20  
  9         163  
7 9     9   51 use Digest::MD5 ();
  9         16  
  9         124  
8 9     9   47 use Storable ();
  9         23  
  9         110  
9 9     9   45 use Cwd ();
  9         22  
  9         17517  
10              
11             our $VERSION = q{0.314004};
12              
13             # constructor
14             sub new {
15 22     22 1 8656 my $pkg = shift;
16 22         152 my %self = @_;
17 22         70 my $self = \%self;
18 22         82 bless $self, $pkg;
19 22 50       120 die qq{'preplan' parameter required!\n} if not defined $self->{preplan};
20              
21             # set to undef to disable preprocessing
22 22 100       80 if ( not exists $self->{preprocess} ) {
23 16         73 $self->{preprocess} = 1;
24             }
25              
26             # set to undef to disable caching
27 22 100       77 if ( not exists $self->{cachedir} ) {
28 19         74419 $self->cachedir( sprintf( qq{%s/%s}, Cwd::cwd(), q{_Sub::Genius} ) );
29             }
30              
31             # keep a historical record
32 22         655 $self->original_preplan($self->preplan);
33              
34             # 'pre-process' plan - this step maximizes the chance of capturing
35             # the same checksum for identical PREs that may just be formatted differently
36 22 100       260 if ( $self->{preprocess} ) {
37 16         95 $self->_trim;
38 16         75 $self->_balkanize;
39 16         72 $self->_normalize;
40             }
41              
42             # generates checksum based on post-preprocessed form
43 22         71 $self->checksum( Digest::MD5::md5_hex( $self->preplan ) );
44              
45 22         69 $self->pregex( FLAT::Regex::WithExtraOps->new( $self->preplan ) );
46 22         1101 return $self;
47             }
48              
49             sub cachefile {
50 68     68 1 155 my $self = shift;
51 68 100       152 return ( $self->cachedir ) ? sprintf( qq{%s/%s}, $self->cachedir, $self->checksum ) : undef;
52             }
53              
54             sub cachedir {
55 180     180 1 642 my ( $self, $dir ) = @_;
56 180 100       643 if ($dir) {
57 19         347 $self->{cachedir} = $dir;
58 19 100       777 if ( not -d $self->{cachedir} ) {
59 1         133 mkdir $self->{cachedir}, 0700 || die $!;
60             }
61             }
62 180         672 return $self->{cachedir};
63             }
64              
65             sub checksum {
66 115     115 1 275 my ( $self, $sum ) = @_;
67 115 100       270 if ($sum) {
68 22         97 $self->{checksum} = $sum;
69             }
70 115         2181 return $self->{checksum};
71             }
72              
73             sub do_cache {
74 25     25 0 73 my $self = shift;
75 25   66     108 return ( $self->cachedir and $self->checksum and $self->cachefile );
76             }
77              
78             # strips comments and empty lines
79             sub _trim {
80 16     16   55 my $self = shift;
81 16         104 my $_pre = q{};
82 16         53 my @pre = ();
83             STRIP:
84 16         218 foreach my $line ( split /\n/, $self->{preplan} ) {
85 52 100       424 next STRIP if ( $line =~ m/^\s*#|^\s*$/ );
86 45         285 my @line = split /\s*#/, $line;
87 45         188 push @pre, $line[0];
88             }
89 16         136 $self->preplan( join qq{\n}, @pre );
90 16         61 return $self->preplan;
91             }
92              
93             sub _balkanize {
94 16     16   36 my $self = shift;
95 16 50       104 if ( $self->{preplan} =~ m/[#\[\]]+/ ) {
96 0         0 die qq{plan to be bracketized must not contain '#', '[', or ']'};
97             }
98 16         104 my $_pre = q{};
99 16         44 my @pre = ();
100             STRIP:
101 16         87 foreach my $line ( split /\n/, $self->{preplan} ) {
102              
103             # supports strings with namespace delim, '::'
104 45         526 $line =~ s/([a-zA-Z:_\d]+)/\[$1\]/g;
105 45         220 push @pre, $line;
106             }
107 16         143 $self->preplan( join qq{\n}, @pre );
108 16         46 return $self->preplan;
109             }
110              
111             # currently, removes all spaces and newlines
112             sub _normalize {
113 16     16   43 my $self = shift;
114 16         94 my @pre = split /\n/, $self->{preplan};
115 16         66 my $minified = join qq{}, @pre;
116 16         81 $minified =~ s/[\s]+//g;
117 16         65 $self->preplan($minified);
118 16         48 return $self->preplan;
119             }
120              
121             # accessor for original plan
122             sub original_preplan {
123 22     22 0 99 my ( $self, $pp ) = @_;
124 22 50       138 if ($pp) {
125 22         158 $self->{original_preplan} = $pp;
126             }
127 22         116 return $self->{original_preplan};
128             }
129              
130             # accessor for original plan
131             sub preplan {
132 174     174 1 4288 my ( $self, $pp ) = @_;
133 174 100       429 if ($pp) {
134 48         159 $self->{preplan} = $pp;
135             }
136 174         1848 return $self->{preplan};
137             }
138              
139             # accessor for original
140             sub pregex {
141 47     47 0 1951322 my ( $self, $pregex ) = @_;
142 47 100       1012 if ($pregex) {
143 22         4873 $self->{pregex} = $pregex;
144             }
145 47         284 return $self->{pregex};
146             }
147              
148             # set/updated whenever ->next() and friends are called, simple way to
149             # query what plan was last created; RO, not destructive on current 'plan'
150             sub plan {
151 104     104 0 186 my $self = shift;
152 104         344 return $self->{plan};
153             }
154              
155             # setter/getter for DFA
156             sub dfa {
157 163     163 0 6949240 my ( $self, $dfa ) = @_;
158 163 100       423 if ($dfa) {
159 16         143 $self->{DFA} = $dfa;
160             }
161 163         1167 return $self->{DFA};
162             }
163              
164             # Converts plan -> PFA -> NFA -> DFA:
165             # NOTE: plan is not generated here, much call ->next()
166             # can pass param to underlying ->dfa also, like 'reset => 1'
167             sub init_plan {
168 16     16 1 1709 my ( $self, %opts ) = @_;
169              
170             # requires plan (duh)
171 16 50       59 die qq{Need to call 'new' with 'preplan => q{PRE...}' to initialize\n} if not $self->pregex;
172              
173             # convert PRE to DFA
174 16         2210 $self->convert_pregex_to_dfa(%opts);
175              
176             # warn if DFA is not acyclic (infinite strings accepted)
177 16 50       60 if ( $self->dfa->is_infinite ) {
178 0 0       0 if ( not $self->{'allow-infinite'} ) {
179 0         0 warn qq{(fatal) Infinite language detected. To avoid, do not use Kleene Star (*).\n};
180 0         0 die qq{ pass in 'allow-infinite => 1' to constructor to disable this warning.\n};
181             }
182             }
183              
184             # else - currently no meaningful way to control 'infinite' languages, this needs to
185             # be investigated
186              
187             # returns $self, for chaining in __PACKAGE__->run_any
188 16         18342 return $self;
189             }
190              
191             # to force a reset, pass in, C 1>.; this makes a lot of cool things
192             sub convert_pregex_to_dfa {
193 16     16 0 45 my ( $self, %opts ) = @_;
194              
195             # look for cached DFA
196 16 100 66     183 if ( not $self->{reset} and $self->do_cache ) {
197 15 100       70 if ( -e $self->cachefile ) {
198 7         44 $self->dfa( Storable::retrieve( $self->cachefile ) );
199 7         43 return $self->dfa;
200             }
201             }
202              
203 9 50 33     60 if ( not $self->dfa or defined $opts{reset} ) {
204 9         42 $self->dfa( $self->pregex->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks );
205              
206             # save to cache
207 9 100       1105 if ( $self->do_cache ) {
208 8         35 Storable::store( $self->dfa, $self->cachefile );
209             }
210             }
211 9         4310 return $self->dfa;
212             }
213              
214             # Acyclic String Iterator
215             # force a reset, pass in, C 1>.
216             sub next {
217 77     77 1 77908 my ( $self, %opts ) = @_;
218              
219 77 50       249 die qq{(fatal) Use 'inext' instead of 'next' for infinite languages.\n} if $self->dfa->is_infinite;
220              
221 77 100 100     113516 if ( not defined $self->{_acyclical_iterator} or $opts{reset} ) {
222 9         33 $self->{_acyclical_iterator} = $self->dfa->init_acyclic_iterator(q{ });
223             }
224              
225 77         44105 $self->{plan} = $self->{_acyclical_iterator}->();
226              
227 77         28083 return $self->{plan};
228             }
229              
230             # accepts the same parameters as a constructor, used to re-initialize
231             # the current reference
232             sub plan_nein {
233 0     0 1 0 my $pkg = shift;
234 0         0 my $self = __PACKAGE__->new(@_);
235              
236             # also returns $self for convenience
237 0         0 return $self;
238             }
239              
240             # wrapper that combines C and C to present an idiom,
241             # my $final_scope = Sub::Genius->new($preplan)->run_any( scope => { ... });
242             sub run_any {
243 3     3 1 1643 my ( $self, %opts ) = @_;
244 3         32 $self->init_plan;
245 3         31 my $final_scope = $self->run_once(%opts);
246 3         27 return $final_scope;
247             }
248              
249             # Runs any single serialization ONCE
250             # defaults to main::, specify namespace of $sub
251             #
252             # * ns => q{Some::NS} # specify name space
253             # * scope => { } # specify initial state of pipeline accumulator
254             # * verbose => 0|1 # output runtime diagnostics
255             sub run_once {
256 52     52 1 631 my ( $self, %opts ) = @_;
257              
258             # initialize scope
259 52   50     189 $opts{scope} //= {};
260              
261             # appends '::' (no check if '::' is at the end to encourage a standard idiom)
262 52 100       176 if ( not defined $opts{ns} ) {
263 51         144 $opts{ns} = q{main::};
264             }
265             else {
266 1         4 $opts{ns} .= q{::};
267             }
268              
269             # only call interator if $self->{plan} has not yet been set
270 52 100       170 $self->next if not $self->plan;
271              
272             # check plan is set, just to be sure
273 52 50       137 if ( my $preplan = $self->plan ) {
274 52 50       166 if ( $opts{verbose} ) {
275 0         0 print qq{plan: "$preplan" <<<\n\nExecute:\n\n};
276             }
277 52         257 my @seq = split( / /, $preplan );
278              
279             # main run loop - run once
280 52         104 local $@;
281 52         128 foreach my $sub (@seq) {
282 311         17486 eval sprintf( qq{%s%s(\$opts{scope});}, $opts{ns}, $sub );
283 311 50       7371 die $@ if $@; # be nice and die for easier debuggering
284             }
285             }
286 52         197 return $opts{scope};
287             }
288              
289             #
290             # D R A G O N S
291             # ~~~> *E X P E R I M E N T A L* (not even in POD yet)
292             #
293              
294             # Deep (Infinite) String Iterator
295             # force a reset, pass in, C 1>.
296             #
297             # To us:
298             # my $sq = Sub::Genius=->new(preplan => q{a&b*c}, => 'allow-infinite' => 1);
299             # $sq->init_plan;
300             #
301             #
302             sub inext {
303 0     0 0   my ( $self, %opts ) = @_;
304 0           local $| = 1;
305 0   0       $opts{max} //= 5;
306 0 0 0       if ( not defined $self->{_deepdft_iterator} or $opts{reset} ) {
307 0           $self->{_deepdft_iterator} = $self->dfa->init_deepdft_iterator( $opts{max}, q{ } );
308             }
309              
310 0           $self->{plan} = $self->{_deepdft_iterator}->();
311              
312 0           return $self->{plan};
313             }
314              
315             1;
316              
317             __END__