view release on metacpan or  search on metacpan

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

package File::DataClass::Storage;

use namespace::autoclean;

use Class::Null;
use English                    qw( -no_match_vars );
use File::Copy;
use File::DataClass::Constants qw( EXCEPTION_CLASS FALSE NUL TRUE );
use File::DataClass::Functions qw( is_stale merge_file_data
                                   merge_for_update throw );
use File::DataClass::Types     qw( Bool HashRef Object Str );
use Scalar::Util               qw( blessed );
use Try::Tiny;
use Unexpected::Functions      qw( RecordAlreadyExists PathNotFound
                                   NothingUpdated Unspecified );
use Moo;

has 'atomic_write'  => is => 'ro', isa => Bool, default => TRUE;

has 'backup'        => is => 'ro', isa => Str,  default => NUL;

has 'encoding'      => is => 'ro', isa => Str,  default => NUL;

has 'extn'          => is => 'ro', isa => Str,  default => NUL;

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

has 'schema'        => is => 'ro', isa => Object,
   handles          => { _cache => 'cache', _lock  => 'lock',
                         _log   => 'log',   _perms => 'perms', },
   required         => TRUE,  weak_ref => TRUE;

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

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

# Private functions
my $_get_src_attributes = sub {
   my ($cond, $src) = @_;

   return grep { not m{ \A _ }mx
                 and $_ ne 'id' and $_ ne 'name'
                 and $cond->( $_ ) } keys %{ $src };
};

my $_lock_set = sub {
   $_[ 0 ]->_lock->set( k => $_[ 1 ] ); $_[ 0 ]->_locks->{ $_[ 1 ] } = TRUE;
};

my $_lock_reset = sub {
   $_[ 0 ]->_lock->reset( k => $_[ 1 ] ); delete $_[ 0 ]->_locks->{ $_[ 1 ] };
};

my $_lock_reset_all = sub {
   my $self = shift;

   eval { $self->$_lock_reset( $_ ) } for (keys %{ $self->_locks });

   return;
};

# Public methods
sub create_or_update {
   my ($self, $path, $result, $updating, $cond) = @_;

   my $rsrc_name = $result->result_source->name;

   $self->validate_params( $path, $rsrc_name ); my $updated;

   my $data = ($self->read_file( $path, TRUE ))[ 0 ];

   try {
      my $filter = sub { $_get_src_attributes->( $cond, $_[ 0 ] ) };
      my $id     = $result->id; $data->{ $rsrc_name } //= {};

      not $updating and exists $data->{ $rsrc_name }->{ $id }
         and throw RecordAlreadyExists, [ $path, $id ], level => 2;

      $updated = merge_for_update
         ( \$data->{ $rsrc_name }->{ $id }, $result, $filter );
   }
   catch { $self->$_lock_reset( $path ); throw $_ };

   if ($updated) { $self->write_file( $path, $data, not $updating ) }
   else { $self->$_lock_reset( $path ) }

   return $updated ? $result : FALSE;
}

sub delete {
   my ($self, $path, $result) = @_;

   my $rsrc_name = $result->result_source->name;

   $self->validate_params( $path, $rsrc_name );