File Coverage

blib/lib/App/RecordStream/Executor.pm
Criterion Covered Total %
statement 225 253 88.9
branch 8 12 66.6
condition n/a
subroutine 54 57 94.7
pod 0 17 0.0
total 287 339 84.6


line stmt bran cond sub pod time code
1             # This class handles the execution of "perl" code from the commandline on a
2             # record. Handles magic of variable hiding and also special syntax issues.
3              
4             package App::RecordStream::Executor;
5              
6             our $VERSION = "4.0.25";
7              
8 71     71   64413 use strict;
  71         128  
  71         1551  
9 71     70   272 use warnings;
  70         114  
  70         1403  
10              
11 70     70   9610 use App::RecordStream::Operation;
  70         145  
  70         29844  
12              
13             my $NEXT_ID = 0;
14             my $DEFAULT_METHOD_NAME = '__MY__DEFAULT';
15              
16             # snippets is of the form:
17             # name => {
18             # arg_names => ['a', 'b'],
19             #
20             # # one of these:
21             # code => 'code string',
22             # }
23             #
24             sub new {
25 56     56 0 95 my $class = shift;
26 56         69 my $snippets = shift;
27              
28 56 100       122 if ( ref($snippets) ne 'HASH' ) {
29 30         66 my $code = <
30             \$filename = App::RecordStream::Operation::get_current_filename();
31             \$line++;
32             $snippets;
33             CODE
34              
35 30         118 $snippets = {
36             $DEFAULT_METHOD_NAME => {
37             code => $code,
38             arg_names => ['r'],
39             },
40             };
41             }
42              
43 56         142 my $this = {
44             ID => $NEXT_ID,
45             SNIPPETS => $snippets,
46             };
47              
48 56         69 $NEXT_ID++;
49              
50 56         76 bless $this, $class;
51              
52 56         140 $this->init();
53              
54 56         166 return $this;
55             }
56              
57             sub init {
58 56     56 0 142 my $this = shift;
59 56         114 $this->create_safe_package();
60             }
61              
62             sub create_snippets {
63 56     56 0 64 my $this = shift;
64              
65 56         101 my $code = '';
66              
67 56         69 foreach my $name (keys %{$this->{'SNIPPETS'}} ) {
  56         159  
68 106         149 my $arg_names = $this->{'SNIPPETS'}->{$name}->{'arg_names'};
69 106         124 my $args_spec = '';
70              
71 106 100       171 if ( $arg_names ) {
72 56         67 $args_spec = 'my (';
73 56         115 $args_spec .= join(',', map { "\$$_"} @$arg_names);
  132         240  
74 56         97 $args_spec .= ') = @_;';
75             }
76              
77 106         188 my $method_name = $this->get_method_name($name);
78 106         199 my $snippet = $this->transform_code($this->{'SNIPPETS'}->{$name}->{'code'});
79              
80 106         303 $code .= <
81             sub $method_name {
82             $args_spec
83              
84             $snippet
85             }
86             CODE
87             }
88              
89 56         111 return $code;
90             }
91              
92             sub get_method_name {
93 212     212 0 254 my $this = shift;
94 212         249 my $name = shift;
95              
96 212         346 return '__MY__' . $name;
97             }
98              
99             sub get_safe_package_name {
100 106     106 0 141 my $this = shift;
101 106         300 return '__MY__SafeCompartment_' . $this->{'ID'};
102             }
103              
104             sub create_safe_package {
105 56     56 0 71 my $this = shift;
106 56         113 my $package_name = $this->get_safe_package_name();
107 56         103 my $snippets = $this->create_snippets();
108              
109 56         127 my $code = <
110             package $package_name;
111              
112             $snippets
113              
114             1;
115             CODE
116              
117 56         165 eval_safe_package($code);
118 56 50       113 if ( $@ ) {
119 0         0 die $@;
120             }
121              
122 56         69 foreach my $name (keys %{$this->{'SNIPPETS'}}) {
  56         313  
123 106         198 my $method_name = $this->get_method_name($name);
124 106         118 my $code_ref = \&{$package_name . '::' . $method_name};
  106         231  
125 106         221 $this->{'SNIPPETS'}->{$name}->{'CODE_REF'} = $code_ref;
126             }
127             }
128              
129             sub clear_vars {
130 0     0 0 0 my $this = shift;
131              
132 0         0 my $package_name = $this->get_safe_package_name();
133              
134 0         0 my %method_names = map { $this->get_method_name($_) => 1 } keys %{$this->{'SNIPPETS'}};
  0         0  
  0         0  
135              
136             {
137 70     70   467 no strict;
  70         117  
  70         1712  
  0         0  
138 70     70   305 no warnings;
  70         108  
  70         7994  
139              
140 0         0 foreach my $variable (keys %{$package_name . '::'}) {
  0         0  
141 0 0       0 next if ( exists $method_names{$variable} );
142 0         0 undef *{$package_name . '::' . $variable};
  0         0  
143 0         0 delete ${$package_name . '::'}{$variable};
  0         0  
144             }
145             }
146             }
147              
148             sub set_scalar {
149 0     0 0 0 my $this = shift;
150 0         0 my $name = shift;
151 0         0 my $val = shift;
152              
153 0         0 my $package_name = $this->get_safe_package_name();
154              
155             {
156 70     70   413 no strict;
  70         108  
  70         1343  
  0         0  
157 70     70   289 no warnings;
  70         100  
  70         4636  
158              
159 0         0 *{$package_name . '::' . $name} = \$val;
  0         0  
160             }
161             }
162              
163             sub get_scalar {
164 0     0 0 0 my $this = shift;
165 0         0 my $name = shift;
166              
167 0         0 my $package_name = $this->get_safe_package_name();
168              
169             {
170 70     70   371 no strict;
  70         114  
  70         1494  
  0         0  
171 70     70   304 no warnings;
  70         104  
  70         5067  
172              
173 0         0 return ${$package_name . '::' . $name};
  0         0  
174             }
175             }
176              
177             sub set_executor_method {
178 50     50 0 66 my $this = shift;
179 50         56 my $name = shift;
180 50         49 my $ref = shift;
181              
182 50         71 my $package_name = $this->get_safe_package_name();
183              
184             {
185 69     69   371 no strict;
  69         112  
  69         1544  
  50         60  
186 69     69   289 no warnings;
  69         129  
  69         21495  
187              
188 50         49 *{$package_name . "::" . $name} = $ref;
  50         170  
189             }
190             }
191              
192             sub get_code_ref {
193 166     166 0 185 my $this = shift;
194 166         172 my $name = shift;
195 166         2756 $this->{'SNIPPETS'}->{$name}->{'CODE_REF'};
196             }
197              
198             sub eval_safe_package {
199 56     56 0 70 my $__MY__code = shift;
200              
201 56         147 my $code = <
202             no strict;
203             no warnings;
204              
205             $__MY__code
206             CODE
207              
208 56 100   22   3275 eval $code;
  27     12   140  
  27     13   188  
  12     12   227  
  20     10   66  
  20     10   80  
  20     8   1004  
  19     11   79  
  12     8   25  
  23     7   227  
  21     6   68  
  21     6   62  
  21     20   825  
  10     11   51  
  10     14   17  
  10     8   209  
  10     7   41  
  27     6   144  
  26     7   665  
  23     5   77  
  22     5   48  
  14     8   147  
  12     5   40  
  12     5   22  
  12     4   522  
  15     3   48  
  11     2   16  
  11     2   113  
  11     2   144  
  11         21  
  10         313  
  9         27  
  9         15  
  9         76  
  5         16  
  5         11  
  13         267  
  12         25  
  12         17  
  12         229  
  12         31  
  10         18  
  10         163  
  6         21  
  6         17  
  6         128  
  9         170  
  6         14  
  6         159  
  4         83  
  4         8  
  4         322  
  5         19  
  5         11  
  5         65  
  5         15  
  6         14  
  6         209  
  6         22  
  6         15  
  4         181  
  5         14  
  5         66  
  5         149  
  5         17  
  5         16  
  4         151  
  4         33  
  4         5  
  4         303  
  4         16  
  4         18  
  4         51  
  4         16  
  4         7  
  6         183  
  6         24  
  4         12  
  7         167  
  5         5  
  5         8  
  5         8  
  5         9  
  5         10  
  5         13  
  2         5  
  2         2  
  2         4  
  2         4  
  2         7  
  2         2  
  2         4  
  2         5  
  2         8  
  2         5  
  2         4  
  2         2  
  2         7  
  2         6  
  1         2  
  1         2  
  1         1  
  1         6  
  1         3  
  2         4  
  2         3  
  2         4  
  1         4  
  1         1  
  2         3  
  2         5  
  2         5  
  2         7  
  2         2  
  2         5  
  2         4  
  2         5  
  2         6  
  2         3  
  2         3  
  2         2  
  2         4  
209 56 50       194 if ($@) {
210 0         0 die $@;
211             }
212             }
213              
214             sub execute_code {
215 93     93 0 662 my ($this, @args) = @_;
216 91         147 return $this->execute_method($DEFAULT_METHOD_NAME, @args);
217             }
218              
219             sub execute_method {
220 164     164 0 299 my ($this, $name, @args) = @_;
221 164         305 return $this->get_code_ref($name)->(@args);
222             }
223              
224             sub transform_code {
225 957     960 0 1459 my $this = shift;
226 957         1255 my $code = shift;
227              
228 968         2689 while ( $code =~ m/\{\{(.*?)\}\}/ ) {
229 116         283 my $specifier = $1;
230 110         208 my $guessing_code = '${App::RecordStream::KeySpec::find_key($r, qq{\@' . $specifier . '})}';
231 110         537 $code =~ s/\{\{.*?\}\}/$guessing_code/;
232             }
233              
234 943         1878 return $code;
235             }
236              
237             sub usage {
238 23     17 0 55 return <
239             CODE SNIPPETS:
240             __FORMAT_TEXT__
241             Recs code snippets are perl code, with one exception. There a couple of
242             variables predefined for you, and one piece of special syntax to assist in
243             modifying hashes.
244             __FORMAT_TEXT__
245              
246             Special Variables:
247             __FORMAT_TEXT__
248             \$r - the current record object. This may be used exactly like a hash,
249             or you can use some of the special record functions, see App::RecordStream::Record for
250             more information
251              
252             \$line - This is the number of records run through the code snippet,
253             starting at 1. For most scripts this corresponds to the line number of the
254             input to the script.
255              
256             \$filename - The filename of the originating record. Note: This is only
257             useful if you're passing filenames directly to the recs script, piping from
258             other recs scripts or from cat, for instance, will not have a useful
259             filename.
260             __FORMAT_TEXT__
261              
262             Special Syntax
263             __FORMAT_TEXT__
264             Use {{search_string}} to look for a string in the keys of a record, use /
265             to nest keys. You can nest into arrays by using an index. If you are
266             vivifying arrays (if the array doesn't exist, prefix your key with # so
267             that an array rather than a hash will be created to put a / in your key,
268             escape it twice, i.e. \\/
269              
270             This is exactly the same as a key spec that is always prefaced with a @,
271             see 'man recs' for more info on key specs
272             __FORMAT_TEXT__
273              
274             For example: A record that looks like:
275             { "foo" : { "bar 1" : 1 }, "zoo" : 2}
276             Could be accessed like this:
277              
278             # value of zoo # value of \$r->{foo}->{bar 1}: (comma separate nested keys)
279             {{zoo}} {{foo/ar 1}}
280              
281             # Even assign to values (set the foo key to the value 1)
282             {{foo}} = 1
283              
284             # And auto, vivify
285             {{new_key/array_key/#0}} = 3 # creates an array within a hash within a hash
286              
287             # Index into an array
288             {{array_key/#3}} # The value of index 3 of the array ref under the
289             'array_key' hash key.
290              
291             __FORMAT_TEXT__
292             This matching is a fuzzy keyspec matching, see --help-keyspecs for more
293             details.
294             __FORMAT_TEXT__
295             USAGE
296             }
297              
298             sub options_help {
299             return (
300 19     10 0 95 ['e', 'a perl snippet to execute, optional'],
301             ['E', 'the name of a file to read as a perl snippet'],
302             ['M module[=...]', 'execute "use module..." before executing snippet; same behaviour as perl -M'],
303             ['m module[=...]', 'same as -M, but by default import nothing'],
304             );
305             }
306              
307             1;