File Coverage

blib/lib/Data/Hive/PathPacker/Flexible.pm

Criterion	Covered	Total	%
statement	34	34	100.0
branch			n/a
condition	6	12	50.0
subroutine	10	10	100.0
pod	3	3	100.0
total	53	59	89.8

use strict;
use warnings;
package Data::Hive::PathPacker::Flexible;
# ABSTRACT: a path packer that can be customized with callbacks
$Data::Hive::PathPacker::Flexible::VERSION = '1.013';
use parent 'Data::Hive::PathPacker';

#pod =head1 DESCRIPTION
#pod
#pod This class provides the Data::Hive::PathPacker interface, and the way in which
#pod paths are packed and unpacked can be defined by callbacks set during
#pod initialization.
#pod
#pod =method new
#pod
#pod   my $path_packer = Data::Hive::PathPacker::Flexible->new( \%arg );
#pod
#pod The valid arguments are:
#pod
#pod =begin :list
#pod
#pod = escape and unescape
#pod
#pod These coderefs are used to escape and path parts so that they can be split and
#pod joined without ambiguity.  The callbacks will be called like this:
#pod
#pod   my $result = do {
#pod     local $_ = $path_part;
#pod     $store->$callback( $path_part );
#pod   }
#pod
#pod The default escape routine uses URI-like encoding on non-word characters.
#pod
#pod = join, split, and separator
#pod
#pod The C coderef is used to join pre-escaped path parts.  C is used
#pod to split up a complete name before unescaping the parts.
#pod
#pod By default, they will use a simple perl join and split on the character given
#pod in the C option.
#pod
#pod =end :list
#pod
#pod =cut

sub new {
  my ($class, $arg) = @_;
  $arg ||= {};

  my $guts = {
    separator => $arg->{separator} || '.',

    escape    => $arg->{escape}   || sub  {
      my ($self, $str) = @_;
      $str =~ s/([^a-z0-9_])/sprintf("%%%x", ord($1))/gie;
      return $str;
    },

    unescape  => $arg->{unescape} || sub {
      my ($self, $str) = @_;
      $str =~ s/%([0-9a-f]{2})/chr(hex($1))/ge;
      return $str;
    },

    join      => $arg->{join}  || sub { join $_[0]{separator}, @{$_[1]} },
    split     => $arg->{split} || sub { split /\Q$_[0]{separator}/, $_[1] },
  };

  return bless $guts => $class;
}

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

  my $escape = $self->{escape};
  my $join   = $self->{join};

  return $self->$join([ map {; $self->$escape($_) } @$path ]);
}

sub unpack_path {
  my ($self, $str) = @_;

  my $split    = $self->{split};
  my $unescape = $self->{unescape};

  return [ map {; $self->$unescape($_) } $self->$split($str) ];
}

1;

__END__