KiokuDB::Set - L<Set::Object> wrapper for KiokuDB with lazy loading.

KiokuDB documentation Contained in the KiokuDB distribution.

Index

Code Index:

NAME

Top

KiokuDB::Set - Set::Object wrapper for KiokuDB with lazy loading.

SYNOPSIS

Top

    use KiokuDB::Util qw(set);

    my $set = set(); # KiokuDB::Set::Transient

    $set->insert($object);

    warn $set->size;

    my $id = $dir->store( $set );

DESCRIPTION

Top

This role defines the API implemented by KiokuDB::Set::Transient, KiokuDB::Set::Deferred, and KiokuDB::Set::Loaded.

These three classes are modeled after Set::Object, but have implementation details specific to KiokuDB.

Transient Sets

Transient sets are in memory, they are sets that have been constructed by the user for subsequent insertion into storage.

When you create a new set, this is what you should use.

KiokuDB::Util provides convenience functions (set in KiokuDB::Util and weak_set in KiokuDB::Util) to construct transient sets concisely.

Deferred Sets

When a set is loaded from the backend, it is deferred by default. This means that the objects inside the set are not yet loaded, and will be fetched only as needed.

When set members are needed, the set is upgraded in place into a KiokuDB::Set::Loaded object.

Loaded Sets

This is the result of vivifying the members of a deferred set, and is similar to transient sets in implementation.

KiokuDB documentation Contained in the KiokuDB distribution. 
#!/usr/bin/perl

package KiokuDB::Set;
use Moose::Role 'requires', 'has' => { -as => "attr" }; # need a 'has' method

use Moose::Util::TypeConstraints 'coerce', 'from', 'via';

use Set::Object;

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

coerce( __PACKAGE__,
    from ArrayRef => via {
        require KiokuDB::Set::Transient;
        KiokuDB::Set::Transient->new( set => Set::Object->new( @$_ ) ),
    },
);

requires qw(
    includes
    members
    insert
    remove
);

attr _objects => (
    isa => "Set::Object",
    is  => "ro",
    init_arg => "set",
    writer   => "_set_objects",
    handles  => [qw(clear size is_weak weaken strengthen is_null)],
    default  => sub { Set::Object->new },
);

sub clone {
    my ( $self, @args ) = @_;
    $self->_clone(@args);
}

sub _clone {
    my ( $self, %args ) = @_;
    $args{set} ||= $self->_clone_object_set;
    $self->meta->clone_object( $self, %args );
}

sub _clone_object_set {
    my $self = shift;
    my $set = $self->_objects;
    ( ref $set )->new( $set->members );
}

sub delete { shift->remove(@_) }

sub elements { shift->members }

sub has { (shift)->includes(@_) }
sub contains { (shift)->includes(@_) }
sub element { (shift)->member(@_) }
sub member {
    my $self = shift;
    my $item = shift;
    return ( $self->includes($item) ?
        $item : undef );
}

sub _apply {
    my ( $self, $method, @sets ) = @_;

    my @real_sets;

    foreach my $set ( @sets ) {
        if ( my $meth = $set->can("_load_all") ) {
            $set->$meth;
        }

        if ( my $inner = $set->can("_objects") ) {
            push @real_sets, $set->$inner;
        } elsif ( $set->isa("Set::Object") ) {
            push @real_sets, $set;
        } else {
            die "Bad set interaction: $self with $set";
        }
    }

    $self->_clone( set => $self->_objects->$method( @real_sets ) );
}

# we weed out empty sets so that they don't trigger loading of deferred sets

sub union {
    if ( my @sets = grep { $_->size } @_ ) {
        my $self = shift @sets;
        return $self->_apply( union => @sets );
    } else {
        my $self = shift;
        return $self->_clone
    }
}

sub intersection {
    my ( $self, @sets ) = @_;

    if ( grep { $_->size == 0 } $self, @sets ) {
        return $self->_clone;
    } else {
        $self->_apply( intersection => @sets );
    }
}

sub subset {
    my ( $self, $other ) = @_;

    return if $other->size < $self->size;
    return 1 if $self->size == 0;

    $self->_apply( subset => $other )
}

sub difference {
    my ( $self, $other ) = @_;

    if ( $other->size == 0 ) {
        return $self->_clone;
    } else {
        $self->_apply( difference => $other );
    }
}

sub equal {
    my ( $self, $other ) = @_;

    return 1 if $self->size == 0 and $other->size == 0;
    return if $self->size != 0 and $other->size != 0;

    $self->_apply( equal => $other )
}

sub not_equal {
    my ( $self, $other ) = @_;
    not $self->equal($other);
}

__PACKAGE__

__END__