view release on metacpan or  search on metacpan

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

   try {
      my $stat = $path->stat; defined $stat and $path_mtime = $stat->{mtime};

      my $meta; ($data, $meta) = $self->_cache->get( $path );

      my $cache_mtime = $self->meta_unpack( $meta );

      if (is_stale $data, $cache_mtime, $path_mtime) {
         if ($for_update and not $path->exists) {
            $data = {}; # uncoverable statement
         }
         else {
            $data = $self->read_from_file( $path->lock ); $path->close;
            $meta = $self->meta_pack( $path_mtime );
            $self->_cache->set( $path, $data, $meta );
            $self->_log->debug( "Read file  ${path}" );
         }
      }
      else { $self->_log->debug( "Read cache ${path}" ) }
   }
   catch { $self->$_lock_reset( $path ); throw $_ };

   $for_update or $self->$_lock_reset( $path );

   return ($data, $path_mtime);
}

sub read_from_file {
   throw 'Method [_1] not overridden in subclass [_2]',
         [ 'read_from_file', blessed $_[ 0 ] ];
}

sub select {
   my ($self, $path, $rsrc_name) = @_;

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

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

   return exists $data->{ $rsrc_name } ? $data->{ $rsrc_name } : {};
}

sub txn_do {
   my ($self, $path, $code_ref) = @_;

   my $wantarray = wantarray; $self->validate_params( $path, TRUE );

   my $key = "txn:${path}"; $self->$_lock_set( $key ); my $res;

   try {
      if ($wantarray) { $res = [ $code_ref->() ] }
      else { $res = $code_ref->() }
   }
   catch { $self->$_lock_reset( $key ); throw $_, { level => 4 } };

   $self->$_lock_reset( $key );

   return $wantarray ? @{ $res } : $res;
}

sub update {
   my ($self, $path, $result, $updating, $cond) = @_;

   $updating //= TRUE; $cond //= sub { TRUE };

   my $updated = $self->create_or_update( $path, $result, $updating, $cond )
      or throw NothingUpdated, level => 2;

   return $updated;
}

sub validate_params {
   my ($self, $path, $rsrc_name) = @_;

   $path         or throw Unspecified, [ 'path name' ], level => 2;
   blessed $path or throw 'Path [_1] is not blessed', [ $path ], level => 2;
   $rsrc_name    or throw 'Path [_1] result source not specified', [ $path ],
                          level => 2;

   return;
}

sub write_file {
   my ($self, $path, $data, $create) = @_; my $exists = $path->exists;

   try {
      $create or $exists or throw PathNotFound, [ $path ];
      $exists or $path->perms( $self->_perms );
      $self->atomic_write and $path->atomic;

      if ($exists and $self->backup and not $path->empty) {
         copy( "${path}", $path.$self->backup )
            or throw 'Backup copy failed: [_1]', [ $OS_ERROR ];
      }

      try   { $data = $self->write_to_file( $path->lock, $data ); $path->close }
      catch { $path->delete; throw $_ };

      $self->_cache->remove( $path );
      $self->_log->debug( "Write file ${path}" )
   }
   catch { $self->$_lock_reset( $path ); throw $_ };

   $self->$_lock_reset( $path );
   return $data;
}

sub write_to_file {
   throw 'Method [_1] not overridden in subclass [_2]',
         [ 'write_to_file', blessed $_[ 0 ] ];
}

# Backcompat
sub _read_file {
   throw 'Class [_1] should never call _read_file', [ blessed $_[ 0 ] ];
}

sub _write_file {
   throw 'Class [_1] should never call _write_file', [ blessed $_[ 0 ] ];
}