File Coverage

blib/lib/Class/Accessor/TrackDirty.pm

Criterion	Covered	Total	%
statement	133	133	100.0
branch	32	32	100.0
condition	14	16	87.5
subroutine	33	33	100.0
pod	4	4	100.0
total	216	218	99.0

package Class::Accessor::TrackDirty;
use 5.008_001;
use strict;
use warnings;
use List::MoreUtils qw(any);
use Storable qw(dclone freeze);
our $VERSION = '0.13';

our $RESERVED_FIELD = '_original';
our $NEW = 'new';
our $FROM_HASH = 'from_hash';
our $RAW = 'raw';
our $TO_HASH = 'to_hash';
our $IS_MODIFIED = 'is_dirty';
our $MODIFIED_FIELDS = 'dirty_fields';
our $IS_NEW = 'is_new';
our $REVERT = 'revert';

{
    my %package_info;
    sub _package_info($) {
        my $package = shift;
        $package_info{$package} ||= {tracked_fields => {}, fields => {}};
    }
}

sub _is_different_deeply($$) {
    my ($ref_x, $ref_y) = @_;
    local $Storable::canonical = 1;  # avoiding Hash Randomization
    (freeze $ref_x) ne (freeze $ref_y);
}

sub _is_different($$) {
    my ($x, $y) = @_;
    if (defined $x && defined $y) {
        if (ref $x && ref $y) {
            return _is_different_deeply $x, $y;
        } else {
            return ref $x || ref $y || $x ne $y;
        }
    } else {
        return defined $x || defined $y;
    }
}

sub _make_tracked_accessor($$) {
    no strict 'refs';
    my ($package, $name) = @_;

    *{"$package\::$name"} = sub {
        my $self = shift;

        # getter
        my $value;
        if (exists $self->{$name}) {
            $value = $self->{$name};
        } elsif (defined $self->{$RESERVED_FIELD})  {
            $value = $self->{$RESERVED_FIELD}{$name};

            # Defensive copying
            $value = ($self->{$name} = dclone $value) if ref $value;
        }

        # setter
        $self->{$name} = $_[0] if @_;

        return $value;
    };
}

sub _make_accessor($$) {
    no strict 'refs';
    my ($package, $name) = @_;

    *{"$package\::$name"} = sub {
        my $self = shift;
        my $value = $self->{$name};
        $self->{$name} = $_[0] if @_;
        $value;
    };
}

sub _mk_tracked_accessors($@) {
    my $package = shift;
    _make_tracked_accessor $package => $_ for @_;
    @{(_package_info $package)->{tracked_fields}}{@_} = (1,) x @_;
}

sub _mk_helpers($) {
    no strict 'refs';
    my $package = shift;
    my ($tracked_fields, $fields) =
        @{_package_info $package}{qw(tracked_fields fields)};

    # cleate helper methods
    *{"$package\::$FROM_HASH"} = sub {
        my $package = shift;
        my %modified = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;

        my %origin;
        for my $name (keys %$tracked_fields) {
            $origin{$name} = delete $modified{$name} if exists $modified{$name};
        }

        $modified{$RESERVED_FIELD} = \%origin;
        bless \%modified, $package;
    };

    *{"$package\::$RAW"} = sub {
        my ($self) = @_;

        my %hash = (
            (map {
                # Don't store undefined values.
                my $v = $self->$_;
                defined $v ? ($_ => $v) : ();
            } keys %$tracked_fields, keys %$fields),
        );

        return \%hash;
    };

    *{"$package\::$TO_HASH"} = sub {
        my ($self) = @_;
        my $raw = $self->$RAW;

        # Move published data for cleaning.
        $self->{$RESERVED_FIELD} ||= {};
        $self->{$RESERVED_FIELD}{$_} = delete $self->{$_}
                         for grep { exists $self->{$_} } keys %$tracked_fields;

        return $raw;
    };

    *{"$package\::$IS_MODIFIED"} = sub {
        my ($self, $field) = @_;
        return any { $self->$IS_MODIFIED($_) } keys %$tracked_fields
                                                                 unless $field;

        return unless $tracked_fields->{$field};
        return 1 unless defined $self->{$RESERVED_FIELD};

        exists $self->{$field} &&
               _is_different $self->{$field}, $self->{$RESERVED_FIELD}{$field};
    };

    *{"$package\::$MODIFIED_FIELDS"} = sub {
        my $self = shift;
        grep { $self->$IS_MODIFIED($_) } keys %$tracked_fields;
    };

    *{"$package\::$IS_NEW"} = sub {
        my $self = shift;
        exists $self->{$RESERVED_FIELD} ? 0 : 1;
    };

    *{"$package\::$REVERT"} = sub {
        my $self = shift;
        delete $self->{$_} for keys %$tracked_fields;
    };
}

sub _mk_accessors($@) {
    my $package = shift;
    _make_accessor $package => $_ for @_;
    @{(_package_info $package)->{fields}}{@_} = (1,) x @_;
}

sub _mk_new($) {
    no strict 'refs';
    my $package = shift;

    *{"$package\::$NEW"} = sub {
        my $package = shift;
        my %modified = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;

        bless \%modified => $package;
    };
}

sub mk_tracked_accessors {
    (undef, my @tracked_fields) = @_;
    my $package = caller(0);
    _mk_tracked_accessors $package => @tracked_fields;
    _mk_helpers $package;
}

sub mk_accessors {
    (undef, my @fields) = @_;
    my $package = caller(0);
    _mk_accessors $package => @fields;
}

sub mk_new {
    my $package = caller(0);
    _mk_new $package;
}

sub mk_new_and_tracked_accessors {
    (undef, my @tracked_fields) = @_;
    my $package = caller(0);
    _mk_tracked_accessors $package => @tracked_fields;
    _mk_helpers $package;
    _mk_new $package;
}

1;
__END__