File Coverage

blib/lib/Parse/Eyapp/Base.pm
Criterion Covered Total %
statement 49 174 28.1
branch 0 74 0.0
condition 0 15 0.0
subroutine 17 32 53.1
pod 0 16 0.0
total 66 311 21.2


line stmt bran cond sub pod time code
1             package Parse::Eyapp::Base;
2 61     61   342 use strict;
  61         114  
  61         1385  
3 61     61   259 use warnings;
  61         106  
  61         1419  
4 61     61   254 use Carp;
  61         123  
  61         3321  
5 61     61   324 use List::Util qw(first);
  61         139  
  61         6787  
6              
7             BEGIN {
8 61     61   362 our @EXPORT_OK = qw(
9             compute_lines
10             empty_method
11             slurp_file
12             valid_keys
13             invalid_keys
14             write_file
15             numbered
16             insert_function
17             insert_method
18             delete_method
19             push_method
20             push_empty_method
21             pop_method
22             firstval
23             lastval
24             part
25             );
26 61         1241 our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
27              
28             }
29 61     61   346 use base qw(Exporter);
  61         121  
  61         37224  
30              
31             our $FILENAME=__FILE__;
32              
33             sub firstval(&@) {
34 25     25 0 546 my $handler = shift;
35            
36 25         69 return (grep { $handler->($_) } @_)[0]
  44         169  
37             }
38              
39             sub lastval(&@) {
40 0     0 0 0 my $handler = shift;
41            
42 0         0 return (grep { $handler->($_) } @_)[-1]
  0         0  
43             }
44              
45             # Receives a handler $h and a list @_
46             # Elements of @_ with the same value of $h go to the same sublist
47             # Returns a list of lists
48             sub part(&@) {
49 0     0 0 0 my $h = shift;
50              
51 0         0 my @p;
52 0         0 push @{$p[$h->($_)]}, $_ for (@_);
  0         0  
53 0         0 return @p;
54             }
55              
56             ####################################################################
57             # Usage : $input = slurp_file($filename, 'trg');
58             # Purpose : opens "$filename.trg" and sets the scalar
59             # Parameters : file name and extension (not icluding the dot)
60             # Comments : Is this O.S dependent?
61              
62             sub slurp_file {
63 0     0 0 0 my ($filename, $ext) = @_;
64              
65 0 0 0     0 croak "Error in slurp_file opening file. Provide a filename!\n"
66             unless defined($filename) and length($filename) > 0;
67 0 0       0 $ext = "" unless defined($ext);
68 0 0 0     0 $filename .= ".$ext" unless (-r $filename) or ($filename =~ m{[.]$ext$});
69 0         0 local $/ = undef;
70 0 0       0 open my $FILE, $filename or croak "Can't open file $filename";
71 0         0 my $input = <$FILE>;
72 0         0 close($FILE);
73 0         0 return $input;
74             }
75              
76             sub valid_keys {
77 36     36 0 224 my %valid_args = @_;
78              
79 36         191 my @valid_args = keys(%valid_args);
80 36         121 local $" = ", ";
81 36         269 return "@valid_args"
82             }
83              
84             sub invalid_keys {
85 30     30 0 72 my $valid_args = shift;
86 30         69 my $args = shift;
87              
88 30     51   301 return (first { !exists($valid_args->{$_}) } keys(%$args));
  51         232  
89             }
90              
91             sub write_file {
92 0     0 0   my ($outputfile, $text) = @_;
93 0 0         defined($outputfile) or croak "Error at write_file. Undefined file name";
94              
95 0           my $OUTPUTFILE;
96            
97 0 0         open($OUTPUTFILE, "> $outputfile") or croak "Can't open file $OUTPUTFILE.";
98 0           print $OUTPUTFILE ($$text);
99 0 0         close($OUTPUTFILE) or croak "Can't close file $OUTPUTFILE.";
100             }
101              
102             # Sort of backpatching for line number directives:
103             # Substitutes $pattern by #line $number $filename in string $textr
104             sub compute_lines {
105 0     0 0   my ($textr, $filename, $pattern) = @_;
106            
107 0           local $_ = 1;
108 0           $$textr =~ s{\n$pattern\n|(\n)}
109             {
110 0           $_++;
111 0 0         if (defined($1)) {
112 0           "\n";
113             }
114             else {
115 0           my $directive = "\n#line $_ $filename\n";
116 0           $_++;
117 0           $directive;
118             }
119             }eg;
120             }
121              
122             sub numbered {
123 0     0 0   my ($output, $c) = (shift(), 1);
124 0           my $cr = $output =~ tr/\n//;
125 0 0         $cr = 1 if $cr <= 0;
126 0           my $digits = 1+int(log($cr)/log(10));
127 0           $output =~ s/^/sprintf("%${digits}d ",$c++)/emg;
  0            
128 0           $output;
129             }
130              
131             sub insert_function {
132 61     61   427 no warnings;
  61         131  
  61         2211  
133 61     61   302 no strict;
  61         128  
  61         24412  
134              
135 0     0 0   my $code = pop;
136 0 0         croak "Error in insert_function: last arg must be a CODE ref\n"
137             unless ref($code) eq 'CODE';
138              
139 0           for (@_) {
140 0 0         croak "Error in insert_function: Illegal function name <$_>\n" unless /^[\w:]+$/;
141 0 0         my $fullname = /^\w+$/? scalar(caller).'::'.$_ : $_;
142 0           *{$fullname} = $code;
  0            
143             }
144             }
145              
146             sub insert_method {
147              
148 0     0 0   my $code = pop;
149              
150 0 0         unless (ref($code)) { # not a ref: string or undef
151             # Call is: insert_method('Tutu', 'titi')
152 0 0 0       if (defined($code) && $code =~/^\w+$/) {
153 0           delete_method(@_, $code);
154 0           return;
155             }
156             # Call is: insert_method('Tutu', 'titi', undef)
157 0           goto &delete_method;
158             }
159 0 0         croak "Error in insert_method: expected a CODE ref found $code\n"
160             unless ref($code) eq 'CODE';
161              
162 0           my $name = pop;
163 0 0         croak "Error in insert_method: Illegal method name <$_>\n" unless $name =~/^\w+$/;
164              
165 0           my @classes = @_;
166 0 0         @classes = scalar(caller) unless @classes;
167 0           for (@classes) {
168 0 0         croak "Error in insert_method: Illegal class name <$_>\n" unless /^[\w:]+$/;
169 61     61   403 no warnings 'redefine';;
  61         123  
  61         1818  
170 61     61   291 no strict 'refs';
  61         115  
  61         7881  
171 0           *{$_."::".$name} = $code;
  0            
172             }
173             }
174              
175             sub delete_method {
176 0     0 0   my $name = pop;
177 0 0         $name = '' unless defined($name);
178 0 0         croak "Error in delete_method: Illegal method name <$name>\n" unless $name =~/^\w+$/;
179 0           my @classes = @_;
180              
181 0 0         @classes = scalar(caller) unless @classes;
182 61     61   350 no strict 'refs';
  61         114  
  61         25576  
183 0           for (@classes) {
184 0 0         croak "Error in delete_method: Illegal class name <$_>\n" unless /^[\w:]+$/;
185 0 0         unless ($_->can($name)) {
186 0           print STDERR "Warning in delete_method: No sub <$name> to delete in package <$_>\n";
187 0           next;
188             }
189 0           my $fullname = $_."::".$name;
190              
191             # Temporarily save the other entries
192 0           my @refs = map { *{$fullname}{$_} } qw{HASH SCALAR ARRAY GLOB};
  0            
  0            
193              
194             # Delete typeglob
195 0           *{$fullname} = do { local *{$fullname} };
  0            
  0            
  0            
196              
197             # Restore HASH SCALAR ARRAY GLOB entries
198 0           for (@refs) {
199 0 0         next unless defined($_);
200 0           *{$fullname} = $_;
  0            
201             }
202             }
203             }
204              
205             sub empty_method {
206 0     0 0   insert_method(@_, sub {});
        0      
207             }
208              
209             sub push_empty_method {
210 0     0 0   push_method(@_, sub {});
        0      
211             }
212              
213             {
214             my %methods;
215              
216             sub push_method {
217 0     0 0   my $handler;
218 0 0         if (ref($_[-1]) eq 'CODE') {
219 0           $handler = pop;
220             }
221             else {
222 0           $handler = undef;
223             }
224              
225 0           my $name = pop;
226 0 0         $name = '' unless defined($name);
227 0 0         croak "Error in push_method: Illegal method name <$name>\n" unless $name =~/^\w+$/;
228 0           my @classes = @_;
229              
230 0           my @returnmethods;
231              
232 0 0         @classes = scalar(caller) unless @classes;
233 0           for (@classes) {
234 0 0         croak "Error in push_method: Illegal class name <$_>\n" unless /^[\w:]+$/;
235 0           my $fullname = $_."::".$name;
236 0 0         if ($_->can($name)) {
237 61     61   398 no strict 'refs';
  61         114  
  61         10950  
238 0           my $coderef = \&{$fullname};
  0            
239 0           push @returnmethods, $coderef;
240 0           push @{$methods{$fullname}}, $coderef;
  0            
241             }
242             else {
243 0           push @returnmethods, undef;
244 0           push @{$methods{$fullname}}, undef;
  0            
245             }
246             }
247 0           insert_method(@classes, $name, $handler);
248            
249 0 0         return wantarray? @returnmethods : $returnmethods[0];
250             }
251              
252             sub pop_method {
253 0     0 0   my $name = pop;
254 0 0         $name = '' unless defined($name);
255 0 0         croak "Error in push_method: Illegal method name <$name>\n" unless $name =~/^\w+$/;
256 0           my @classes = @_;
257              
258 0           my @returnmethods;
259              
260 0 0         @classes = scalar(caller) unless @classes;
261 0           for (@classes) {
262 0           my $fullname = $_."::".$name;
263 61     61   369 no strict 'refs';
  61         124  
  61         6964  
264 0 0         push @returnmethods, $_->can($name)? \&{$fullname} : undef;
  0            
265 0 0 0       if (defined($methods{$fullname})
      0        
266             && UNIVERSAL::isa($methods{$fullname}, 'ARRAY')
267 0           && @{$methods{$fullname}}) {
268 0           my $handler = pop @{$methods{$fullname}};
  0            
269 0           insert_method($_, $name, $handler);
270             }
271             }
272 0 0         return wantarray? @returnmethods : $returnmethods[0];
273             }
274              
275             } # Closure for %methods
276              
277             1;
278