File Coverage

blib/lib/Dancer2/Core/Role/SessionFactory/File.pm

Criterion	Covered	Total	%
statement	56	67	83.5
branch	15	32	46.8
condition	0	3	0.0
subroutine	14	15	93.3
pod	0	1	0.0
total	85	118	72.0

package Dancer2::Core::Role::SessionFactory::File;
# ABSTRACT: Role for file-based session factories
$Dancer2::Core::Role::SessionFactory::File::VERSION = '2.1.0';
use Moo::Role;
with 'Dancer2::Core::Role::SessionFactory';

use Carp 'croak';
use Dancer2::Core::Types;
use Dancer2::FileUtils qw(escape_filename);
use Fcntl ':flock';
use File::Copy ();
use Path::Tiny ();

#--------------------------------------------------------------------------#
# Required by classes consuming this role
#--------------------------------------------------------------------------#

requires '_suffix';              # '.yml', '.json', etc.
requires '_thaw_from_handle';    # given handle, return session 'data' field
requires '_freeze_to_handle';    # given handle and data, serialize it


#--------------------------------------------------------------------------#
# Attributes and methods
#--------------------------------------------------------------------------#

has session_dir => (
    is      => 'ro',
    isa     => Str,
    default => sub { Path::Tiny::path( '.', 'sessions' )->stringify },
);

has _session_dir_path => (
    is       => 'ro',
    lazy     => 1,
    builder  => '_build_session_dir_path',
    init_arg => undef,
);

sub _build_session_dir_path {
    my $self = shift;
    return Path::Tiny::path( $self->session_dir );
}

sub BUILD {
    my $self = shift;

    if ( !$self->_session_dir_path->is_dir ) {
        mkdir $self->session_dir
          or croak "Unable to create session dir : "
          . $self->session_dir . ' : '
          . $!;
    }
}

sub _sessions {
    my ($self) = @_;
    my $sessions = [];

    opendir( my $dh, $self->session_dir )
      or croak "Unable to open directory " . $self->session_dir . " : $!";

    my $suffix = $self->_suffix;

    while ( my $file = readdir($dh) ) {
        next if $file eq '.' || $file eq '..';
        if ( $file =~ /(\w+)\Q$suffix\E/ ) {
            push @{$sessions}, $1;
        }
    }
    closedir($dh);

    return $sessions;
}

sub _retrieve {
    my ( $self, $id ) = @_;
    my $session_file = $self->_session_dir_path->child(
        escape_filename($id) . $self->_suffix,
    )->stringify;

    croak "Invalid session ID: $id" unless -f $session_file;

    open my $fh, '+<', $session_file or die "Can't open '$session_file': $!\n";
    flock $fh, LOCK_SH or die "Can't lock file '$session_file': $!\n";
    my $data = $self->_thaw_from_handle($fh);
    close $fh or die "Can't close '$session_file': $!\n";

    return $data;
}

sub _change_id {
    my ($self, $old_id, $new_id) = @_;

    my $old_path = $self->_session_dir_path->child(
        escape_filename($old_id) . $self->_suffix
    )->stringify;

    return if !-f $old_path;

    my $new_path = $self->_session_dir_path->child(
        escape_filename($new_id) . $self->_suffix
    )->stringify;

    File::Copy::move($old_path, $new_path);
}

sub _destroy {
    my ( $self, $id ) = @_;
    my $session_file = $self->_session_dir_path->child(
        escape_filename($id) . $self->_suffix
    )->stringify;
    return if !-f $session_file;

    unlink $session_file;
}

sub _flush {
    my ( $self, $id, $data ) = @_;
    my $session_file = $self->_session_dir_path->child(
        escape_filename($id) . $self->_suffix
    )->stringify;

    open my $fh, '>', $session_file or die "Can't open '$session_file': $!\n";
    flock $fh, LOCK_EX or die "Can't lock file '$session_file': $!\n";
    seek $fh, 0, 0 or die "Can't seek in file '$session_file': $!\n";
    truncate $fh, 0 or die "Can't truncate file '$session_file': $!\n";
    binmode $fh, ':encoding(UTF-8)';
    $self->_freeze_to_handle( $fh, $data );
    close $fh or die "Can't close '$session_file': $!\n";

    return $data;
}

1;

__END__