File Coverage

blib/lib/EntityModel/Storage.pm

Criterion	Covered	Total	%
statement	6	119	5.0
branch	0	28	0.0
condition	0	2	0.0
subroutine	2	26	7.6
pod	18	20	90.0
total	26	195	13.3

package EntityModel::Storage;
{
  $EntityModel::Storage::VERSION = '0.102';
}
use EntityModel::Class {
	_isa		=> [qw(Mixin::Event::Dispatch)],
	entity		=> { type => 'array', subclass => 'EntityModel::Entity' },
	transaction	=> { type => 'array', subclass => 'EntityModel::Transaction' },
};
no if $] >= 5.017011, warnings => "experimental::smartmatch";

=head1 NAME

EntityModel::Storage - backend storage interface for L

=head1 VERSION

version 0.102

=head1 SYNOPSIS

See L.

=head1 DESCRIPTION

See L for more details.

=head1 METHODS

=cut

=head2 register

Register with L so that callbacks trigger when further definitions are loaded/processed.

The base storage engine doesn't provide any callbacks - but we define the method anyway so that we don't
need to check for ->can.

=cut

sub register {
	my $class = shift;
}

=head2 apply_model

Apply the given model.

=cut

sub apply_model {
	my $self = shift;
	my $model = shift;
	$self->apply_model_and_schema($model);
}

=head2 apply_model_and_schema

Apply the given model to the storage layer.

This delegates most of the work to L.

=cut

sub apply_model_and_schema {
	my $self = shift;
	my $model = shift;
	my %args = @_;

	# Start off assuming that we need all the listed entities
	my @pending = $model->entity->list;
	# Nothing applied yet (should be $self->entity->list)
	my %existing;
	my @pendingNames = map { $_->name } @pending;

	my $code;
	# Called when everything's been applied successfully
	my $done; $done = sub {
#		$done = sub { die "Tried to hit the same completion callback twice\n" };
		$args{on_complete}->() if exists $args{on_complete};
		0
	};
	my %incomplete;
	# Process a single entity
	$code = sub {
		# We may be a leftover event, bail out if there's nothing to do
		unless(@pending) {
			return 1 if keys %incomplete; # try us again later
			$done->();
			return 0; # all complete
		}

		# Next item in queue, no idea what state it's in yet
		my $entity = shift(@pending);

		# Also remove current entry so we don't match ourselves when checking deps
		shift(@pendingNames);

		# If we've seen this one before, assume it's done
		# FIXME Diff the entities
		return $code->() if exists $existing{$entity->name};

		{ # Dependency handling
			my @deps = map { $_->name } $entity->dependencies;
			# Include ourselves in the list in case anyone else has a dependency on us
			my %expected = %existing; @expected{map { $_->name } @pending, $entity} = ();
			if(my @unresolved = grep { !exists $expected{$_} } @deps, $entity->name) {
				logError("%s unresolved (pending %s, deps %s for %s)", $_, join(',', @pendingNames), join(',', @deps), $entity->name) for @unresolved;
				die "Dependency error";
			}

			# Check that all dependencies are complete
			delete @expected{$entity->name, keys %existing};
			if(my @unsatisfied = grep { exists $expected{$_} } @deps) {
				logInfo("%s has %d unsatisfied deps, postponing: %s", $entity->name, scalar @unsatisfied, join(',',@unsatisfied));
				push @pending, $entity;
				push @pendingNames, $entity->name;
				return $code->();
			}
		}

		# Apply this entity and add more detail to the error message if it fails:
		return try {
			$incomplete{$entity->name} = $entity;
			$self->apply_entity(
				$entity,
				on_complete => sub {
					# Record this entry so we pick it up in later dependency checks
					$existing{$entity->name} = $entity;
					$code->();
					return 0;
				}
			);
			return 0;
		} catch {
			die "Failed to apply entity " . $entity->name . " (pending " . join(',', @pendingNames) . "): " . ($_ // 'undef');
			return 1;
		};
	};
	1 while $code->();
	return $self;
}

=head2 read

Reads the data for the given entity and returns hashref with the appropriate data.

Parameters:

=over 4

=item * entity - L

=item * id - ID to read data from

=back

=cut

sub read {
	my $self = shift;
	my %args = @_;
	die "Virtual!";
}

=head2 create

Creates new entry for the given L.

Parameters:

=over 4

=item * entity - L

=item * data - actual data values

=back

=cut

sub create {
	my $self = shift;
	my %args = @_;
	die "Virtual!";
}

=head2 store

Stores data to the given entity and ID.

Parameters:

=over 4

=item * entity - L

=item * id - ID to store data to

=item * data - actual data values

=back

=cut

sub store {
	my $self = shift;
	my %args = @_;
	die "Virtual!";
}

=head2 remove

Removes given ID from storage.

Parameters:

=over 4

=item * entity - L

=item * id - ID to store data to

=back

=cut

sub remove {
	my $self = shift;
	my %args = @_;
	die "Virtual!";
}

=head2 find

Find some entities that match the spec.

=cut

sub find {
	my $self = shift;
	my %args = @_;
	die "Virtual!";
}

=head2 adjacent

Returns the previous and next element for the given ID.

=cut

sub adjacent {
	my $self = shift;
	my %args = @_;
	die "Virtual!";
}

=head2 prev

Returns previous element for the given ID.

=cut

sub prev {
	my $self = shift;
	my ($prev, $next) = $self->adjacent(@_);
	return $prev;
}

=head2 next

Returns next element for the given ID.

=cut

sub next {
	my $self = shift;
	my ($prev, $next) = $self->adjacent(@_);
	return $next;
}

=head2 outer

Returns first and last IDs for the given entity.

=cut

sub outer {
	my $self = shift;
	my %args = @_;
	die "Virtual!";
}

=head2 first

Returns first active ID for the given entity.

=cut

sub first {
	my $self = shift;
	my ($first, $last) = $self->outer(@_);
	return $first;
}

=head2 last

Returns last active ID for the given entity.

=cut

sub last {
	my $self = shift;
	my ($first, $last) = $self->outer(@_);
	return $last;
}

=head2 transaction_start

Mark the start of a transaction.

=cut

sub transaction_start {
	my $self = shift;
	my $tran = shift;

# TODO weaken?
	$self->transaction->push($tran);
	return $self;
}

=head2 transaction_rollback

Roll back a transaction.

=cut

sub transaction_rollback {
	my $self = shift;
	my $tran = shift;
	die "No transaction in progress" unless $self->transaction->count;
	die "Mismatched transaction" unless $tran ~~ $self->transaction->last;
}

=head2 transaction_commit

Commit this transaction to storage - makes everything done within the transaction permanent
(or at least to the level the storage class supports permanence).

=cut

sub transaction_commit {
	my $self = shift;
	my $tran = shift;
	die "No transaction in progress" unless $self->transaction->count;
	die "Mismatched transaction" unless $tran ~~ $self->transaction->last;
}

=head2 transaction_end

Release the transaction on completion.

=cut

sub transaction_end {
	my $self = shift;
	my $tran = shift;
	die "No transaction in progress" unless $self->transaction->count;
	die "Mismatched transaction" unless $tran ~~ $self->transaction->last;
	$self->transaction->pop;
	return $self;
}

sub backend_ready { shift->{backend_ready} }

sub wait_for_backend {
	my $self = shift;
	my $code = shift;
	return $code->($self) if $self->backend_ready;
	$self->add_handler_for_event( backend_ready => sub { $code->(@_); 0 });
	return $self;
}

sub DESTROY {
	my $self = shift;
	die "Active transactions" if $self->transaction->count;
}

1;

__END__