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