File Coverage

blib/lib/Convert/Binary/C/Cached.pm
Criterion Covered Total %
statement 171 195 87.7
branch 102 134 76.1
condition 22 30 73.3
subroutine 17 18 94.4
pod 7 7 100.0
total 319 384 83.1


line stmt bran cond sub pod time code
1             ################################################################################
2             #
3             # MODULE: Convert::Binary::C::Cached
4             #
5             ################################################################################
6             #
7             # DESCRIPTION: Cached version of Convert::Binary::C module
8             #
9             ################################################################################
10             #
11             # $Project: /Convert-Binary-C $
12             # $Author: mhx $
13             # $Date: 2006/11/02 12:54:57 +0100 $
14             # $Revision: 31 $
15             # $Source: /lib/Convert/Binary/C/Cached.pm $
16             #
17             ################################################################################
18             #
19             # Copyright (c) 2002-2006 Marcus Holland-Moritz. All rights reserved.
20             # This program is free software; you can redistribute it and/or modify
21             # it under the same terms as Perl itself.
22             #
23             ################################################################################
24              
25             package Convert::Binary::C::Cached;
26              
27 5     5   69 use strict;
  5         47  
  5         102  
28 5     5   103 use Convert::Binary::C;
  5         46  
  5         62  
29 5     5   139 use Carp;
  5         46  
  5         95  
30 5     5   79 use vars qw( @ISA $VERSION );
  5         45  
  5         116  
31              
32             @ISA = qw(Convert::Binary::C);
33              
34             $VERSION = do { my @r = '$Snapshot: /Convert-Binary-C/0.67 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
35             $VERSION = eval $VERSION;
36              
37             sub new
38             {
39 888     888 1 110901   my $class = shift;
40 888         38481   my $self = $class->SUPER::new;
41              
42 888         10127   $self->{cache} = undef;
43 888         16041   $self->{parsed} = 0;
44 888         10128   $self->{uses_cache} = 0;
45              
46 888 100       17429   @_ % 2 and croak "Number of configuration arguments to new must be even";
47              
48 887 100       12133   @_ and $self->configure(@_);
49              
50 884         12923   return $self;
51             }
52              
53             sub configure
54             {
55 1861     1861 1 26298   my $self = shift;
56              
57 1861 100 100     29221   if (@_ < 2 and not defined wantarray) {
58 3 100       49     $^W and carp "Useless use of configure in void context";
59 3         87     return;
60               }
61              
62 1858 100 33     24162   if (@_ == 0) {
    50          
63 910         54140     my $cfg = $self->SUPER::configure;
64 910         13303     $cfg->{Cache} = $self->{cache};
65 910         46945     return $cfg;
66               }
67               elsif (@_ == 1 and $_[0] eq 'Cache') {
68 0         0     return $self->{cache};
69               }
70              
71 948         9857   my @args;
72              
73 948 50       15858   if (@_ == 1) {
    50          
74 0         0     @args = @_;
75               }
76               elsif (@_ % 2 == 0) {
77 948         12180     while (@_) {
78 1033         14571       my %arg = splice @_, 0, 2;
79 1033 100       16268       if (exists $arg{Cache}) {
80 880 50       11270         if ($self->{parsed}) {
    100          
81 0         0           croak 'Cache cannot be configured after parsing';
82                     }
83                     elsif (ref $arg{Cache}) {
84 1         14           croak 'Cache must be a string value, not a reference';
85                     }
86                     else {
87 879 50       11747           if (defined $arg{Cache}) {
88 879         9022             my @missing;
89 879         10325             eval { require Data::Dumper };
  879         19041  
90 879 100       10550             $@ and push @missing, 'Data::Dumper';
91 879         8999             eval { require IO::File };
  879         13610  
92 879 100       9922             $@ and push @missing, 'IO::File';
93 879 100       10634             if (@missing) {
94 2 50       60               $^W and carp "Cannot load ", join(' and ', @missing), ", disabling cache";
95 2         70               undef $arg{Cache};
96                         }
97                       }
98 879         19394           $self->{cache} = $arg{Cache};
99                     }
100                   }
101 153         2698       else { push @args, %arg }
102                 }
103               }
104              
105 947         32017   my $opt = $self;
106              
107 947 100       15519   if (@args) {
108 106         925     $opt = eval { $self->SUPER::configure(@args) };
  106         3093  
109 106 100       2079     $@ =~ s/\s+at.*?Cached\.pm.*//s, croak $@ if $@;
110               }
111              
112 909         13505   $opt;
113             }
114              
115             sub clean
116             {
117 46     46 1 486   my $self = shift;
118              
119 46         373   delete $self->{$_} for grep !/^(?:|cache|parsed|uses_cache)$/, keys %$self;
  46         1277  
120              
121 46         512   $self->{parsed} = 0;
122 46         392   $self->{uses_cache} = 0;
123              
124 46         2604   $self->SUPER::clean;
125             }
126              
127             sub clone
128             {
129 3     3 1 28   my $self = shift;
130              
131 3 50       32   unless (defined wantarray) {
132 3 100       45     $^W and carp "Useless use of clone in void context";
133 3         78     return;
134               }
135              
136 0         0   my $clone = $self->SUPER::clone;
137              
138 0         0   for (keys %$self) {
139 0 0       0     if ($_) {
140 0 0       0       $clone->{$_} = ref $_ eq 'ARRAY' ? [@{$self->{$_}}] : $self->{$_};
  0         0  
141                 }
142               }
143              
144 0         0   $clone;
145             }
146              
147             sub parse_file
148             {
149 48     48 1 50865   my $self = shift;
150 48         783   my($warn,$error) = $self->__parse('file', $_[0]);
151 47         648   for my $w ( @$warn ) { carp $w }
  0         0  
152 47 100       564   defined $error and croak $error;
153 41 100       671   defined wantarray and return $self;
154             }
155              
156             sub parse
157             {
158 916     916 1 105195   my $self = shift;
159 916         14071   my($warn,$error) = $self->__parse('code', $_[0]);
160 915         10727   for my $w ( @$warn ) { carp $w }
  4         65  
161 915 100       10077   defined $error and croak $error;
162 864 100       21295   defined wantarray and return $self;
163             }
164              
165             sub dependencies
166             {
167 20     20 1 14926   my $self = shift;
168              
169 20 100       246   $self->{parsed} or croak "Call to dependencies without parse data";
170              
171 17 100       205   unless (defined wantarray) {
172 3 100       201     $^W and carp "Useless use of dependencies in void context";
173 3         88     return;
174               }
175              
176 14 100       356   $self->{files} || $self->SUPER::dependencies;
177             }
178              
179             sub __uses_cache
180             {
181 853     853   32113   my $self = shift;
182 853         14776   $self->{uses_cache};
183             }
184              
185             sub __parse
186             {
187 964     964   9643   my $self = shift;
188              
189 964 100       11815   if (defined $self->{cache}) {
190 877 100       10058     $self->{parsed} and croak "Cannot parse more than once for cached objects";
191              
192 876         10643     $self->{$_[0]} = $_[1];
193              
194 876 100       15272     if ($self->__can_use_cache) {
195 44         2018       my @WARN;
196                   {
197 44     0   382         local $SIG{__WARN__} = sub { push @WARN, $_[0] };
  44         1456  
  0         0  
198 44         739         eval { $self->SUPER::parse_file($self->{cache}) };
  44         804752  
199                   }
200 44 100 66     1844       unless ($@ or @WARN) {
201 27         388         $self->{parsed} = 1;
202 27         255         $self->{uses_cache} = 1;
203 27         371         return;
204                   }
205 17         205       $self->clean;
206                 }
207               }
208              
209 936         37542   $self->{parsed} = 1;
210              
211 936         19411   my(@warnings, $error);
212               {
213 936     4   9135     local $SIG{__WARN__} = sub { push @warnings, $_[0] };
  936         123946  
  4         46  
214              
215 936 100       14572     if ($_[0] eq 'file') {
216 23         207       eval { $self->SUPER::parse_file($_[1]) };
  23         256653  
217                 }
218                 else {
219 913         9315       eval { $self->SUPER::parse($_[1]) };
  913         209892  
220                 }
221               }
222              
223 936 100       11813   if ($@) {
224 57         531     $error = $@;
225 57         1195     $error =~ s/\s+at.*?Cached\.pm.*//s;
226               }
227               else {
228 879 100       13566     defined $self->{cache} and $self->__save_cache;
229               }
230              
231 935         87078   for (@warnings) { s/\s+at.*?Cached\.pm.*//s }
  4         67  
232              
233 935         17444   (\@warnings, $error);
234             }
235              
236             sub __can_use_cache
237             {
238 876     876   11027   my $self = shift;
239 876         21186   my $fh = new IO::File;
240              
241 876 100 66     29752   unless (-e $self->{cache} and -s _) {
242 5 50       86     $ENV{CBCC_DEBUG} and print STDERR "CBCC: cache file '$self->{cache}' doesn't exist or is empty\n";
243 5         64     return 0;
244               }
245              
246 871 50       11867   unless ($fh->open($self->{cache})) {
247 0 0       0     $^W and carp "Cannot open '$self->{cache}': $!";
248 0 0       0     $ENV{CBCC_DEBUG} and print STDERR "CBCC: cannot open cache file '$self->{cache}'\n";
249 0         0     return 0;
250               }
251              
252 871         9075   my @config = do {
253 871         8399     my $config;
254 871 50       41748     unless (defined($config = <$fh>)) {
255 0 0       0       $ENV{CBCC_DEBUG} and print STDERR "CBCC: cannot read configuration\n";
256 0         0       return 0;
257                 }
258 871 100       18598     unless ($config =~ /^#if\s+0/) {
259 5 50       60       $ENV{CBCC_DEBUG} and print STDERR "CBCC: invalid configuration\n";
260 5         57       return 0;
261                 }
262 866         15693     local $/ = $/.'#endif';
263 866         28209     chomp($config = <$fh>);
264 866         44224     $config =~ s/^\*//gms;
265 866         72586     eval $config;
266               };
267              
268             # corrupt config
269 866 100       14289   if (@config % 2) {
270 10 50       128     $ENV{CBCC_DEBUG} and print STDERR "CBCC: broken configuration\n";
271 10         125     return 0;
272               }
273              
274 856         10312   my %config = @config;
275              
276 856 100       12145   my $what = exists $self->{code} ? 'code' : 'file';
277              
278 856 100 100     52406   unless (exists $config{$what} and
      100        
279                       $config{$what} eq $self->{$what} and
280                       __reccmp($config{cfg}, $self->configure)) {
281 809 50       14536     if ($ENV{CBCC_DEBUG}) {
282 0         0       print STDERR "CBCC: configuration has changed\n";
283 0         0       print STDERR "CBCC: what='$what', \$config{$what}='$config{$what}' \$self->{$what}='$self->{$what}'\n";
284 0         0       my $dump = Data::Dumper->Dump([$config{cfg}, $self->configure], ['config', 'self']);
285 0         0       $dump =~ s/^/CBCC: /mg;
286 0         0       print STDERR $dump;
287                 }
288 809         9471     return 0;
289               }
290              
291 47         933   while (my($file, $spec) = each %{$config{files}}) {
  3127         50195  
292 3083 50       81132     unless (-e $file) {
293 0 0       0       $ENV{CBCC_DEBUG} and print STDERR "CBCC: file '$file' deleted\n";
294 0         0       return 0;
295                 }
296 3083         38098     my($size, $mtime, $ctime) = (stat(_))[7,9,10];
297 3083 100 100     64275     unless ($spec->{size} == $size and
      66        
298                         $spec->{mtime} == $mtime and
299                         $spec->{ctime} == $ctime) {
300 3 50       35       $ENV{CBCC_DEBUG} and print STDERR "CBCC: size/mtime/ctime of '$file' changed\n";
301 3         44       return 0;
302                 }
303               }
304              
305 44         539   $self->{files} = $config{files};
306              
307 44 50       1712   $ENV{CBCC_DEBUG} and print STDERR "CBCC: '$self->{cache}' is usable\n";
308 44         658   return 1;
309             }
310              
311             sub __save_cache
312             {
313 849     849   8365   my $self = shift;
314 849         18217   my $fh = new IO::File;
315              
316 849 100       13866   $fh->open(">$self->{cache}") or croak "Cannot open '$self->{cache}': $!";
317              
318 848 100       13786   my $what = exists $self->{code} ? 'code' : 'file';
319              
320 848         18468   my $config = Data::Dumper->new([{ $what => $self->{$what},
321                                                 cfg => $self->configure,
322                                                 files => scalar $self->SUPER::dependencies,
323                                              }], ['*'])->Indent(1)->Dump;
324 848         13889   $config =~ s/[^(]*//;
325 848         99870   $config =~ s/^/*/gms;
326              
327               print $fh "#if 0\n", $config, "#endif\n\n",
328 848         11185             do { local $^W; $self->sourcify({ Context => 1 }) };
  848         14687  
  848         12993  
329             }
330              
331             sub __reccmp
332             {
333 1476     1476   16032   my($ref, $val) = @_;
334              
335 1476 100 66     16125   !defined($ref) && !defined($val) and return 1;
336 1466 50 33     26280   !defined($ref) || !defined($val) and return 0;
337              
338 1466 100       19683   ref $ref or return $ref eq $val;
339              
340 331 100       6055   if (ref $ref eq 'ARRAY') {
    50          
341 189 100       2115     @$ref == @$val or return 0;
342 188         2518     for (0..$#$ref) {
343 91 50       1139       __reccmp($ref->[$_], $val->[$_]) or return 0;
344                 }
345               }
346               elsif (ref $ref eq 'HASH') {
347 142 50       1502     keys %$ref == keys %$val or return 0;
348 142         1894     for (keys %$ref) {
349 1337 100       14479       __reccmp($ref->{$_}, $val->{$_}) or return 0;
350                 }
351               }
352 0         0   else { return 0 }
353              
354 329         5867   return 1;
355             }
356              
357             1;
358              
359             __END__
360            
361             =head1 NAME
362            
363             Convert::Binary::C::Cached - Caching for Convert::Binary::C
364            
365             =head1 SYNOPSIS
366            
367             use Convert::Binary::C::Cached;
368             use Data::Dumper;
369            
370             #------------------------
371             # Create a cached object
372             #------------------------
373             $c = Convert::Binary::C::Cached->new(
374             Cache => '/tmp/cache.c',
375             Include => [
376             '/usr/lib/gcc-lib/i686-pc-linux-gnu/3.3.6/include',
377             '/usr/include',
378             ],
379             );
380            
381             #----------------------------------------------------
382             # Parse 'time.h' and dump the definition of timespec
383             #----------------------------------------------------
384             $c->parse_file('time.h');
385            
386             print Dumper($c->struct('timespec'));
387            
388             =head1 DESCRIPTION
389            
390             Convert::Binary::C::Cached simply adds caching capability to
391             Convert::Binary::C. You can use it in just the same way that
392             you would use Convert::Binary::C. The interface is exactly
393             the same.
394            
395             To use the caching capability, you must pass the C<Cache> option
396             to the constructor. If you don't pass it, you will receive
397             an ordinary Convert::Binary::C object. The argument to
398             the C<Cache> option is the file that is used for caching
399             this object.
400            
401             The caching algorithm automatically detects when the cache
402             file cannot be used and the original code has to be parsed.
403             In that case, the cache file is updated. An update of the
404             cache file can be triggered by one or more of the following
405             factors:
406            
407             =over 2
408            
409             =item *
410            
411             The cache file doesn't exist, which is obvious.
412            
413             =item *
414            
415             The cache file is corrupt, i.e. cannot be parsed.
416            
417             =item *
418            
419             The object's configuration has changed.
420            
421             =item *
422            
423             The embedded code for a L<C<parse>|Convert::Binary::C/"parse"> method
424             call has changed.
425            
426             =item *
427            
428             At least one of the files that the object depends on
429             does not exist or has a different size or a different
430             modification or change timestamp.
431            
432             =back
433            
434             =head1 LIMITATIONS
435            
436             You cannot
437             call L<C<parse>|Convert::Binary::C/"parse"> or L<C<parse_file>|Convert::Binary::C/"parse_file"> more
438             that once when using a Convert::Binary::C::Cached object. This isn't
439             a big problem, as you usually don't call them multiple times.
440            
441             If a dependency file changes, but the change affects neither
442             the size nor the timestamps of that file, the caching
443             algorithm cannot detect that an update is required.
444            
445             =head1 COPYRIGHT
446            
447             Copyright (c) 2002-2006 Marcus Holland-Moritz. All rights reserved.
448             This program is free software; you can redistribute it and/or modify
449             it under the same terms as Perl itself.
450            
451             =head1 SEE ALSO
452            
453             See L<Convert::Binary::C>.
454            
455             =cut
456            
457