File Coverage

blib/lib/Tie/History.pm

Criterion	Covered	Total	%
statement	151	203	74.3
branch	66	140	47.1
condition	10	15	66.6
subroutine	29	35	82.8
pod	6	7	85.7
total	262	400	65.5

package Tie::History;

use 5.008; # Data::Dumper's use of Sortkeys requires 5.8 or higher
use strict;
use warnings;
use warnings::register;
use Data::Dumper;
use Carp;

our $VERSION = '0.03';

sub TIESCALAR {
  my $self = shift;
  my $args = shift;

  if ($args) {
    unless (ref $args eq 'HASH') {
      croak('->TIESCALAR: First argument to TIESCALAR constructor should be a hash reference');
    }
  }

  my $data = {
    CURRENT    => "",
    PREVIOUS   => [],
    RECENT     => 1, # not really, but we want to prevent a commit on nothing
    ENTRYS     => 0,
    TYPE       => "SCALAR",
    AUTOCOMMIT => $args->{AutoCommit} || 0,
  };
  return bless $data, $self;
}

sub TIEARRAY {
  my $self = shift;
  my $args = shift;

  if ($args) {
    unless (ref $args eq 'HASH') {
      croak('->TIESCALAR: First argument to TIESCALAR constructor should be a hash reference');
    }
  }

  my $data = {
    CURRENT    => [],
    PREVIOUS   => [],
    RECENT     => 1, # not really, but we want to prevent a commit on nothing
    ENTRYS     => 0,
    TYPE       => "ARRAY",
    AUTOCOMMIT => $args->{AutoCommit} || 0,
  };
  return bless $data, $self;
}

sub TIEHASH {
  my $self = shift;
  my $args = shift;

  if ($args) {
    unless (ref $args eq 'HASH') {
      croak('->TIESCALAR: First argument to TIESCALAR constructor should be a hash reference');
    }
  }

  my $data = {
    CURRENT    => {},
    PREVIOUS   => [],
    RECENT     => 1, # not really, but we want to prevent a commit on nothing
    ENTRYS     => 0,
    TYPE       => "HASH",
    AUTOCOMMIT => $args->{AutoCommit} || 0,
  };
  return bless $data, $self;
}

sub commit {
  my $self = shift;
  if ($self->{TYPE} eq "SCALAR") {
    $self->{RECENT} = ($self->{CURRENT} eq ($self->{PREVIOUS}->[-1] || "")) ? 1 : 0;
  }
  elsif ($self->{TYPE} eq "ARRAY") {
    $self->_cmp;
    $self->{RECENT} = 1 if (scalar(@{$self->{CURRENT}}) == 0);
  }
  elsif ($self->{TYPE} eq "HASH") {
    $self->_cmp;
    $self->{RECENT} = 1 if (scalar(keys(%{$self->{CURRENT}})) == 0);
  }
  if ($self->{RECENT} == 1) {
    carp "You can't commit something that has not changed" if (warnings::enabled());
    return 0;
  }
  else {
    if ($self->{TYPE} eq "HASH") {
      push(@{$self->{PREVIOUS}}, {%{$self->{CURRENT}}});
    }
    else{
      push(@{$self->{PREVIOUS}}, $self->{CURRENT});
    }
    $self->{RECENT} = 1;
    $self->{ENTRYS}++;
    return 1;
  }
}

sub setautocommit {
  my $self = shift;
  my $value = shift;
  if ($value == 0) {
    $self->{AUTOCOMMIT} = 0;
  }
  elsif ($value == 1) {
    $self->{AUTOCOMMIT} = 1;
  }
  else {
    croak " ->setautocommit takes either 1 or 0";
  }
}

sub _cmp {
  my $self = shift;
  my $current  = $self->{CURRENT};
  my $previous = $self->{PREVIOUS}->[-1] || "";
  my $c = new Data::Dumper([$current])->Deepcopy(1)->Terse(1)->Purity(1);
  my $p = new Data::Dumper([$previous])->Deepcopy(1)->Terse(1)->Purity(1);
  $c->Sortkeys(1) if ($self->{TYPE} eq "HASH");
  $p->Sortkeys(1) if ($self->{TYPE} eq "HASH");
  $self->{RECENT} = ($p->Dump eq $c->Dump) ? 1 : 0;
}

sub previous {
  my $self = shift;
  return 0 unless $self->_checkentries();
  my $index = ($self->{RECENT}) ? -2 : -1;
  return $self->{PREVIOUS}->[$index];
}

sub current {
  my $self = shift;
  return $self->{CURRENT};
}

sub getall {
  my $self = shift;
  return 0 unless $self->_checkentries();
  return $self->{PREVIOUS};
}

sub get {
  my $self  = shift;
  my $index = shift;
  return 0 unless $self->_checkentries($index);
  return $self->{PREVIOUS}->[$index];
}

sub revert {
  my $self = shift;
  my $index = shift || ($self->{RECENT}) ? -2 : -1;
  return 0 unless $self->_checkentries($index);
  $self->{CURRENT} = $self->{PREVIOUS}->[$index];
  return 1;
}

sub _checkentries {
  my $self  = shift;
  my $index = shift || "NULL";
  if ($self->{ENTRYS} == 0) {
    carp "There are no previous entries" if (warnings::enabled());
    return 0;
  }
  if ($index ne "NULL") {
    if ($index >= $self->{ENTRYS}) {
      carp "Invalid entry" if (warnings::enabled());
      return 0;
    }
  }
  return 1;
}

sub FETCH {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my $indexkey = shift;
  return $self->{CURRENT}              if ($self->{TYPE} eq "SCALAR");
  return $self->{CURRENT}->[$indexkey] if ($self->{TYPE} eq "ARRAY");
  return $self->{CURRENT}->{$indexkey} if ($self->{TYPE} eq "HASH");
}

sub STORE {
  my $self  = shift;
  confess "I am not a class method" unless ref $self;
  if ($self->{TYPE} eq "SCALAR") {
    my $value = shift;
    return $self->{CURRENT} = $value;
  }
  elsif ($self->{TYPE} eq "ARRAY") {
    my $index = shift;
    my $value = shift;
    return $self->{CURRENT}->[$index] = $value;
  }
  elsif ($self->{TYPE} eq "HASH") {
    my $key   = shift;
    my $value = shift;
    return $self->{CURRENT}->{$key} = $value;
  }
  if ($self->{AUTOCOMMIT}) {
    $self->commit;
  }
}

sub UNTIE {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  undef($self->{PREVIOUS});
  return $self->{CURRENT}    if ($self->{TYPE} eq "SCALAR");
  return @{$self->{CURRENT}} if ($self->{TYPE} eq "ARRAY");
  return %{$self->{CURRENT}} if ($self->{TYPE} eq "HASH");
}

sub DESTROY {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
}

sub EXISTS {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my $key = shift;
  if ($self->{TYPE} eq "ARRAY") {
    return 0 if (!defined $self->{CURRENT}->[$key]);
    return 1;
  }
  elsif ($self->{TYPE} eq "HASH") {
    return exists $self->{CURRENT}->{$key};
  }
}

sub CLEAR {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  return $self->{CURRENT} = []    if ($self->{TYPE} eq "ARRAY");
  return %{$self->{CURRENT}} = () if ($self->{TYPE} eq "HASH");
}

sub DELETE {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my $key = shift;
  return $self->STORE($key, undef)       if ($self->{TYPE} eq "ARRAY");
  return delete $self->{CURRENT}->{$key} if ($self->{TYPE} eq "HASH");
}

sub FIRSTKEY {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my $a = scalar keys %{$self->{CURRENT}};
  each %{$self->{CURRENT}};
}

sub NEXTKEY {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my $lastkey = shift;
  each %{$self->{CURRENT}}
}

sub FETCHSIZE {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  return scalar(@{$self->{CURRENT}});
}

sub STORESIZE {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my $count = shift;
  if ($count > $self->FETCHSIZE()) {
    foreach ($count - $self->FETCHSIZE() .. $count - 1) {
      $self->STORE($_, undef);
    }
  }
  elsif ($count < $self->FETCHSIZE()) {
    foreach (0 .. $self->FETCHSIZE() - $count - 2) {
      $self->POP();
    }
  }
}

sub EXTEND {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my $count = shift;
  $self->STORESIZE($count);
}

sub PUSH {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my @list = @_;
  push(@{$self->{CURRENT}}, @list);
  return $self->FETCHSIZE();
}

sub POP {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  return pop @{$self->{CURRENT}};
}

sub SHIFT {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  return shift @{$self->{CURRENT}};
}

sub UNSHIFT {
  my $self = shift;
  confess "I am not a class method" unless ref $self;
  my @list = @_;
  unshift(@{$self->{CURRENT}}, @list);
  return $self->FETCHSIZE();
}

sub SPLICE {
  my $self    = shift;
  confess "I am not a class method" unless ref $self;
  my $size   = $self->FETCHSIZE;
  my $offset = @_ ? shift : 0;
  $offset += $size if $offset < 0;
  my $length = @_ ? shift : $size-$offset;
  return splice(@{$self->{CURRENT}},$offset,$length,@_);
}

1;
__END__