libkiokudb-perl 0.57-1 / usr / share / perl5 / KiokuDB / TypeMap / Entry / StorableHook.pm

package KiokuDB::TypeMap::Entry::StorableHook;
BEGIN {
  $KiokuDB::TypeMap::Entry::StorableHook::AUTHORITY = 'cpan:NUFFIN';
}
$KiokuDB::TypeMap::Entry::StorableHook::VERSION = '0.57';
use Moose;
# ABSTRACT: Reuse existing Storable hooks for KiokuDB storage.

use Scalar::Util qw(reftype);
use Carp qw(croak);

no warnings 'recursion';

# predeclare for namespace::clean;
sub _type ($);
sub _new ($;$);
sub _clear ($);

use namespace::clean -except => 'meta';

with qw(
    KiokuDB::TypeMap::Entry::Std
    KiokuDB::TypeMap::Entry::Std::Expand
);

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

    my $attach = $class->can("STORABLE_attach") ? 1 : 0;

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

        my $object = $args{object};

        my @type = _type($object);

        my ( $str, @refs ) = $object->STORABLE_freeze(0);

        my $data;

        if ( @refs ) {
            croak sprintf "Freeze cannot return references if %s class is using STORABLE_attach", $class if $attach;

            if ( my @non_refs = grep { not ref } @refs ) {
                croak blessed($object) . "::STORABLE_freeze returned non reference values: @non_refs";
            }

            my @collapsed = $self->visit(@refs);

            foreach my $ref ( @collapsed ) {
                next unless ref($ref) eq 'KiokuDB::Reference';
                next if $self->may_compact($ref);
                $ref = $ref->id; # don't save a bunch of Reference objects when all we need is the ID
            }

            $data = [ @type, $str, @collapsed ],
        } else {
            unless ( $attach ) {
                if ( @type == 1 ) {
                    $data = ( $type[0] . $str );
                } else {
                    $data = [ @type, $str ];
                }
            } else {
                $data = $str;
            }
        }

        return $self->make_entry(
            %args,
            data => $data,
        );
    };
}

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

    unless ( $class->can("STORABLE_attach") ) {
        # normal form, STORABLE_freeze
        return sub {
            my ( $self, $entry ) = @_;

            my $data = $entry->data;

            my ( $reftype, @args ) = ref $data ? @$data : ( substr($data, 0, 1), substr($data, 1) );

            my $instance;

            if ( ref $args[0] ) {
                my $tied;
                $self->queue_ref(shift(@args), \$tied);
                $instance = _new( $reftype, $tied );
            } else {
                $instance = _new( $reftype );
            }

            bless $instance, $entry->class;
        };
    } else {
        # esotheric STORABLE_attach form
        return sub {
            my ( $self, $entry ) = @_;

            $entry->class->STORABLE_attach( 0, $entry->data ); # FIXME support non ref
        };
    }
}

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

    return sub {
        my ( $linker, $instance ) = @_;

        _clear($instance);
    };
}

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

    unless ( $class->can("STORABLE_attach") ) {
        # normal form, STORABLE_freeze
        return sub {
            my ( $self, $instance, $entry ) = @_;

            my $data = $entry->data;

            my ( $reftype, @args ) = ref $data ? @$data : ( substr($data, 0, 1), substr($data, 1) );

            shift @args if ref $args[0]; # tied

            my ( $str, @refs ) = @args;

            my @inflated;

            foreach my $ref ( @refs ) {
                push @inflated, undef;

                if ( ref $ref ) {
                    $self->inflate_data($ref, \$inflated[-1]);
                } else {
                    $self->queue_ref($ref, \$inflated[-1]);
                }
            }

            $self->queue_finalizer(sub {
                $instance->STORABLE_thaw( 0, $str, @inflated );
            });
        };
    } else {
        # esotheric STORABLE_attach form
        return sub { };
    }
}

sub _type ($) {
    my $obj = shift;

    my $type = reftype($obj);

    if ( $type eq 'SCALAR' or $type eq 'REF' ) {
        if ( my $tied = tied $$obj ) {
            return ( S => $tied );
        } else {
            return 'S';
        }
    } elsif ( $type eq 'HASH' ) {
        if ( my $tied = tied %$obj ) {
            return ( H => $tied );
        } else {
            return 'H';
        }
    } elsif ( $type eq 'ARRAY' ) {
        if ( my $tied = tied @$obj ) {
            return ( A => $tied );
        } else {
            return 'A';
        }
    } else {
        croak sprintf "Unexpected object type (%s)", reftype($obj);
    }
}

sub _new ($;$) {
    my ( $type, $tied ) = @_;

    if ( $type eq 'S' ) {
        my $ref = \( my $x );
        tie $x, "To::Object", $tied if ref $tied;
        return $ref;
    } elsif ( $type eq 'H' ) {
        my $ref = {};
        tie %$ref, "To::Object", $tied if ref $tied;
        return $ref;
    } elsif ( $type eq 'A' ) {
        my $ref = [];
        tie @$ref, "To::Object", $tied if ref $tied;
        return $ref;
    } else {
        croak sprintf "Unexpected object type (%d)", $type;
    }
}

sub _clear ($) {
    my $obj = shift;

    my $type = reftype($obj);

    if ( $type eq 'SCALAR' or $type eq 'REF' ) {
        undef $$obj;
    } elsif ( $type eq 'HASH' ) {
        %$obj = ();
    } elsif ( $type eq 'ARRAY' ) {
        @$obj = ();
    } else {
        croak sprintf "Unexpected object type (%s)", reftype($obj);
    }
}


__PACKAGE__->meta->make_immutable;

__PACKAGE__

__END__

=pod

=encoding UTF-8

=head1 NAME

KiokuDB::TypeMap::Entry::StorableHook - Reuse existing Storable hooks for KiokuDB storage.

=head1 VERSION

version 0.57

=head1 SYNOPSIS

    use KiokuDB::TypeMap::Entry::StorableHook;

=head1 DESCRIPTION

=head1 AUTHOR

Yuval Kogman <nothingmuch@woobling.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Yuval Kogman, Infinity Interactive.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut