File Coverage

blib/lib/EntityModel.pm

Criterion	Covered	Total	%
statement	62	154	40.2
branch	5	24	20.8
condition	2	3	66.6
subroutine	15	28	53.5
pod	13	15	86.6
total	97	224	43.3

package EntityModel;
# ABSTRACT: Cross-language event-driven ORM

use EntityModel::Class {
	_isa => [qw(EntityModel::Model)],
	name => { type => 'string' },
	plugin => { type => 'array', subclass => 'EntityModel::Plugin' },
	support => { type => 'array', subclass => 'EntityModel::Support' },
	storage => { type => 'array', subclass => 'EntityModel::Storage' },
	storage_queued => { type => 'array', subclass => 'EntityModel::Storage' },
	cache => { type => 'array', subclass => 'EntityModel::Cache' },
	cache_queued => { type => 'array', subclass => 'EntityModel::Cache' },
	db => { type => 'EntityModel::DB' },
};
no if $] >= 5.017011, warnings => "experimental::smartmatch";

our $VERSION = '0.102';

=head1 NAME

EntityModel - manage entity model definitions

=head1 VERSION

version 0.102

=head1 SYNOPSIS

 use EntityModel;
 # Define model
 my $model = EntityModel->new->load_from(
 	JSON => { entity : [
		{ name : 'article', field : [
			{ name : 'idarticle', type : 'bigserial' },
			{ name : 'title', type : 'varchar' },
			{ name : 'content', type : 'text' }
		], primary => { field : [ 'idarticle' ], separator : ':' }
	 ] }
 );
 # Apply PostgreSQL schema (optional, only needed if the model changes)
 $model->apply('PostgreSQL' => { schema => 'datamodel', host => 'localhost', user => 'testuser' });
 # Create Perl classes
 $model->apply('Perl' => { namespace => 'Entity', baseclass => 'EntityModel::EntityBase' });

 my $article = Entity::Article->create(
 	title => 'Test article',
	content => 'Article content'
 )->done(sub {
  	my $article = shift;
	say "ID was " . $article->id;
 })->fail(sub {
 	die 'Failed to create new article';
 });
 Entity::Article->find(
 	title => 'Test article'
 )->first(sub {
 	my $match = shift;
 	$match->title('Revised title');
 	die "Instances of the same object should always be linked, consistent and up-to-date"
 		unless $article->title eq $match->title;
 });

=head1 DESCRIPTION

This module provides a data storage abstraction system (in the form of an Object Relational Model) for accessing
backend storage from Perl and other languages. The intent is to take a model definition and generate or update
database tables, caching layer and the corresponding code (Perl/C++/JS) for accessing data.

A brief comparison and list of alternatives is in the L and L sections, please check there
before investing any time into using this module.

Eventually a full set of documentation will be added to L
but for now see the examples further down in this document.

=head1 METHODS

=cut

use Module::Load ();

use EntityModel::Transaction;
use EntityModel::Entity;
use EntityModel::Field;
use EntityModel::Query;

=head2 new

Constructor. Given a set of options, will load any plugins specified (and/or the defaults), applying
other config options via the appropriate plugins.

Typically run without options:

 my $model = EntityModel->new;

The exciting things happen elsewhere. See:

=over 4

=item * L

=item * L

=item * L

=back

=cut

sub new {
	my $class = shift;

	my @def;
	if(ref $_[0] ~~ 'HASH') {
		@def = %{$_[0]};
	} elsif(ref $_[0] ~~ 'ARRAY') {
		@def = @{$_[0]};
	} else {
		@def = @_;
	}

	my $self = bless { }, $class;

	# Apply plugins and options
	while(@def) {
		my ($k, $v) = splice @def, 0, 2;
		$self->load_plugin($k => $v);
	}

	return $self;
}

=head2 load_from

Read in a model definition from the given L-based source.

Parameters:

=over 4

=item * Type - must be a valid L subclass, such as 'Perl', 'JSON' or 'XML'.

=item * Definition - dependent on the subclass, typically the filename or raw string data.

=back

Common usage includes reading from inline Perl:

 $model->load_from(
  Perl => {
   name => 'kvstore',
   entity => [
    name => 'object',
    primary => 'iditem',
    field => [
     { name => 'iditem', type => 'bigserial' },
     { name => 'key', type => 'varchar' },
     { name => 'value', type => 'varchar' },
    ],
   ],
  }
 );

or the equivalent from JSON:

 $model->load_from(
  JSON => \q{
   "name" : "kvstore",
   "entity" : [
    "name" : "object",
    "primary" : "iditem",
    "field" : [
     { "name" : "iditem", "type" : "bigserial" },
     { "name" : "key", "type" : "varchar" },
     { "name" : "value", "type" : "varchar" }
    ]
   ]
  }
 );

=cut

sub load_from {
	my $self = shift;
	my ($type, $value) = @_;

	my $class = "EntityModel::Definition::$type";
	$self->load_component($class);

	$class->new->load(
		model	=> $self,
		source	=> $value
	);
	return $self;
}

=head2 save_to

Saves the current model definition to a definition.

Parameters:

=over 4

=item * Type - must be a valid L subclass, such as 'Perl', 'JSON' or 'XML'.

=item * Definition - dependent on the subclass, typically the filename or scalarref to hold raw string data.

=back

You might use something like this to store the current model to a file in JSON format:

 $model->save_to(
  JSON => 'model.json'
 );

or this to copy everything from a source model to a target model (wiping everything
in the target in the process):

 my $target = EntityModel->new;
 $source->save_to(
  model => $target
 );

=cut

sub save_to {
	my $self = shift;
	my ($type, $value) = @_;

	my $class = "EntityModel::Definition::$type";
	$self->load_component($class);

	$class->new->save(
		model	=> $self,
		target	=> $value
	);
	return $self;
}

=head2 load_component

Brings in the given component if it hasn't already been loaded.

Typically used by internal methods only.

=cut

sub load_component {
	my $self = shift;
	my $class = shift;
	unless($class->can('new')) {
		Module::Load::load($class);
		$class->register;
	}
	return $self;
}

=head2 add_support

Bring in a new L class for this L.

Example:

 $model->add_support(Perl => { namespace => 'Entity' });

=cut

sub add_support {
	my ($self, $name, $v) = @_;
	logDebug("Load support for [%s]", $name);
	my $class = 'EntityModel::Support::' . $name;
	$self->load_component($class);

	my $obj = $class->new($self, $v);
	$obj->setup($v);
	$obj->apply_model($self);
	$self->support->push($obj);
	return $self;
}

=head2 add_storage

Add backend storage provided by an L subclass.

Example:

 $model->add_storage(PostgreSQL => { service => ... });

=cut

sub add_storage {
	my ($self, $name, $v) = @_;
	delete $self->{backend_ready};
	logDebug("Load storage for [%s]", $name);
	my $class = $name;
	try { Module::Load::load($class) } unless try { $class->can('new') };
	unless(try { $class->can('new') }) {
		$class = 'EntityModel::Storage::' . $name;
		Module::Load::load($class);
	}

	my $obj = $class->new($self, $v);
	$self->storage_queued->push($obj);
	$self->add_handler_for_event(
		backend_ready => sub {
			my $self = shift;
			$self->{backend_ready} = 1;
			0 # one-shot
		}
	);
	$obj->setup($v);
	$obj->wait_for_backend($self->sap( sub {
		my ($model, $obj) = @_;
		$obj->apply_model($model);
		$model->storage->push($model->storage_queued->shift);
		$model->invoke_event(backend_ready =>) unless $model->storage_queued->count;
		0; # one-shot event
	}));
	return $self;
}

=head2 backend_ready

Returns true if all storage and cache backends are ready, false otherwise.

=cut

sub backend_ready { shift->{backend_ready} }

=head2 wait_for_backend

Requests an event to run after all backends signal readiness.

=cut

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;
}

=head2 add_cache

Add backend cache provided by an L subclass.

Example:

 $model->add_cache(PostgreSQL => { service => ... });

=cut

sub add_cache {
	my ($self, $name, $v) = @_;
	logDebug("Load cache for [%s]", $name);
	my $class = $name;
	try { Module::Load::load($class) } unless try { $class->can('new') };
	unless(try { $class->can('new') }) {
		$class = 'EntityModel::Cache::' . $name;
		Module::Load::load($class);
	}

	my $obj = $class->new($self, $v);
	$obj->setup($v);
	$obj->apply_model($self);
	$self->cache->push($obj);
	return $self;
}

=head2 add_plugin

Adds a plugin. Currently the definition of a 'plugin' is somewhat nebulous,
but L is one example.

=cut

sub add_plugin {
	my $self = shift;
	my ($name, $v) = @_;
	my $plugin;
	if(eval { $name->isa('EntityModel::Plugin') }) {
		$plugin = $name;
	} else {
		my $mod = 'EntityModel::' . $name;
		Module::Load::load($mod);
		$plugin = $mod->new;
	}
	$plugin->register($self);
	$self->plugin->push($plugin);
	return $self;
}

=head2 transaction

Run the coderef in a transaction.

Notifies all the attached L instances that we want a transaction, runs the
code, then signals end-of-transaction.

=cut

sub transaction {
	my $self = shift;
	my $code = shift;
	return EntityModel::Transaction->new(
		code	=> $code,
		model	=> $self,
		param	=> [ @_ ]
	);
}

=head2 load_plugin

Used internally, see L. Will disappear in the future.

=cut

sub load_plugin {
	my ($self, $name, $v) = @_;
	logDebug("Load plugin [%s]", $name);
	my $class = 'EntityModel::Plugin::' . $name;
	unless(eval { $class->can('new') }) {
		Module::Load::load($class);
	}
	logDebug("Activating plugin [%s]", $name);
	my $obj = $class->new($self, $v);
	$obj->setup($v);
	$self->plugin->push($obj);
	return $self;
}

=head2 handler_for

Returns the handler for a given entry in the L.

=cut

sub handler_for {
	my $self = shift;
	my $name = shift;
	logDebug("Check for handlers for [%s] node", $name);
	my @handler;
	$self->plugin->each(sub {
		push @handler, $_[0]->handler_for($name);
	});
	return @handler;
}

sub defer {
	my $self = shift;
	my $code = shift;

}

{
my $model;
sub default_model {
	my $class = shift;
	if(@_) {
		my $old_model = $model;
		$model = shift;
		return $old_model;
	}
	$model ||= EntityModel->new;
	return $model
}
}

=head2 DESTROY

Unload all plugins on exit.

=cut

sub DESTROY {
	my $self = shift;
	$self->plugin->each(sub {
		$_[0]->unload;
	});
}

1;

__END__