view release on metacpan or  search on metacpan

lib/DBIx/Class/KiokuDB.pm  view on Meta::CPAN

package DBIx::Class::KiokuDB;
BEGIN {
  $DBIx::Class::KiokuDB::AUTHORITY = 'cpan:NUFFIN';
}
# ABSTRACT: Refer to KiokuDB objects from DBIx::Class tables.
$DBIx::Class::KiokuDB::VERSION = '1.23';
use strict;
use warnings;

use Carp;
use Scalar::Util qw(weaken);

use namespace::clean;

use base qw(DBIx::Class::Core);

sub new {
    my $self = shift->next::method(@_);

    foreach my $key ( $self->result_source->columns ) {
        my $col_info = $self->column_info($key);

        if ( $col_info->{_kiokudb_info} and ref( my $obj = $self->get_column($key) ) ) {
            $self->store_kiokudb_column( $key => $obj );
        }
    }

    return $self;
}

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

    my $schema = $self->result_source->schema;

    my $g = $schema->txn_scope_guard;

    my $dir = $schema->kiokudb_handle;
    my $lo = $dir->live_objects;

    if ( my @insert = grep { ref and not $lo->object_to_entry($_) } values %{ $self->{_kiokudb_column} } ) {
        $dir->insert(@insert);
    }

    my $ret = $self->next::method(@args);

    $g->commit;

    return $ret;
}

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

    my $dir = $self->result_source->schema->kiokudb_handle;
    my $lo = $dir->live_objects;

    if ( my @insert = grep { ref and not $lo->object_to_entry($_) } values %{ $self->{_kiokudb_column} } ) {
        croak("Can't update object, related KiokuDB objects are not in storage");
    }

    $self->next::method(@args);
}

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

    my $schema = $self->result_source->schema;

    my $g = $schema->txn_scope_guard;

    if ( my @objects = grep { ref } values %{ $self->{_kiokudb_column} } ) {
        $schema->kiokudb_handle->store(@objects);
    }

    my $ret = $self->insert_or_update;

    $g->commit;

    return $ret;
}

sub kiokudb_column {
    my ($self, $rel, $cond, $attrs) = @_;

    # assume a foreign key contraint unless defined otherwise
    $attrs->{is_foreign_key_constraint} = 1
        if not exists $attrs->{is_foreign_key_constraint};

    my $fk = defined $cond ? $cond : $rel;

    $self->add_relationship( $rel, 'entries', { 'foreign.id' => "self.$fk" }, $attrs ); # FIXME hardcoded 'entries'

    my $col_info = $self->column_info($fk);

    $col_info->{_kiokudb_info} = {};

    my $accessor = $col_info->{accessor};
    $accessor = $rel unless defined $accessor;

    $self->mk_group_accessors('kiokudb_column' => [ $accessor, $fk]);
}

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

    if ( ref( my $obj = $self->result_source->schema->kiokudb_handle->lookup($id) ) ) {
        return $obj;
    } else {
        croak("No object with ID '$id' found") unless ref $obj;
    }
}