File Coverage

blib/lib/Bot/Cobalt/Serializer.pm

Criterion	Covered	Total	%
statement	91	111	81.9
branch	25	58	43.1
condition	7	18	38.8
subroutine	21	22	95.4
pod	5	6	83.3
total	149	215	69.3

package Bot::Cobalt::Serializer;
$Bot::Cobalt::Serializer::VERSION = '0.021001';
use strictures 2;
use Carp;
use Scalar::Util 'reftype';

## These two must be present anyway:
use YAML::XS ();
use JSON::MaybeXS ();

use Fcntl ':flock';
use Time::HiRes  'sleep';
use Scalar::Util 'blessed';

use Bot::Cobalt::Common ':types';

use Moo;


has Format => (
  is        => 'rw',
  isa       => Str,
  builder   => sub { 'YAMLXS' },
  trigger   => sub {
    my ($self, $format) = @_;
    $format = uc($format);
    confess "Unknown format $format"
      unless grep { $_ eq $format } keys %{ $self->_types };
    confess "Requested format $format but can't find a module for it"
      unless $self->_check_if_avail($format)
  },
);

has _types => (
  lazy      => 1,
  is        => 'ro',
  isa       => HashRef,
  builder   => sub {
    +{
      YAML   => 'YAML::Syck',
      YAMLXS => 'YAML::XS',
      JSON   => 'JSON::MaybeXS',
    }
  },
);

has yamlxs_from_ref => (
  is        => 'rw',
  lazy      => 1,
  coerce    => sub { YAML::XS::Dump($_[0]) },
);

has ref_from_yamlxs => (
  is        => 'rw',
  lazy      => 1,
  coerce    => sub { YAML::XS::Load($_[0]) },
);

has yaml_from_ref => (
  is        => 'rw',
  lazy      => 1,
  coerce    => sub { require YAML::Syck; YAML::Syck::Dump($_[0]) },
);

has ref_from_yaml => (
  is        => 'rw',
  lazy      => 1,
  coerce    => sub { require YAML::Syck; YAML::Syck::Load($_[0]) },
);

has json_from_ref => (
  is        => 'rw',
  lazy      => 1,
  coerce    => sub {
    my $jsify = JSON::MaybeXS->new(
      utf8 => 1, allow_nonref => 1, convert_blessed => 1
    );
    $jsify->utf8->encode($_[0]);
  },
);

has ref_from_json => (
  is        => 'rw',
  lazy      => 1,
  coerce => sub {
    my $jsify = JSON::MaybeXS->new(
      utf8 => 1, allow_nonref => 1
    );
    $jsify->utf8->decode($_[0])
  },
);


sub BUILDARGS {
  my ($class, @args) = @_;
  ## my $serializer = Bot::Cobalt::Serializer->new( %opts )
  ## Serialize to YAML using YAML::XS:
  ## ->new()
  ## - or -
  ## ->new($format)
  ## ->new('JSON')  # f.ex
  ## - or -
  ## ->new( Format => 'JSON' )   ## --> to JSON
  ## - or -
  ## ->new( Format => 'YAML' ) ## --> to YAML1.0
  @args == 1 ? { Format => $args[0] } : { @args }
}

sub freeze {
  ## ->freeze($ref)
  my ($self, $ref) = @_;
  unless (defined $ref) {
    carp "freeze() received no data";
    return
  }

  my $method = lc( $self->Format );
  $method = $method . "_from_ref";

  $self->$method($ref)
}

sub thaw {
  ## ->thaw($data)
  my ($self, $data) = @_;
  unless (defined $data) {
    carp "thaw() received no data";
    return
  }

  my $method = lc( $self->Format );
  $method = "ref_from_" . $method ;

  $self->$method($data)
}

sub writefile {
  my ($self, $path, $ref, $opts) = @_;
  ## $serializer->writefile($path, $ref [, { Opts });

  if (!$path) {
    confess "writefile called without path argument"
  } elsif (!defined $ref) {
    confess "writefile called without data to serialize"
  }

  my $frozen = $self->freeze($ref);

  $self->_write_serialized($path, $frozen, $opts)
}

sub readfile {
  my ($self, $path, $opts) = @_;
  ## my $ref = $serializer->readfile($path)

  if (!$path) {
    confess "readfile called without path argument";
  } elsif (!-e $path ) {
    confess "readfile called on nonexistant file $path";
  }

  my $data = $self->_read_serialized($path, $opts);

  $self->thaw($data)
}

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

  my $module = $self->_types->{ $self->Format };
  { local $@; eval "require $module" }
  return($module, $module->VERSION);
}



sub _check_if_avail {
  my ($self, $type) = @_;

  my $module;
  return unless $module = $self->_types->{$type};

  {
    local $@;
    eval "require $module";
    return if $@;
  }

  return $module
}


sub _read_serialized {
  my ($self, $path, $opts) = @_;
  return unless defined $path;

  my $lock = 1;
  if (defined $opts && ref $opts && reftype $opts eq 'HASH') {
    $lock = $opts->{Locking} if defined $opts->{Locking};
  }

  if (blessed $path && $path->can('slurp_utf8')) {
    return $path->slurp_utf8
  } else {
    open(my $in_fh, '<:encoding(UTF-8)', $path)
      or confess "open failed for $path: $!";

    if ($lock) {
      flock($in_fh, LOCK_SH)
        or confess "LOCK_SH failed for $path: $!";
     }

    my $data = join '', <$in_fh>;

    flock($in_fh, LOCK_UN) if $lock;

    close($in_fh)
      or carp "close failed for $path: $!";

    return $data
  }
}

sub _write_serialized {
  my ($self, $path, $data, $opts) = @_;
  return unless $path and defined $data;

  my $lock    = 1;
  my $timeout = 2;

  if (defined $opts && ref $opts && reftype $opts eq 'HASH') {
    $lock    = $opts->{Locking} if defined $opts->{Locking};
    $timeout = $opts->{Timeout} if $opts->{Timeout};
  }

  open(my $out_fh, '>>:encoding(UTF-8)', $path)
    or confess "open failed for $path: $!";

  if ($lock) {
    my $timer = 0;

    until ( flock $out_fh, LOCK_EX | LOCK_NB ) {
      confess "Failed writefile lock ($path), timed out ($timeout)"
        if $timer > $timeout;

      sleep 0.01;
      $timer += 0.01;
    }

  }

  seek($out_fh, 0, 0)
    or confess "seek failed for $path: $!";
  truncate($out_fh, 0)
    or confess "truncate failed for $path";

  print $out_fh $data;

  flock($out_fh, LOCK_UN) if $lock;

  close($out_fh)
    or carp "close failed for $path: $!";

  return 1
}

1;
__END__