home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Cached.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  9.9 KB  |  439 lines
  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: joker $
  13. # $Date: 2003/09/16 18:16:40 $
  14. # $Revision: 1.2 $
  15. # $Snapshot: /Convert-Binary-C/0.40 $
  16. # $Source: /srv/cvs/tsw/WEB/Apache2/perl/site/lib/Convert/Binary/C/Cached.pm,v $
  17. #
  18. ################################################################################
  19. #
  20. # Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved.
  21. # This program is free software; you can redistribute it and/or modify
  22. # it under the same terms as Perl itself.
  23. #
  24. ################################################################################
  25.  
  26. package Convert::Binary::C::Cached;
  27.  
  28. use strict;
  29. use Convert::Binary::C;
  30. use Carp;
  31. use vars qw( @ISA $VERSION );
  32.  
  33. @ISA = qw(Convert::Binary::C);
  34.  
  35. $VERSION = do { my @r = '$Snapshot: /Convert-Binary-C/0.40 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
  36.  
  37. my %cache;
  38.  
  39. sub new
  40. {
  41.   my $class = shift;
  42.   my $self = $class->SUPER::new;
  43.  
  44.   $cache{"$self"} = {
  45.     cache      => undef,
  46.     parsed     => 0,
  47.     uses_cache => 0,
  48.   };
  49.  
  50.   @_ % 2 and croak "Number of configuration arguments to new must be even";
  51.  
  52.   @_ and $self->configure( @_ );
  53.  
  54.   return $self;
  55. }
  56.  
  57. sub configure
  58. {
  59.   my $self = shift;
  60.  
  61.   if( @_ < 2 and not defined wantarray ) {
  62.     $^W and carp "Useless use of configure in void context";
  63.     return;
  64.   }
  65.  
  66.   my $c = $cache{"$self"};
  67.  
  68.   if( @_ == 0 ) {
  69.     my $cfg = $self->SUPER::configure;
  70.     $cfg->{Cache} = $c->{cache};
  71.     return $cfg;
  72.   }
  73.   elsif( @_ == 1 and $_[0] eq 'Cache' ) {
  74.     return $c->{cache};
  75.   }
  76.  
  77.   my @args;
  78.  
  79.   if( @_ == 1 ) {
  80.     @args = @_;
  81.   }
  82.   elsif( @_ % 2 == 0 ) {
  83.     while( @_ ) {
  84.       my %arg = splice @_, 0, 2;
  85.       if( exists $arg{Cache} ) {
  86.         if( $c->{parsed} ) {
  87.           croak 'Cache cannot be configured after parsing';
  88.         }
  89.         elsif( ref $arg{Cache} ) {
  90.           croak 'Cache must be a string value, not a reference';
  91.         }
  92.         else {
  93.           if( defined $arg{Cache} ) {
  94.             eval { require Data::Dumper };
  95.             if( $@ ) {
  96.               $^W and carp "Cannot load Data::Dumper, disabling cache";
  97.               undef $arg{Cache};
  98.             }
  99.             eval { require IO::File };
  100.             if( $@ ) {
  101.               $^W and carp "Cannot load IO::File, disabling cache";
  102.               undef $arg{Cache};
  103.             }
  104.           }
  105.           $c->{cache} = $arg{Cache};
  106.         }
  107.       }
  108.       else { push @args, %arg }
  109.     }
  110.   }
  111.  
  112.   my $opt = $self;
  113.  
  114.   if( @args ) {
  115.     $opt = eval { $self->SUPER::configure( @args ) };
  116.     $@ =~ s/\s+at.*?Cached\.pm.*//s, croak $@ if $@;
  117.   }
  118.  
  119.   $opt;
  120. }
  121.  
  122. sub clean
  123. {
  124.   my $self = shift;
  125.  
  126.   $cache{"$self"} = {
  127.     cache      => $cache{"$self"}{cache},
  128.     parsed     => 0,
  129.     uses_cache => 0,
  130.   };
  131.  
  132.   $self->SUPER::clean;
  133. }
  134.  
  135. sub clone
  136. {
  137.   my $self = shift;
  138.   my $s = $cache{"$self"};
  139.  
  140.   $s->{parsed} or croak "Call to clone without parse data";
  141.  
  142.   unless( defined wantarray ) {
  143.     $^W and carp "Useless use of clone in void context";
  144.     return;
  145.   }
  146.  
  147.   my $c;
  148.   my $clone = $self->SUPER::clone;
  149.  
  150.   for( keys %$s ) {
  151.     $c->{$_} = ref $_ eq 'ARRAY' ? [@{$s->{$_}}] : $s->{$_};
  152.   }
  153.  
  154.   $cache{"$clone"} = $c;
  155.  
  156.   $clone;
  157. }
  158.  
  159. sub parse_file
  160. {
  161.   my $self = shift;
  162.   eval { $self->__parse( 'file', $_[0] ) };
  163.   $@ =~ s/\s+at.*?Cached\.pm.*//s, croak $@ if $@;
  164. }
  165.  
  166. sub parse
  167. {
  168.   my $self = shift;
  169.   eval { $self->__parse( 'code', $_[0] ) };
  170.   $@ =~ s/\s+at.*?Cached\.pm.*//s, croak $@ if $@;
  171. }
  172.  
  173. sub dependencies
  174. {
  175.   my $self = shift;
  176.   my $c = $cache{"$self"};
  177.  
  178.   $c->{parsed} or croak "Call to dependencies without parse data";
  179.  
  180.   unless( defined wantarray ) {
  181.     $^W and carp "Useless use of dependencies in void context";
  182.     return;
  183.   }
  184.  
  185.   $c->{files} || $self->SUPER::dependencies;
  186. }
  187.  
  188. sub DESTROY
  189. {
  190.   my $self = shift;
  191.   delete $cache{"$self"};
  192.   $self->SUPER::DESTROY;
  193. }
  194.  
  195. sub __uses_cache
  196. {
  197.   my $self = shift;
  198.   $cache{"$self"}{uses_cache};
  199. }
  200.  
  201. sub __parse
  202. {
  203.   my $self = shift;
  204.   my $c = $cache{"$self"};
  205.  
  206.   if( defined $c->{cache} ) {
  207.     $c->{parsed} and croak "Cannot parse more than once for cached objects";
  208.  
  209.     $c->{$_[0]} = $_[1];
  210.  
  211.     if( $self->__can_use_cache ) {
  212.       my @WARN;
  213.       {
  214.         local $SIG{__WARN__} = sub { push @WARN, $_[0] };
  215.         eval { $self->SUPER::parse_file( $c->{cache} ) };
  216.       }
  217.       unless( $@ or @WARN ) {
  218.         $c->{parsed}     = 1;
  219.         $c->{uses_cache} = 1;
  220.         return;
  221.       }
  222.       $self->clean;
  223.     }
  224.   }
  225.  
  226.   $c->{parsed} = 1;
  227.  
  228.   my @warnings;
  229.   {
  230.     local $SIG{__WARN__} = sub { push @warnings, $_[0] };
  231.  
  232.     if( $_[0] eq 'file' ) {
  233.       $self->SUPER::parse_file( $_[1] );
  234.     }
  235.     else {
  236.       $self->SUPER::parse( $_[1] );
  237.     }
  238.   }
  239.  
  240.   for( @warnings ) {
  241.     s/\s+at.*?Cached\.pm.*//s;
  242.     carp $_;
  243.   }
  244.  
  245.   defined $c->{cache} and $self->__save_cache;
  246. }
  247.  
  248. sub __can_use_cache
  249. {
  250.   my $self = shift;
  251.   my $c = $cache{"$self"};
  252.   my $fh = new IO::File;
  253.  
  254.   -e $c->{cache} and -s _ or return 0;
  255.  
  256.   unless( $fh->open( $c->{cache} ) ) {
  257.     $^W and carp "Cannot open '$c->{cache}': $!";
  258.     return 0;
  259.   }
  260.  
  261.   my @config = do {
  262.     defined( my $config = <$fh> ) or return 0;
  263.     $config =~ /^#if\s+0/ or return 0;
  264.     local $/ = $/.'#endif';
  265.     chomp( $config = <$fh> );
  266.     $config =~ s/^\*//gms;
  267.     eval $config;
  268.   };
  269.  
  270.   # corrupt config
  271.   @config % 2 and return 0;
  272.  
  273.   my %config = @config;
  274.  
  275.   my $what = exists $c->{code} ? 'code' : 'file';
  276.  
  277.   exists $config{$what}
  278.       and $config{$what} eq $c->{$what}
  279.       and __reccmp( $config{cfg}, $self->configure )
  280.       or return 0;
  281.  
  282.   while( my($file, $spec) = each %{$config{files}} ) {
  283.     -e $file or return 0;
  284.     my($size, $mtime, $ctime) = (stat(_))[7,9,10];
  285.     $spec->{size} == $size
  286.       and $spec->{mtime} == $mtime
  287.       and $spec->{ctime} == $ctime
  288.       or return 0;
  289.   }
  290.  
  291.   $c->{files} = $config{files};
  292.  
  293.   return 1;
  294. }
  295.  
  296. sub __save_cache
  297. {
  298.   my $self = shift;
  299.   my $c = $cache{"$self"};
  300.   my $fh = new IO::File;
  301.  
  302.   $fh->open( ">$c->{cache}" ) or croak "Cannot open '$c->{cache}': $!";
  303.  
  304.   my $what = exists $c->{code} ? 'code' : 'file';
  305.  
  306.   my $config = Data::Dumper->new( [{ $what  => $c->{$what},
  307.                                      cfg    => $self->configure,
  308.                                      files  => $self->SUPER::dependencies,
  309.                                   }], ['*'] )->Indent(1)->Dump;
  310.   $config =~ s/[^(]*//;
  311.   $config =~ s/^/*/gms;
  312.  
  313.   print $fh "#if 0\n", $config, "#endif\n\n",
  314.             do { local $^W; $self->sourcify };
  315. }
  316.  
  317. sub __reccmp
  318. {
  319.   my($ref, $val) = @_;
  320.  
  321.   !defined($ref) && !defined($val) and return 1;
  322.   !defined($ref) || !defined($val) and return 0;
  323.  
  324.   ref $ref or return $ref eq $val;
  325.  
  326.   if( ref $ref eq 'ARRAY' ) {
  327.     @$ref == @$val or return 0;
  328.     for( 0..$#$ref ) {
  329.       __reccmp( $ref->[$_], $val->[$_] ) or return 0;
  330.     }
  331.   }
  332.   elsif( ref $ref eq 'HASH' ) {
  333.     keys %$ref == keys %$val or return 0;
  334.     for( keys %$ref ) {
  335.       __reccmp( $ref->{$_}, $val->{$_} ) or return 0;
  336.     }
  337.   }
  338.   else { return 0 }
  339.  
  340.   return 1;
  341. }
  342.  
  343. 1;
  344.  
  345. __END__
  346.  
  347. =head1 NAME
  348.  
  349. Convert::Binary::C::Cached - Caching for Convert::Binary::C
  350.  
  351. =head1 SYNOPSIS
  352.  
  353.   use Convert::Binary::C::Cached;
  354.   use Data::Dumper;
  355.   
  356.   #------------------------
  357.   # Create a cached object
  358.   #------------------------
  359.   $c = new Convert::Binary::C::Cached
  360.              Cache   => '/tmp/cache.c',
  361.              Include => ['include']
  362.            ;
  363.   
  364.   #-------------------------------------------------
  365.   # Parse 'stdio.h' and dump the definition of FILE
  366.   #-------------------------------------------------
  367.   $c->parse_file( 'stdio.h' );
  368.   
  369.   print Dumper( $c->typedef( 'FILE' ) );
  370.  
  371. =head1 DESCRIPTION
  372.  
  373. Convert::Binary::C::Cached simply adds caching capability to
  374. Convert::Binary::C. You can use it in just the same way that
  375. you would use Convert::Binary::C. The interface is exactly
  376. the same.
  377.  
  378. To use the caching capability, you must pass the C<Cache> option
  379. to the constructor. If you don't pass it, you will receive
  380. an ordinary Convert::Binary::C object. The argument to
  381. the C<Cache> option is the file that is used for caching
  382. this object.
  383.  
  384. The caching algorithm automatically detects when the cache
  385. file cannot be used and the original code has to be parsed.
  386. In that case, the cache file is updated. An update of the
  387. cache file can be triggered by one or more of the following
  388. factors:
  389.  
  390. =over 2
  391.  
  392. =item *
  393.  
  394. The cache file doesn't exist, which is obvious.
  395.  
  396. =item *
  397.  
  398. The cache file is corrupt, i.e. cannot be parsed.
  399.  
  400. =item *
  401.  
  402. The object's configuration has changed.
  403.  
  404. =item *
  405.  
  406. The embedded code for a L<C<parse>|Convert::Binary::C/"parse"> method
  407. call has changed.
  408.  
  409. =item *
  410.  
  411. At least one of the files that the object depends on
  412. does not exist or has a different size or a different
  413. modification or change timestamp.
  414.  
  415. =back
  416.  
  417. =head1 LIMITATIONS
  418.  
  419. You cannot
  420. call L<C<parse>|Convert::Binary::C/"parse"> or L<C<parse_file>|Convert::Binary::C/"parse_file"> more
  421. that once when using a Convert::Binary::C::Cached object. This isn't
  422. a big problem, as you usually don't call them multiple times.
  423.  
  424. If a dependency file changes, but the change affects neither
  425. the size nor the timestamps of that file, the caching
  426. algorithm cannot detect that an update is required.
  427.  
  428. =head1 COPYRIGHT
  429.  
  430. Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved.
  431. This program is free software; you can redistribute it and/or modify
  432. it under the same terms as Perl itself.
  433.  
  434. =head1 SEE ALSO
  435.  
  436. See L<Convert::Binary::C>.
  437.  
  438. =cut
  439.