path: root/lib/Data/COW.pm

package Data::COW;

use 5.006001;
use strict;
no warnings;

use Exporter;
use Scalar::Util qw<reftype blessed>;
use overload ();  # we're not overloading anything, but we'd like to
                  # check if they're already implementing a value type

use base 'Exporter';

our @EXPORT = qw<make_cow_ref>;

our $VERSION = '0.02';

sub tied_any {
    my ($ref) = @_;
    if (ref $ref) {
        if (reftype($ref) eq 'SCALAR') {
            tied $$ref;
        }
        elsif (reftype($ref) eq 'ARRAY') {
            tied @$ref;
        }
        elsif (reftype($ref) eq 'HASH') {
            tied %$ref;
        }
    }

}

sub cow_object {
    my ($ref) = @_;
    my $tied = tied_any $ref;
    $tied && $tied->isa('Data::COW') && $tied;
}

sub make_cow_ref {
    my ($ref, $parent, $key) = @_;

    make_cow_ref_nocheck($ref, $parent, $key);
}

sub make_temp_cow_ref {
    my ($ref, $parent, $key) = @_;

    if (my $obj = cow_object $ref) {
        if ($obj->{parent} == $parent) {
            $ref;
        }
        else {
            make_cow_ref_nocheck($ref, $parent, $key);
        }
    }
    else {
        make_cow_ref_nocheck($ref, $parent, $key);
    }
}

sub make_cow_ref_nocheck {
    my ($ref, $parent, $key) = @_;

    if (ref $ref && 
        # check if they already think they're a value type
        !(overload::Overloaded($ref) && overload::Method($ref, '=')))
    {
        my $ret;
        if (reftype($ref) eq 'SCALAR') {
            tie my $it => 'Data::COW::Scalar', $ref, $parent, $key;
            $ret = \$it;
        }
        elsif (reftype($ref) eq 'ARRAY') {
            tie my @it => 'Data::COW::Array', $ref, $parent, $key;
            $ret = \@it;
        }
        elsif (reftype($ref) eq 'HASH') {
            tie my %it => 'Data::COW::Hash', $ref, $parent, $key;
            $ret = \%it;
        }
        else {
            # code and glob are not aggregates that we can take control
            # of, so punt and just return them like anything else
            return $ref;
        }
        
        if (blessed($ref)) {
            bless $ret => blessed($ref);
        }
        
        return $ret;
    }
    else {
        return $ref;
    }
}

sub clone_using {
    my ($self, $copier) = @_;

    return unless $self->{const};
    my $old = $self->{ref};
    my $new = $copier->($old);

    if (blessed $old) {
        bless $new => blessed $old;
    }
    if ($self->{parent}) {
        my $cnew = make_cow_ref $new, $self->{parent}, undef;
        tied_any($cnew)->{const} = 0;
        $self->{parent}->clone($self->{key} => $cnew);
    }
    $self->{ref} = $new;
    $self->{const} = 0;
}

package Data::COW::Scalar;

use Tie::Scalar;
use base 'Tie::Scalar';
use base 'Data::COW';

sub TIESCALAR {
    my ($class, $ref, $parent, $key) = @_;
    bless {
        ref => $ref,
        parent => $parent,
        key => $key,
        const => 1,
    } => ref $class || $class;
}

sub clone {
    my ($self, $key, $value) = @_;

    $self->clone_using(sub { my $v = ${$_[0]}; \$v });
    ${$self->{ref}} = $value if defined $key;
}

sub FETCH {
    my ($self) = @_;
    Data::COW::make_temp_cow_ref(${$self->{ref}}, $self, 1);
}

sub STORE {
    my ($self, $value) = @_;
    $self->clone(1 => $value);
    $value;
}

package Data::COW::Array;

use Tie::Array;
use base 'Tie::Array';
use base 'Data::COW';

sub TIEARRAY {
    my ($class, $ref, $parent, $key) = @_;
    bless {
        ref => $ref,
        parent => $parent,
        key => $key,
        const => 1,
    } => ref $class || $class;
}

sub clone {
    my ($self, $key, $value) = @_;
    $self->clone_using(sub { [ @{$_[0]} ] });
    $self->{ref}[$key] = $value if defined $key;
}

sub FETCH {
    my ($self, $key) = @_;
    Data::COW::make_temp_cow_ref($self->{ref}[$key], $self, $key);
}

sub STORE {
    my ($self, $key, $value) = @_;
    $self->clone($key => $value);
    $value;
}

sub FETCHSIZE {
    my ($self) = @_;
    scalar @{$self->{ref}};
}

sub STORESIZE {
    my ($self, $size) = @_;
    $self->clone;
    $#{$self->{ref}} = $size-1;
}

sub DELETE {
    my ($self, $key) = @_;
    $self->clone;
    delete $self->{ref}[$key];
}

sub EXISTS {
    my ($self, $key) = @_;
    exists $self->{ref}[$key];
}

package Data::COW::Hash;

use Tie::Hash;
use base 'Tie::Hash';
use base 'Data::COW';

sub TIEHASH {
    my ($class, $ref, $parent, $key) = @_;
    bless {
        ref => $ref,
        parent => $parent,
        key => $key,
        const => 1,
    } => ref $class || $class;
}

sub clone {
    my ($self, $key, $value) = @_;
    $self->clone_using(sub { 
        my $ret = { %{$_[0]} };
        $ret;
    });
    $self->{ref}{$key} = $value if defined $key;
}

sub FETCH {
    my ($self, $key) = @_;
    Data::COW::make_temp_cow_ref($self->{ref}{$key}, $self, $key);
}

sub STORE {
    my ($self, $key, $value) = @_;
    $self->clone($key => $value);
    $value;
}

sub EXISTS {
    my ($self, $key) = @_;
    exists $self->{ref}{$key};
}

sub DELETE {
    my ($self, $key) = @_;
    $self->clone;
    delete $self->{ref}{$key};
}

sub CLEAR {
    my ($self) = @_;
    $self->clone_using(sub { {} });
    ();
}

sub FIRSTKEY {
    my ($self) = @_;
    my $a = keys %{$self->{ref}};  # reset iterator
    each %{$self->{ref}};
}

sub NEXTKEY {
    my ($self) = @_;
    each %{$self->{ref}};
}

sub SCALAR {
    my ($self) = @_;
    scalar %{$self->{ref}};
}

1;

=head1 NAME

Data::COW - clone deep data structures copy-on-write

=head1 SYNOPSIS

    use Data::COW;

    my $array = [ 0, 1, 2 ];
    my $copy = make_cow_ref $array;

    push @$array, 3;
    # $copy->[3] is 3
    push @$copy, 4;
    # $array->[4] is not defined (and doesn't even exist)
    # $copy is a real copy now
    push @$array, 5;
    # $copy is unaffected

=head1 DESCRIPTION

Data::COW makes copies of data structures copy-on-write, or "lazily".
So if you have a data structure that takes up ten megs of memory, it
doesn't take ten megs to copy it.  Even if you change part of it,
Data::COW only copies the parts that need to be copied in order to
reflect the change.

Data::COW exports one function: C<make_cow_ref>.  This takes a reference
and returns a copy-on-write reference to it.  If you don't want this
in your namespace, and you want to use it as C<Data::COW::make_cow_ref>,
use the module like this:

    use Data::COW ();

Data::COW won't be able to copy filehandles or glob references.  But how
do you change those anyway?  It's also probably a bad idea to give it
objects that refer to XS internal state without providing a value type
interface.  Also, don't use stringified references from this data
structure: they're different each time you access them!

=head1 SEE ALSO

L<Clone>

=head1 AUTHOR

Luke Palmer <luke@luqui.org>

=head1 COPYRIGHT

    Copyright (C) 2005 by Luke Palmer

    This library is free software; you can redistribute it and/or modify it under
    the same terms as Perl itself, either Perl version 5.8.3 or, at your option,
    any later version of Perl 5 you may have available.