Data::Transactional - data structures with RDBMS-like transactions

    use Data::Transactional;

    my $data = Data::Transactional->new(type => 'hash');
    $data->{food_and_drink} = [ [], [] ];
    $data->checkpoint();
    $data->{food_and_drink}->[0] = [qw(pie curry chips)];
    $data->checkpoint();
    $data->{food_and_drink}->[1] = [qw(beer gin whisky)];
    $data->rollback();   # back to last checkpoint

package Data::Transactional;

use strict;
use warnings;

our $VERSION = '1.02';

use Data::Dumper;

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

    $args{type} ||= 'HASH'; $args{type} = uc($args{type});

    if($args{type} eq 'HASH') {
        tie %{$self}, __PACKAGE__.'::Hash';
    } elsif($args{type} eq 'ARRAY') {
        tie @{$self}, __PACKAGE__.'::Array';
    } else {
        die(__PACKAGE__."::new(): type '$args{type}' unknown\n");
    }

    return bless $self, $class;
}

sub checkpoint {
    my $self = shift;
    (tied %{$self})->checkpoint();
}

# should this also commit_all in sub-structures?
sub commit {
    my $self = shift;
    (tied %{$self})->commit();
}

sub commit_all {
    my $self = shift;
    undef $@;
    while(!$@) { eval { $self->commit(); }; }
}

sub rollback {
    my $self = shift;
    (tied %{$self})->rollback();
}

sub rollback_all {
    my $self = shift;
    undef $@;
    while(!$@) { eval { $self->rollback(); }; }
}

sub current_state {
    my $self = shift;
    return $self->isa('HASH') ?
        tied(%{$self})->current_state() :
        tied(@{$self})->current_state();
}

package Data::Transactional::Hash;
use Storable qw(dclone);
use strict;use warnings;

sub TIEHASH {
    my $class = shift;
    my $self = {
        STACK           => [],
        CURRENT_STATE   => {},
    };

    return bless $self, $class;
}

sub CLEAR {
    my $self=shift;
    $self->{CURRENT_STATE}={};
}

sub STORE {
    my($self, $key, $value)=@_;
    my $newobj = $value;
    if(ref($value)) {
        if(ref($value) eq 'ARRAY') {
	    $newobj = Data::Transactional->new(type => 'ARRAY');
	    # @{$newobj} = @{$value};
	    push @{$newobj}, $_ foreach(@{$value});
	} elsif(ref($value) eq 'HASH') {
	    $newobj = Data::Transactional->new(type => 'HASH');
	    # %{$newobj} = %{$value};
	    $newobj->{$_} = $value->{$_} foreach(keys %{$value});
	} else {
            die(__PACKAGE__."::STORE(): don't know how to store a ".ref($value)."\n");
	}
    }
    $self->{CURRENT_STATE}->{$key} = $newobj;
}

sub FETCH {
    my($self, $key) = @_;
    $self->{CURRENT_STATE}->{$key};
}

sub FIRSTKEY {
    my $self = shift;
    scalar keys %{$self->{CURRENT_STATE}};   # reset iterator
    # scalar each %{$self->{CURRENT_STATE}};
    $self->NEXTKEY();
}

sub NEXTKEY { my $self = shift; scalar each %{$self->{CURRENT_STATE}}; }
sub DELETE { my($self, $key) = @_; delete $self->{CURRENT_STATE}->{$key}; }
sub EXISTS { my($self, $key) = @_; exists($self->{CURRENT_STATE}->{$key}); }

sub checkpoint {
    my $self = shift;
    # make a new copy of CURRENT_STATE before putting on stack,
    # otherwise CURRENT_STATE and top-of-STACK will reference the
    # same data structure, which would be a Bad Thing
    push @{$self->{STACK}}, dclone($self->{CURRENT_STATE});
}

sub commit {
    my $self = shift;
    # $self->{STACK}=[];                     # clear all checkpoints
    defined(pop(@{$self->{STACK}})) ||
        die("Attempt to commit without a checkpoint");
}

sub rollback {
    my $self = shift;
    die("Attempt to rollback too far") unless(@{$self->{STACK}});
    # no copying required, just update a pointer
    $self->{CURRENT_STATE}=pop @{$self->{STACK}};
}

sub current_state {
    shift->{CURRENT_STATE};
}

package Data::Transactional::Array;
use Storable qw(dclone);
use strict;use warnings;

sub TIEARRAY {
    my $class = shift;
    my $self = {
        STACK           => [],
        CURRENT_STATE   => [],
    };

    return bless $self, $class;
}

sub CLEAR {
    my $self=shift;
    $self->{CURRENT_STATE}=[];
}

sub STORE {
    my($self, $index, $value)=@_;
    my $newobj = $value;
    if(ref($value)) {
        if(ref($value) eq 'ARRAY') {
	    $newobj = Data::Transactional->new(type => 'ARRAY');
	    # @{$newobj} = @{$value};
	    push @{$newobj}, $_ foreach(@{$value});
	} elsif(ref($value) eq 'HASH') {
	    $newobj = Data::Transactional->new(type => 'HASH');
	    # %{$newobj} = %{$value};
	    $newobj->{$_} = $value->{$_} foreach(keys %{$value});
	} else {
            die(__PACKAGE__."::STORE(): don't know how to store a ".ref($value)."\n");
	}
    }
    $self->{CURRENT_STATE}->[$index] = $newobj;
}

sub FETCH {
    my($self, $index) = @_;
    $self->{CURRENT_STATE}->[$index];
}

sub DELETE { my($self, $index) = @_; delete $self->{CURRENT_STATE}->[$index]; }
sub EXISTS { my($self, $index) = @_; exists($self->{CURRENT_STATE}->[$index]); }
sub POP { my $self = shift; pop @{$self->{CURRENT_STATE}}; }
sub SHIFT { my $self = shift; shift @{$self->{CURRENT_STATE}}; }

sub PUSH {
    my($self, @list) = @_;
    $self->STORE($self->FETCHSIZE(), $_) foreach (@list);
}

sub UNSHIFT {
    my($self, @list) = @_;
    my @oldlist = @{$self->{CURRENT_STATE}};
    # shuffle existing contents along
    for(my $i = $self->FETCHSIZE() - 1; $i >= 0; $i--) {
        $self->{CURRENT_STATE}->[$i + scalar(@list)] =
	    $self->{CURRENT_STATE}->[$i];
    }
    $self->STORE($_, $list[$_]) foreach(0..$#list);
    return $self->FETCHSIZE();
}

# # FIXME - this needs to shuffle stuff as UNSHIFT does, then use STORE
# # for anything we insert
# sub SPLICE {
# }

sub FETCHSIZE { my $self = shift; scalar(@{$self->{CURRENT_STATE}}); }
sub STORESIZE {
    my($self, $count) = @_;
    $self->{CURRENT_STATE} = [(@{$self->{CURRENT_STATE}})[0..$count - 1]];
}
sub EXTEND { 'the voices told me to write this method' }

sub checkpoint {
    my $self = shift;
    push @{$self->{STACK}}, dclone($self->{CURRENT_STATE});
}

sub commit {
    my $self = shift;
    # $self->{STACK}=[];                     # clear all checkpoints
    defined(pop(@{$self->{STACK}})) ||
        die("Attempt to commit without a checkpoint");
}

sub rollback {
    my $self = shift;
    die("Attempt to rollback too far") unless(@{$self->{STACK}});
    # no copying required, just update a pointer
    $self->{CURRENT_STATE} = pop @{$self->{STACK}};
}

sub current_state {
    shift->{CURRENT_STATE};
}