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


line stmt bran cond sub pod time code
1 1     1   502 use strict;
  1         3  
  1         29  
2 1     1   6 use warnings;
  1         2  
  1         42  
3             package Data::Hive::PathPacker::Flexible 1.014;
4             # ABSTRACT: a path packer that can be customized with callbacks
5              
6 1     1   5 use parent 'Data::Hive::PathPacker';
  1         2  
  1         5  
7              
8             #pod =head1 DESCRIPTION
9             #pod
10             #pod This class provides the Data::Hive::PathPacker interface, and the way in which
11             #pod paths are packed and unpacked can be defined by callbacks set during
12             #pod initialization.
13             #pod
14             #pod =method new
15             #pod
16             #pod my $path_packer = Data::Hive::PathPacker::Flexible->new( \%arg );
17             #pod
18             #pod The valid arguments are:
19             #pod
20             #pod =begin :list
21             #pod
22             #pod = escape and unescape
23             #pod
24             #pod These coderefs are used to escape and path parts so that they can be split and
25             #pod joined without ambiguity. The callbacks will be called like this:
26             #pod
27             #pod my $result = do {
28             #pod local $_ = $path_part;
29             #pod $store->$callback( $path_part );
30             #pod }
31             #pod
32             #pod The default escape routine uses URI-like encoding on non-word characters.
33             #pod
34             #pod = join, split, and separator
35             #pod
36             #pod The C coderef is used to join pre-escaped path parts. C is used
37             #pod to split up a complete name before unescaping the parts.
38             #pod
39             #pod By default, they will use a simple perl join and split on the character given
40             #pod in the C option.
41             #pod
42             #pod =end :list
43             #pod
44             #pod =cut
45              
46             sub new {
47 1     1 1 33 my ($class, $arg) = @_;
48 1   50     5 $arg ||= {};
49              
50             my $guts = {
51             separator => $arg->{separator} || '.',
52              
53             escape => $arg->{escape} || sub {
54 19     19   35 my ($self, $str) = @_;
55 19         45 $str =~ s/([^a-z0-9_])/sprintf("%%%x", ord($1))/gie;
  2         16  
56 19         57 return $str;
57             },
58              
59             unescape => $arg->{unescape} || sub {
60 30     30   51 my ($self, $str) = @_;
61 30         58 $str =~ s/%([0-9a-f]{2})/chr(hex($1))/ge;
  3         16  
62 30         79 return $str;
63             },
64              
65 11     11   19 join => $arg->{join} || sub { join $_[0]{separator}, @{$_[1]} },
  11         47  
66 15     15   59 split => $arg->{split} || sub { split /\Q$_[0]{separator}/, $_[1] },
67 1   50     30 };
      50        
      50        
      50        
      50        
68              
69 1         11 return bless $guts => $class;
70             }
71              
72             sub pack_path {
73 11     11 1 21 my ($self, $path) = @_;
74              
75 11         18 my $escape = $self->{escape};
76 11         17 my $join = $self->{join};
77              
78 11         22 return $self->$join([ map {; $self->$escape($_) } @$path ]);
  19         34  
79             }
80              
81             sub unpack_path {
82 15     15 1 28 my ($self, $str) = @_;
83              
84 15         23 my $split = $self->{split};
85 15         22 my $unescape = $self->{unescape};
86              
87 15         27 return [ map {; $self->$unescape($_) } $self->$split($str) ];
  30         49  
88             }
89              
90             1;
91              
92             __END__