view release on metacpan or  search on metacpan

lib/Convert/Binary/C/Cached.pm  view on Meta::CPAN

  my $self = shift;
  my $fh = IO::File->new;

  unless (-e $self->{cache} and -s _) {
    $ENV{CBCC_DEBUG} and print STDERR "CBCC: cache file '$self->{cache}' doesn't exist or is empty\n";
    return 0;
  }

  unless ($fh->open($self->{cache})) {
    $^W and carp "Cannot open '$self->{cache}': $!";
    $ENV{CBCC_DEBUG} and print STDERR "CBCC: cannot open cache file '$self->{cache}'\n";
    return 0;
  }

  my @warnings;
  my @config = do {
    my $config;
    unless (defined($config = <$fh>)) {
      $ENV{CBCC_DEBUG} and print STDERR "CBCC: cannot read configuration\n";
      return 0;
    }
    unless ($config =~ /^#if\s+0/) {
      $ENV{CBCC_DEBUG} and print STDERR "CBCC: invalid configuration\n";
      return 0;
    }
    local $/ = $/.'#endif';
    chomp($config = <$fh>);
    $config =~ s/^\*//gms;
    local $SIG{__WARN__} = sub { push @warnings, $_[0] };
    eval $config;
  };

  # corrupt config
  if ($@ or @warnings or @config % 2) {
    $ENV{CBCC_DEBUG} and print STDERR "CBCC: broken configuration\n";
    return 0;
  }

  my %config = @config;

  my $what = exists $self->{code} ? 'code' : 'file';

  unless (exists $config{$what} and
          $config{$what} eq $self->{$what} and
          __reccmp($config{cfg}, $self->configure)) {
    if ($ENV{CBCC_DEBUG}) {
      print STDERR "CBCC: configuration has changed\n";
      print STDERR "CBCC: what='$what', \$config{$what}='$config{$what}' \$self->{$what}='$self->{$what}'\n";
      my $dump = Data::Dumper->Dump([$config{cfg}, $self->configure], ['config', 'self']);
      $dump =~ s/^/CBCC: /mg;
      print STDERR $dump;
    }
    return 0;
  }

  while (my($file, $spec) = each %{$config{files}}) {
    unless (-e $file) {
      $ENV{CBCC_DEBUG} and print STDERR "CBCC: file '$file' deleted\n";
      return 0;
    }
    my($size, $mtime, $ctime) = (stat(_))[7,9,10];
    unless ($spec->{size} == $size and
            $spec->{mtime} == $mtime and
            $spec->{ctime} == $ctime) {
      $ENV{CBCC_DEBUG} and print STDERR "CBCC: size/mtime/ctime of '$file' changed\n";
      return 0;
    }
  }

  $self->{files} = $config{files};

  $ENV{CBCC_DEBUG} and print STDERR "CBCC: '$self->{cache}' is usable\n";
  return 1;
}

sub __save_cache
{
  my $self = shift;
  my $fh = IO::File->new;

  $fh->open(">$self->{cache}") or croak "Cannot open '$self->{cache}': $!";

  my $what = exists $self->{code} ? 'code' : 'file';

  my $config = Data::Dumper->new([{ $what => $self->{$what},
                                    cfg   => $self->configure,
                                    files => scalar $self->SUPER::dependencies,
                                 }], ['*'])->Indent(1)->Dump;
  $config =~ s/[^(]*//;
  $config =~ s/^/*/gms;

  print $fh "#if 0\n", $config, "#endif\n\n",
            do { local $^W; $self->sourcify({ Context => 1 }) };
}

sub __reccmp
{
  my($ref, $val) = @_;

  !defined($ref) && !defined($val) and return 1;
  !defined($ref) || !defined($val) and return 0;

  ref $ref or return $ref eq $val;

  if (ref $ref eq 'ARRAY') {
    @$ref == @$val or return 0;
    for (0..$#$ref) {
      __reccmp($ref->[$_], $val->[$_]) or return 0;
    }
  }
  elsif (ref $ref eq 'HASH') {
    keys %$ref == keys %$val or return 0;
    for (keys %$ref) {
      __reccmp($ref->{$_}, $val->{$_}) or return 0;
    }
  }
  else { return 0 }

  return 1;
}