view release on metacpan or  search on metacpan

lib/File/DataClass/Schema.pm  view on Meta::CPAN

use Scalar::Util               qw( blessed );
use Unexpected::Functions      qw( Unspecified );
use Moo;

my $_cache_objects = {};

# Private methods
my $_build_cache = sub {
   my $self  = shift;
   my $attr  = { builder => $self,
                 cache_attributes => { %{ $self->cache_attributes } }, };
   my $cattr = $attr->{cache_attributes};
  (my $ns    = lc __PACKAGE__) =~ s{ :: }{-}gmx;

   $ns = $cattr->{namespace} //= $ns;
   exists $_cache_objects->{ $ns } and return $_cache_objects->{ $ns };
   $self->cache_class eq 'none'    and return Class::Null->new;
   $cattr->{share_file} //= $self->tempdir->catfile( "${ns}.dat" )->pathname;

   return $_cache_objects->{ $ns } = $self->cache_class->new( $attr );
};

my $_build_source_registrations = sub {
   my $self = shift; my $sources = {};

   for my $moniker (keys %{ $self->result_source_attributes }) {
      my $attr = { %{ $self->result_source_attributes->{ $moniker } } };
      my $class = delete $attr->{result_source_class}
               // $self->result_source_class;

      $attr->{name} = $moniker; $attr->{schema} = $self;

      $sources->{ $moniker } = $class->new( $attr );
   }

   return $sources;
};

my $_build_storage = sub {
   my $self = shift; my $class = $self->storage_class;

   if (first_char $class eq '+') { $class = substr $class, 1 }
   else { $class = qualify_storage_class $class }

   ensure_class_loaded $class;

   return $class->new( { %{ $self->storage_attributes }, schema => $self } );
};

my $_constructor = sub {
   my $class = shift;
   my $attr  = { cache_class => 'none', storage_class => 'Any' };

   return $class->new( $attr );
};

# Private attributes
has 'cache'                    => is => 'lazy', isa => Cache,
   builder                     => $_build_cache;

has 'cache_attributes'         => is => 'ro',   isa => HashRef,
   builder                     => sub { {
      page_size                => 131_072,
      num_pages                => 89,
      unlink_on_exit           => TRUE, } };

has 'cache_class'              => is => 'ro',   isa => ClassName | DummyClass,
   default                     => 'File::DataClass::Cache';

has 'lock'                     => is => 'lazy', isa => Lock,
   builder                     => sub { Class::Null->new };

has 'log'                      => is => 'lazy', isa => Object,
   builder                     => sub { Class::Null->new };

has 'path'                     => is => 'rw',   isa => Path, coerce => TRUE;

has 'perms'                    => is => 'rw',   isa => Num, default => PERMS;

has 'result_source_attributes' => is => 'ro',   isa => HashRef,
   builder                     => sub { {} };

has 'result_source_class'      => is => 'ro',   isa => ClassName,
   default                     => 'File::DataClass::ResultSource';

has 'source_registrations'     => is => 'lazy', isa => HashRef[Object],
   builder                     => $_build_source_registrations;

has 'storage'                  => is => 'rw',   isa => Object,
   builder                     => $_build_storage, lazy => TRUE;

has 'storage_attributes'       => is => 'ro',   isa => HashRef,
   builder                     => sub { {} };

has 'storage_class'            => is => 'rw',   isa => Str,
   default                     => 'JSON', lazy => TRUE;

has 'tempdir'                  => is => 'ro',   isa => Directory,
   coerce                      => TRUE, builder => sub { File::Spec->tmpdir };

# Construction
around 'BUILDARGS' => sub {
   my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args );

   my $builder = $attr->{builder} or return $attr;
   my $config  = $builder->can( 'config' ) ? $builder->config : {};
   my $keys    = [ qw( cache_attributes cache_class lock log tempdir ) ];

   merge_attributes $attr, $builder, $keys;
   merge_attributes $attr, $config,  $keys;

   return $attr;
};

# Public methods
sub dump {
   my ($self, $args) = @_; blessed $self or $self = $self->$_constructor;

   my $path = $args->{path} // $self->path; blessed $path or $path = io $path;

   return $self->storage->dump( $path, $args->{data} );
}

sub load {
   my ($self, @paths) = @_; blessed $self or $self = $self->$_constructor;

   $paths[ 0 ] //= $self->path;

   return $self->storage->load( map { (blessed $_) ? $_ : io $_ } @paths );
}

sub resultset {
   my ($self, $moniker) = @_; return $self->source( $moniker )->resultset;
}

sub source {
   my ($self, $moniker) = @_;

   $moniker or throw Unspecified, [ 'result source' ];

   my $source = $self->source_registrations->{ $moniker }
      or throw 'Result source [_1] unknown', [ $moniker ];

   return $source;
}

sub sources {
   return keys %{ shift->source_registrations };
}

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