package Data::Transactional;

use strict;
use warnings;
use diagnostics;

our $VERSION = '1.0';

use Data::Dumper;

=head1 NAME

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

=head1 SYNOPSIS

    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

=head1 METHODS

=over

=item new

The constructor.  This takes named parameters.  The only parameter
so far is:

=over

=item type

Optional parameter, taking either 'ARRAY' or 'HASH' as its value (case-
insensitive), to determine what data type to base the structure on.
Regardless of what you choose for the first level of the structure, you
may use whatever you like further down the tree.  If not supplied, this
defaults to 'HASH'.

=back

=cut

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;
}

=item checkpoint

Saves the current state of the structure so that we can roll back to it.

=cut

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

=item commit

Discards the most recent saved state, so it can no longer be rolled back.
Why do this?  Well, throwing away the history saves a load of memory.
It is a fatal error to commit() when there's no saved states.

=cut

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

=item commit_all

Throws away all saved states, effectively committing all current transactions.

=cut

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

=item rollback

Revert the data structure to the last checkpoint.  To roll back beyond the
first checkpoint is a fatal error.

=cut

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

=item rollback_all

Roll back all changes.

=cut

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

=item current_state

Return a reference to the current state of the underlying object.

=cut

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

=back

=head1 IMPLEMENTATION NOTES

This module relies on two other packages which are included in the same
file - Data::Transactional::Hash and Data::Transactional::Array.  These
are where the magic really happens.  These implement everything needed
for C<tie()>ing those structures, plus their own C<checkpoint()>,
C<commit()> and C<rollback()> methods.  When you create a
Data::Transactional object, what you really get is one of these tied
structures, reblessed into the Data::Transactional class.  The
transactional methods simply call through to the same method on the
underlying tied structure.

This is loosely inspired by L<DBM::Deep>.

=head1 BUGS/WARNINGS

I assume that C<$[> is zero.

Storing blessed objects in a C<Data::Transactional> structure is not
supported.  I suppose it could be, but there's no sane way that they
could be transactionalised.  This also applies to tie()d objects.
Please note that in the case of tie()d objects, we don't do a great deal
of checking, so things may break in subtle and hard-to-debug ways.

The precise details of how the transactional methods affect sub-structures
in your data may change before a 1.0 release.  If you have suggestions for
how it could be improved, do please let me know.

The SPLICE() operation is *not defined* for transactionalised arrays,
because it makes my brane hurt.  If you want to implement this please
do!  Remember that you should use STORE() to put each new entry in the
array, as that will properly handle adding complex data structures.

No doubt there are others.  When submitting a bug report please please
please include a test case, in the form of a .t file, which will fail
with my version of the module and pass once the bug is fixed.  If you
include a patch as well, that's even better!

=head1 FEEDBACK

I welcome all comments - both praise and constructive criticism - about
my code.  If you have a question about how to use it please read *all*
of the documentation first, and let me know what you have tried and how
the results differ from what you wanted or expected.

I do not consider blind, automatically generated and automatically sent
error reports to be constructive.
Don't send them, you'll only get flamed.

=head1 AUTHOR

David Cantrell E<lt>david@cantrell.org.ukE<gt>

=head1 LICENCE

This software is Copyright 2004 David Cantrell.  You may use, modify and
distribute it under the same terms as perl itself.

=cut

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

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;use diagnostics;

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};
}