File Coverage

blib/lib/Storage/Abstract/Driver.pm

Criterion	Covered	Total	%
statement	72	88	81.8
branch	14	16	87.5
condition	17	17	100.0
subroutine	19	26	73.0
pod	7	17	41.1
total	129	164	78.6

package Storage::Abstract::Driver;
$Storage::Abstract::Driver::VERSION = '0.008';
use v5.14;
use warnings;

use Mooish::Base -standard;

use Scalar::Util qw(blessed);
use Storage::Abstract::Handle;
use Storage::Abstract::X;

# Not using File::Spec here, because paths must be unix-like regardless of
# local OS
use constant UPDIR_STR => '..';
use constant CURDIR_STR => '.';
use constant DIRSEP_STR => '/';

has param 'readonly' => (
	isa => Bool,
	writer => 1,
	lazy => 1,
	clearer => -hidden,
);

# HELPERS

# this is intentionally not portable - only drivers working on an actual
# filesystem should port this unix-like path to its own representation
sub resolve_path
{
	my ($self, $name, %opts) = @_;

	my @path = $self->split_path($name);
	Storage::Abstract::X::PathError->raise("path $name is empty")
		unless @path || $opts{allow_empty};

	my $i = 0;
	my $last_ok = 1;
	while ($i < @path) {
		if ($path[$i] eq UPDIR_STR) {
			Storage::Abstract::X::PathError->raise("path $name is trying to leave root")
				if $i == 0;

			splice @path, $i - 1, 2;
			$last_ok = 0;
			$i -= 1;
		}
		elsif ($path[$i] eq '' || $path[$i] eq CURDIR_STR) {
			splice @path, $i, 1;
			$last_ok = 0;
		}
		else {
			$i += 1;
			$last_ok = 1;
		}
	}

	Storage::Abstract::X::PathError->raise("path $name has no filename")
		unless $last_ok || $opts{allow_directory};

	return $self->join_path(@path);
}

sub split_path
{
	my ($self, $name) = @_;
	return split DIRSEP_STR, $name, -1;
}

sub join_path
{
	my ($self, @parts) = @_;
	return join DIRSEP_STR, @parts;
}

sub common_properties
{
	my ($self, $handle) = @_;

	return {
		size => tied(*$handle)->size,
		mtime => time,
	};
}

sub refresh
{
	# Nothing to clear here
}

# TO BE IMPLEMENTED IN SUBCLASSES

sub store_impl
{
	my ($self, $name, $handle) = @_;

	...;
}

sub is_stored_impl
{
	my ($self, $name, %opts) = @_;

	...;
}

sub retrieve_impl
{
	my ($self, $name, $properties) = @_;

	...;
}

sub dispose_impl
{
	my ($self, $name, %opts) = @_;

	...;
}

sub list_impl
{
	my ($self, $directory, %opts) = @_;

	...;
}

sub prune_impl
{
	my ($self) = @_;

	...;
}

# PUBLIC INTERFACE

sub store
{
	my ($self, $name, $handle) = @_;
	local $Storage::Abstract::X::path_context = $name;

	Storage::Abstract::X::Readonly->raise('storage is readonly')
		if $self->readonly;

	$self->store_impl($self->resolve_path($name), $handle);
	return;
}

sub is_stored
{
	my ($self, $name, %opts) = @_;
	local $Storage::Abstract::X::path_context = $name;

	return $self->is_stored_impl($self->resolve_path($name, allow_directory => $opts{directory}), %opts);
}

sub retrieve
{
	my ($self, $name, $properties) = @_;
	local $Storage::Abstract::X::path_context = $name;

	return $self->retrieve_impl($self->resolve_path($name), $properties);
}

sub dispose
{
	my ($self, $name, %opts) = @_;
	local $Storage::Abstract::X::path_context = $name;

	Storage::Abstract::X::Readonly->raise('storage is readonly')
		if $self->readonly;

	$self->dispose_impl($self->resolve_path($name, allow_directory => $opts{directory}), %opts);
	return;
}

sub list
{
	my ($self, $directory, %opts) = @_;
	local $Storage::Abstract::X::path_context = $directory;

	$directory = $self->resolve_path(
		$directory // '',
		allow_directory => !!1,
		allow_empty => !!1,
	);
	$opts{recursive} //= !!0;
	$opts{filter} //= '*';
	$opts{directories} //= !!0;

	return $self->list_impl($directory, %opts);
}

sub prune
{
	my ($self) = @_;

	Storage::Abstract::X::Readonly->raise('storage is readonly')
		if $self->readonly;

	$self->prune_impl();
	return;
}

1;

__END__