File Coverage

blib/lib/App/RecordStream/Executor.pm
Criterion Covered Total %
statement 222 250 88.8
branch 8 12 66.6
condition n/a
subroutine 54 57 94.7
pod 0 17 0.0
total 284 336 84.5


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.24";
7              
8 75     75   70869 use strict;
  75         167  
  75         2002  
9 75     70   399 use warnings;
  70         150  
  70         1761  
10              
11 70     70   7013 use App::RecordStream::Operation;
  70         199  
  70         35607  
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 181 my $class = shift;
26 56         128 my $snippets = shift;
27              
28 56 100       220 if ( ref($snippets) ne 'HASH' ) {
29 30         105 my $code = <
30             \$filename = App::RecordStream::Operation::get_current_filename();
31             \$line++;
32             $snippets;
33             CODE
34              
35 30         167 $snippets = {
36             $DEFAULT_METHOD_NAME => {
37             code => $code,
38             arg_names => ['r'],
39             },
40             };
41             }
42              
43 56         304 my $this = {
44             ID => $NEXT_ID,
45             SNIPPETS => $snippets,
46             };
47              
48 56         129 $NEXT_ID++;
49              
50 56         150 bless $this, $class;
51              
52 56         253 $this->init();
53              
54 56         219 return $this;
55             }
56              
57             sub init {
58 56     56 0 127 my $this = shift;
59 56         212 $this->create_safe_package();
60             }
61              
62             sub create_snippets {
63 56     56 0 114 my $this = shift;
64              
65 56         124 my $code = '';
66              
67 56         121 foreach my $name (keys %{$this->{'SNIPPETS'}} ) {
  56         289  
68 106         274 my $arg_names = $this->{'SNIPPETS'}->{$name}->{'arg_names'};
69 106         214 my $args_spec = '';
70              
71 106 100       287 if ( $arg_names ) {
72 56         121 $args_spec = 'my (';
73 56         174 $args_spec .= join(',', map { "\$$_"} @$arg_names);
  132         432  
74 56         155 $args_spec .= ') = @_;';
75             }
76              
77 106         313 my $method_name = $this->get_method_name($name);
78 106         385 my $snippet = $this->transform_code($this->{'SNIPPETS'}->{$name}->{'code'});
79              
80 106         524 $code .= <
81             sub $method_name {
82             $args_spec
83              
84             $snippet
85             }
86             CODE
87             }
88              
89 56         175 return $code;
90             }
91              
92             sub get_method_name {
93 212     212 0 385 my $this = shift;
94 212         364 my $name = shift;
95              
96 212         597 return '__MY__' . $name;
97             }
98              
99             sub get_safe_package_name {
100 106     106 0 196 my $this = shift;
101 106         398 return '__MY__SafeCompartment_' . $this->{'ID'};
102             }
103              
104             sub create_safe_package {
105 56     56 0 160 my $this = shift;
106 56         214 my $package_name = $this->get_safe_package_name();
107 56         217 my $snippets = $this->create_snippets();
108              
109 56         232 my $code = <
110             package $package_name;
111              
112             $snippets
113              
114             1;
115             CODE
116              
117 56         275 eval_safe_package($code);
118 56 50       208 if ( $@ ) {
119 0         0 die $@;
120             }
121              
122 56         121 foreach my $name (keys %{$this->{'SNIPPETS'}}) {
  56         548  
123 106         301 my $method_name = $this->get_method_name($name);
124 106         204 my $code_ref = \&{$package_name . '::' . $method_name};
  106         404  
125 106         374 $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   571 no strict;
  70         171  
  70         2048  
  0         0  
138 70     70   412 no warnings;
  70         176  
  70         9483  
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   503 no strict;
  70         165  
  70         1614  
  0         0  
157 70     70   347 no warnings;
  70         401  
  70         5371  
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   459 no strict;
  70         160  
  70         1633  
  0         0  
171 70     70   410 no warnings;
  70         158  
  70         5708  
172              
173 0         0 return ${$package_name . '::' . $name};
  0         0  
174             }
175             }
176              
177             sub set_executor_method {
178 50     50 0 108 my $this = shift;
179 50         121 my $name = shift;
180 50         92 my $ref = shift;
181              
182 50         194 my $package_name = $this->get_safe_package_name();
183              
184             {
185 69     69   420 no strict;
  69         157  
  69         1505  
  50         109  
186 69     69   389 no warnings;
  69         164  
  69         25015  
187              
188 50         87 *{$package_name . "::" . $name} = $ref;
  50         357  
189             }
190             }
191              
192             sub get_code_ref {
193 166     166 0 285 my $this = shift;
194 166         268 my $name = shift;
195 166         3918 $this->{'SNIPPETS'}->{$name}->{'CODE_REF'};
196             }
197              
198             sub eval_safe_package {
199 56     56 0 125 my $__MY__code = shift;
200              
201 56         187 my $code = <
202             no strict;
203             no warnings;
204              
205             $__MY__code
206             CODE
207              
208 56 100   18   5254 eval $code;
  27     12   138  
  27     13   86  
  15     12   358  
  25     10   106  
  25     10   71  
  23     8   1184  
  22     11   143  
  12     8   34  
  19     7   298  
  17     6   74  
  17     6   45  
  17     19   1221  
  9     11   74  
  10     17   31  
  10     8   247  
  10     8   56  
  27     6   98  
  25     6   1002  
  21     5   86  
  21     5   313  
  13     6   207  
  12     5   50  
  12     4   32  
  12     4   745  
  10     4   73  
  6     2   130  
  6     2   203  
  11     2   50  
  11         24  
  11         532  
  10         53  
  10         35  
  9         131  
  9         40  
  9         28  
  20         442  
  15         53  
  15         35  
  15         343  
  15         66  
  15         47  
  15         328  
  6         45  
  6         19  
  6         299  
  6         279  
  8         43  
  8         237  
  6         34  
  4         15  
  4         446  
  6         42  
  6         19  
  6         118  
  6         38  
  6         29  
  6         359  
  6         40  
  6         28  
  7         285  
  4         23  
  4         14  
  4         207  
  4         26  
  4         136  
  4         177  
  4         27  
  4         87  
  4         432  
  4         28  
  4         16  
  4         101  
  4         27  
  4         12  
  4         369  
  4         24  
  4         25  
  5         218  
  3         10  
  3         8  
  3         15  
  3         18  
  2         8  
  2         5  
  2         7  
  2         8  
  1         6  
  1         4  
  1         3  
  1         5  
  2         8  
  2         5  
  2         4  
  2         8  
  2         10  
  2         6  
  2         5  
  2         2  
  2         7  
  2         6  
  2         5  
  2         3  
  2         6  
  1         3  
  1         2  
  2         4  
  2         7  
  2         7  
  2         7  
  2         5  
  2         3  
  2         8  
  2         8  
  2         7  
  2         6  
  2         6  
  2         7  
  2         7  
209 56 50       279 if ($@) {
210 0         0 die $@;
211             }
212             }
213              
214             sub execute_code {
215 93     93 0 889 my ($this, @args) = @_;
216 91         216 return $this->execute_method($DEFAULT_METHOD_NAME, @args);
217             }
218              
219             sub execute_method {
220 165     165 0 453 my ($this, $name, @args) = @_;
221 165         456 return $this->get_code_ref($name)->(@args);
222             }
223              
224             sub transform_code {
225 958     956 0 1687 my $this = shift;
226 958         1642 my $code = shift;
227              
228 941         3433 while ( $code =~ m/\{\{(.*?)\}\}/ ) {
229 110         364 my $specifier = $1;
230 106         383 my $guessing_code = '${App::RecordStream::KeySpec::find_key($r, qq{\@' . $specifier . '})}';
231 106         729 $code =~ s/\{\{.*?\}\}/$guessing_code/;
232             }
233              
234 956         2447 return $code;
235             }
236              
237             sub usage {
238 25     17 0 180 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 23     13 0 82 ['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;