view release on metacpan or  search on metacpan

lib/KiokuDB/LiveObjects.pm  view on Meta::CPAN

}

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

    return $self->object_to_id($objects[0])
        if @objects == 1;

    map { $_ && $_->{guard}->key } @{ $self->_objects }{@objects};
}

sub object_to_id {
    my ( $self, $obj ) = @_;

    if ( my $info = $self->_objects->{$obj} ){
        return $info->{guard}->key;
    }

    return undef;
}

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

    return $self->ids_to_entries( $self->objects_to_ids(@objects) );
}

sub object_to_entry {
    my ( $self, $obj ) = @_;

    return $self->id_to_entry( $self->object_to_id($obj) || return );
}

sub id_in_root_set {
    my ( $self, $id ) = @_;

    if ( my $data = $self->_id_info($id) ) {
        return $data->{root};
    }

    return undef;
}

sub id_in_storage {
    my ( $self, $id ) = @_;

    if ( my $data = $self->_id_info($id) ) {
        return $data->{in_storage};
    }

    return undef;
}


sub object_in_storage {
    my ( $self, $object ) = @_;

    $self->id_in_storage( $self->object_to_id($object) || return );
}

sub update_object_entry {
    my ( $self, $object, $entry, %args ) = @_;


    my $s = $self->current_scope or croak "no open live object scope";

    my $info = $self->_objects->{$object} or croak "Object not yet registered";
    $self->_entries->{$entry} = $info;

    @{$info}{keys %args} = values %args;
    weaken($info->{entry} = $entry);

    if ( $self->keep_entries ) {
        $self->_object_entries->{$object} = $entry;

        if ( $args{in_storage} and my $txs = $self->txn_scope ) {
            $txs->push($entry);
        }
    }

    # break cycle for passthrough objects
    if ( ref($entry->data) and refaddr($object) == refaddr($entry->data) ) {
        weaken($entry->{data}); # FIXME there should be a MOP way to do this
    }
}

sub register_object {
    my ( $self, $id, $object, %args ) = @_;

    my $s = $self->current_scope or croak "no open live object scope";

    croak($object, " is not a reference") unless ref($object);
    croak($object, " is an entry") if blessed($object) && $object->isa("KiokuDB::Entry");

    if ( my $old_id = $self->object_to_id($object) ) {
        croak($object, " is already registered as '$old_id'")
    }

    if ( my $object = $self->id_to_object($id) ) {
        croak("ID '$id' is already in use by ", $object);
    }

    my $info = $self->_vivify_id_info($id);

    if ( ref $info->{object} ) {
        croak "An object with the id '$id' is already registered ($info->{object} != $object)"
    }

    $self->_objects->{$object} = $info;

    weaken($info->{object} = $object);

    if ( my $entry = $info->{entry} ) {
        # break cycle for passthrough objects
        if ( ref($entry->data) and refaddr($object) == refaddr($entry->data) ) {
            weaken($entry->{data}); # FIXME there should be a MOP way to do this
        }

        if ( $self->keep_entries ) {
            $self->_object_entries->{$object} = $entry;
        }
    }

    @{$info}{keys %args} = values %args;

    if ( $args{cache} and my $c = $self->cache ) {
        $c->set( $id => $object );
    }

    $s->push($object);
}

sub register_entry {
    my ( $self, $id, $entry, %args ) = @_;

    my $info = $self->_vivify_id_info($id);

    $self->_entries->{$entry} = $info;

    confess "$entry" unless $entry->isa("KiokuDB::Entry");
    @{$info}{keys %args, 'root'} = ( values %args, $entry->root );

    weaken($info->{entry} = $entry);

    if ( $args{in_storage} and $self->keep_entries and my $txs = $self->txn_scope ) {
        $txs->push($entry);
    }
}

sub insert {
    my ( $self, @pairs ) = @_;

    croak "The arguments must be an list of pairs of IDs/Entries to objects"
        unless @pairs % 2 == 0;

    croak "no open live object scope" unless $self->current_scope;

    my @register;
    while ( @pairs ) {
        my ( $id, $object ) = splice @pairs, 0, 2;
        my $entry;

        if ( ref $id ) {
            $entry = $id;
            $id = $entry->id;
        }

        confess("blah") unless $id;

        croak($object, " is not a reference") unless ref($object);
        croak($object, " is an entry") if blessed($object) && $object->isa("KiokuDB::Entry");

        if ( $entry ) {
            $self->register_entry( $id => $entry, in_storage => 1 );
            $self->register_object( $id => $object );
        } else {
            $self->register_object( $id => $object );
        }
    }
}

sub update_entries {
    my ( $self, @pairs ) = @_;
    my @entries;

    while ( @pairs ) {
        my ( $object, $entry ) = splice @pairs, 0, 2;

        $self->register_entry( $entry->id => $entry, in_storage => 1 );

        unless ( $self->object_to_id($object) ) {
            $self->register_object( $entry->id => $object );
        } else {
            $self->update_object_entry( $object, $entry );
        }
    }

    return;
}

sub rollback_entries {
    my ( $self, @entries ) = @_;

    foreach my $entry ( reverse @entries ) {
        my $info = $self->_id_info($entry->id);

        if ( my $prev = $entry->prev ) {
            weaken($info->{entry} = $prev);
        } else {
            delete $info->{entry};
        }
    }
}

sub remove {
    my ( $self, @stuff ) = @_;

    my ( $i, $o, $e, $oe ) = ( $self->_ids, $self->_objects, $self->_entries, $self->_object_entries );

    while ( @stuff ) {
        my $thing = shift @stuff;

        if ( ref $thing ) {
            # FIXME make this a bit less zealous?
            my $info;
            if ( $info = delete $o->{$thing} ) {
                delete $info->{object};
                delete $oe->{$thing};
                push @stuff, $info->{entry} if $info->{entry};
            } elsif ( $info = delete $e->{$thing} ) {
                delete $info->{entry};
                push @stuff, $info->{object} if ref $info->{object};
            }
        } else {
            my $info = delete $i->{$thing};
            push @stuff, grep { ref } delete @{$info}{qw(entry object)};
        }
    }
}

sub clear {
    my $self = shift;