view release on metacpan or  search on metacpan

lib/KiokuDB.pm  view on Meta::CPAN

sub refresh {
    my ( $self, @objects ) = @_;

    return unless @objects;

    my $l = $self->live_objects;

    croak "Object not in storage"
        if grep { not $l->object_in_storage($_) } @objects;

    $self->linker->refresh_objects(@objects);

    if ( defined wantarray ) {
        if ( @objects == 1 ) {
           return $objects[0];
        } else {
           return @objects;
        }
    }
}

sub _store {
    my ( $self, $root, @args ) = @_;

    my @objects = $self->_register(@args);

    return unless @objects;

    $self->store_objects( root_set => $root, objects => \@objects );
}

sub store         { shift->_store( 1, @_ ) }
sub store_nonroot { shift->_store( 0, @_ ) }

sub _insert {
    my ( $self, $root, @args ) = @_;

    my @objects = $self->_register(@args);

    return unless @objects;

    my $l = $self->live_objects;

    # FIXME make optional?
    if ( my @in_storage = grep { $l->object_in_storage($_) } @objects ) {
        croak "Objects already in database: @in_storage";
    }

    $self->store_objects( root_set => $root, only_in_storage => 1, objects => \@objects );

    # return IDs only for unknown objects
    if ( defined wantarray ) {
        return $self->live_objects->objects_to_ids(@objects);
    }
}

sub insert         { shift->_insert( 1, @_ ) }
sub insert_nonroot { shift->_insert( 0, @_ ) }

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

    my @objects = $self->_register(@args);

    my $l = $self->live_objects;

    croak "Object not in storage"
        if grep { not $l->object_in_storage($_) } @objects;

    $self->store_objects( shallow => 1, only_known => 1, objects => \@objects );
}

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

    my @objects = $self->_register(@args);

    my $l = $self->live_objects;

    croak "Object not in storage"
        if grep { not $l->object_in_storage($_) } @objects;

    $self->store_objects( only_known => 1, objects => \@objects );
}

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

    my @objects = @{ $args{objects} };

    my $l = $self->live_objects;

    my @entries = $l->objects_to_entries( @{ $args{objects} } );

    my $method = $args{method} || "derive";

    my $derive_args = $args{args} || [];

    my @args = ref($derive_args) eq 'HASH' ? %$derive_args : @$derive_args;

    $l->update_entries(map {
        my $obj = shift @objects;
        $obj => $_->$method( object => $obj, @args );
    } @entries);
}

sub set_root {
    my ( $self, @objects ) = @_;

    $self->_derive_entries( objects => \@objects, args => { root => 1 } );
}

sub unset_root {
    my ( $self, @objects ) = @_;

    $self->_derive_entries( objects => \@objects, args => { root => 0 } );
}

sub is_root {
    my ( $self, @objects ) = @_;