File Coverage

blib/lib/File/Modified.pm

Criterion	Covered	Total	%
statement	393	401	98.0
branch	19	28	67.8
condition	8	19	42.1
subroutine	118	119	99.1
pod	5	5	100.0
total	543	572	94.9

package File::Modified;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.09';
our @ISA;

sub new {
  my ($class, %args) = @_;

  my $method = $args{method} || "MD5";
  my $files = $args{files} || [];

  my $self = {
    Defaultmethod => $method,
    Files => {},
  };

  bless $self, $class;

  $self->addfile(@$files);

  return $self;
};

sub _make_digest_signature {
  my ($self,$digest) = @_;

  eval "use Digest::$digest";

  if (! $@) {
    no strict 'refs';
    if (@{"Digest::${digest}::ISA"}) {
      @{"File::Modified::Signature::${digest}::ISA"} = qw(File::Modified::Signature::Digest);
      return 1;
    };
  };
  return undef;
};

sub add {
  my ($self,$filename,$method) = @_;
  $method ||= $self->{Defaultmethod};

  my $signatureclass = "File::Modified::Signature::$method";
  my $s = eval { $signatureclass->new($filename) };
  if (! $@) {
    return $self->{Files}->{$filename} = $s;
  } else {
    # retry and try Digest::$method

    if ($self->_make_digest_signature($method)) {
      my $s = $signatureclass->new($filename);
      return $self->{Files}->{$filename} = $s;
    } else {
      return undef;
    };
  };
};

sub addfile {
  my ($self,@files) = @_;

  my @result;

  # We only return something if the caller wants it
  if (defined wantarray) {
    push @result, $self->add($_) for @files;
    return @result;
  } else {
    $self->add($_) for @files;
  };
};

sub update {
  my ($self) = @_;

  $_->initialize() for values %{$self->{Files}};
};

sub changed {
  my ($self) = @_;

  return map {$_->{Filename}} grep {$_->changed()} (values %{$self->{Files}});
};

1;

{
  package File::Modified::Signature;

  # This is a case where Python would be nicer. With Python, we could have (paraphrased)
  # class File::Modified::Signature;
  #       def initialize(self):
  #           self.hash = self.identificate()
  #           return self
  #       def signature(self):
  #           return MD5(self.filename)
  #       def changed(self):
  #           return self.hash != self.signature()
  # and it would work as expected, (almost) regardless of the structure that is returned
  # by self.signature(). This is some DWIMmery that I sometimes miss in Perl.
  # For now, only string comparisions are allowed.

  sub create {
    my ($class,$filename,$signature) = @_;

    my $self = {
      Filename => $filename,
      Signature => $signature,
    };

    bless $self, $class;
  };

  sub new {
    my ($class,$filename) = @_;

    my $self = $class->create($filename);
    $self->initialize();

    return $self;
  };

  sub initialize {
    my ($self) = @_;
    $self->{Signature} = $self->signature();
    return $self;
  };

  sub from_scalar {
    my ($baseclass,$scalar) = @_;
    die "Strange value in from_scalar: $scalar\n" unless $scalar =~ /^([^|]+)\|([^|]+)\|(.+)$/;
    my ($class,$filename,$signature) = ($1,$2,$3);
    return $class->create($filename,$signature);
  };

  sub as_scalar {
    my ($self) = @_;
    return ref($self) . "|" . $self->{Filename} . "|" . $self->{Signature};
  };

  sub changed {
    my ($self) = @_;
    my $currsig = $self->signature();

    # FIXME: Deep comparision of the two signatures instead of equality !
    # And what's this about string comparisions anyway ?
    if ((ref $currsig) or (ref $self->{Signature})) {
      die "Implementation error in $self : changed() can't handle references and complex structures (yet) !\n";
      #return $currsig != $self->{Signature};
    } else {
      return $currsig ne $self->{Signature};
    };
  };
};

{
  package File::Modified::Signature::mtime;
  use base 'File::Modified::Signature';

  sub signature {
    my ($self) = @_;

    my @stat = stat $self->{Filename} or die "Couldn't stat '$self->{Filename}' : $!";

    return $stat[9];
  };
};

{
  package File::Modified::Signature::Checksum;
  use base 'File::Modified::Signature';

  sub signature {
    my ($self) = @_;
    my $result;
    if (-e $self->{Filename} and -r $self->{Filename}) {
      local *F;
      open F, $self->{Filename} or die "Couldn't read from file '$self->{Filename}' : $!";
      binmode F;

      my $buf;
      while (read(F,$buf,32768)) {
        $result += unpack("%32C*", $buf);
        $result %= 0xFFFFFFFF;
      };

      close F;
    };
    return $result;
  };
};

{
  package File::Modified::Signature::Digest;
  use base 'File::Modified::Signature';

  sub digestname {
    my ($class) = @_;
    $class = ref $class || $class;
    return $1 if ($class =~ /^File::Modified::Signature::([^:]+)$/);
  };

  sub digest {
    my ($self) = @_;
    if (! exists $self->{Digest}) {
      my $digestclass = "Digest::" . $self->digestname;
      eval "use $digestclass";
      $self->{Digest} = $digestclass->new();
    };
    return $self->{Digest};
  };

  sub signature {
    my ($self) = @_;
    my $result;
    if (-e $self->{Filename} and -r $self->{Filename}) {
      local *F;
      open F, $self->{Filename} or die "Couldn't read from file '$self->{Filename}' : $!";
      binmode F;
      $result = $self->digest->addfile(*F)->b64digest();
      close F;
    };
    return $result;
  };
};

1;

__END__