File Coverage

blib/lib/Dancer/Session/YAML.pm

Criterion	Covered	Total	%
statement	67	69	97.1
branch	16	24	66.6
condition	5	6	83.3
subroutine	17	17	100.0
pod	6	6	100.0
total	111	122	90.9

package Dancer::Session::YAML;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: YAML-file-based session backend for Dancer
$Dancer::Session::YAML::VERSION = '1.3520';
use strict;
use warnings;
use Carp;
use base 'Dancer::Session::Abstract';

use Dancer::Logger;
use Dancer::ModuleLoader;
use Dancer::Config 'setting';
use Dancer::FileUtils qw(path atomic_write);
use Dancer::Exception qw(:all);

# static

my %session_dir_initialized;

sub init {
    my $self = shift;
    $self->SUPER::init(@_);

    if (!keys %session_dir_initialized) {
        raise core_session => "YAML is needed and is not installed"
          unless Dancer::ModuleLoader->load('YAML');
    }

    # default value for session_dir
    setting('session_dir' => path(setting('appdir'), 'sessions'))
      if not defined setting('session_dir');

    my $session_dir = setting('session_dir');
    if (! exists $session_dir_initialized{$session_dir}) {
        $session_dir_initialized{$session_dir} = 1;
        # make sure session_dir exists
        if (!-d $session_dir) {
            mkdir $session_dir
              or raise core_session => "session_dir $session_dir cannot be created";
        }
        Dancer::Logger::core("session_dir : $session_dir");
    }
}

# create a new session and return the newborn object
# representing that session
sub create {
    my ($class) = @_;

    my $self = Dancer::Session::YAML->new;
    $self->flush;
    return $self;
}

# deletes the dir cache
sub reset {
    my ($class) = @_;
    %session_dir_initialized = ();
}

# Return the session object corresponding to the given id
sub retrieve {
    my ($class, $id) = @_;

    unless( $id =~ /^[\da-z]+$/i ) {
        warn "session id '$id' contains illegal characters\n";
        return;
    }

    my $session_file = yaml_file($id);

    return unless defined $session_file && -f $session_file;

    open my $fh, '+<', $session_file or die "Can't open '$session_file': $!\n";
    my $content = YAML::LoadFile($fh);
    close $fh or die "Can't close '$session_file': $!\n";

    return bless $content => ref($class) || $class;
}

# instance

sub yaml_file {
    my $id = shift;

    # Untaint Session ID before using it in file actions
    # required when running under Perl Taint mode
    $id =~ m/^([\d]*)$/;
    return unless $1;
    my $yaml_file = "$1.yml";

    return path(setting('session_dir'), $yaml_file);
}

sub destroy {
    my ($self) = @_;
    use Dancer::Logger;
    Dancer::Logger::core(
        "trying to remove session file: " . yaml_file($self->id));
    unlink yaml_file($self->id) if -f yaml_file($self->id);
}

sub flush {
    my $self         = shift;
    my $session_file = yaml_file( $self->id );

    atomic_write( setting('session_dir'), yaml_file($self->id), YAML::Dump($self) );

    return $self;
}

1;

__END__