File Coverage

blib/lib/Datify/Path.pm
Criterion Covered Total %
statement 113 115 98.2
branch 38 58 65.5
condition 15 25 60.0
subroutine 20 20 100.0
pod 1 1 100.0
total 187 219 85.3


line stmt bran cond sub pod time code
1 1     1   6258 use v5.14;
  1         5  
2 1     1   6 use warnings;
  1         3  
  1         41  
3              
4             package Datify::Path v0.20.064;
5             # ABSTRACT: Describe structures like filesystem paths.
6             # VERSION
7              
8 1     1   5 use Carp (); #qw( carp croak );
  1         2  
  1         11  
9 1     1   495 use Datify (); #qw( self _internal );
  1         3  
  1         27  
10 1     1   6 use List::Util (); #qw( reduce );
  1         2  
  1         11  
11 1     1   4 use Scalar::Util (); #qw( blessed refaddr reftype );
  1         2  
  1         31  
12 1     1   4 use String::Tools qw( subst );
  1         2  
  1         70  
13              
14 1     1   467 use parent 'Datify';
  1         250  
  1         5  
15              
16             ### Public methods ###
17              
18              
19             ### Constructor ###
20              
21              
22              
23             ### Accessor ###
24              
25              
26              
27              
28              
29             ### Setter ###
30              
31              
32              
33              
34             sub pathify {
35 194 50   194 1 829 return unless defined( my $wantarray = wantarray );
36 194         297 my $self = &self;
37 194 50       396 local $_ = @_ == 0 ? $_ : @_ == 1 ? shift : \@_;
    50          
38              
39 194   100     290 my $values = $self->_cache_get($_) // [ $self->_scalar($_) ];
40 190 100       827 if ( $self->_internal ) {
41 186         298 $self->_cache_add( $_ => $values );
42             } else {
43 4         15 $values = [ map $self->_flatten, @$values ];
44 4         290 $self->_cache_reset();
45             }
46 190 50       503 return $wantarray ? @$values : $values;
47             }
48              
49             ### Private Methods ###
50             ### Do not use these methods outside of this package,
51             ### they are subject to change or disappear at any time.
52             *self = \&Datify::self;
53             sub _settings() {
54 876 50   876   1281 Carp::croak('Illegal use of private method') unless $_[0]->_internal;
55 876         1454 \state %SETTINGS;
56             }
57              
58              
59             __PACKAGE__->set(
60             datify_options => {},
61             );
62              
63             sub _datify {
64 169     169   226 my $self = &self;
65 169         295 my $datify = $self->get('_datify');
66 169 50       261 if ( not $datify ) {
67 169   50     172 $datify = Datify->new( %{ $self->get('datify_options') // {} } );
  169         234  
68 169         308 $self->set( _datify => $datify );
69             }
70 169         298 return $datify;
71             }
72              
73             __PACKAGE__->set(
74             statement => '$key = $value',
75             );
76              
77             sub _flatten {
78 340     340   6363 my $self = &self;
79 340 100       588 local $_ = shift if @_;
80 340         492 my $ref = Scalar::Util::reftype($_);
81 340 50 33     995 my ( $key, $value ) = $ref && $ref eq 'ARRAY' ? @$_ : ($_);
82              
83 340 100       473 if ( defined $value ) {
84 316         417 $ref = Scalar::Util::reftype($value);
85 316         471 my $statement = $self->get('statement');
86 316 100       587 if ( not $ref ) {
    50          
    0          
87 114         182 return subst(
88             $statement,
89             key => $key,
90             value => $self->_datify->keyify($value)
91             );
92             } elsif ( $ref eq 'ARRAY' ) {
93 202         314 return $key . $self->_flatten($value);
94             #} elsif ( $ref eq 'HASH' ) {
95             # return subst(
96             # $self->get('object'),
97             # class => $value->{class},
98             # key => $key,
99             # value => $value->{value}
100             # );
101             } elsif ( $ref eq 'SCALAR' ) {
102 0         0 return subst(
103             $statement,
104             key => $key,
105             value => $$value
106             );
107             } else {
108 0         0 die 'Unsure of how to handle ', $ref;
109             }
110             } else {
111 24         84 return $key;
112             }
113             }
114              
115             __PACKAGE__->set(
116             list_count => '[$i/$n]',
117             );
118              
119             sub _array {
120 25     25   38 my $self = &self;
121 25 50       48 local $_ = shift if @_;
122              
123 25         48 my $datify = $self->_datify;
124 25         54 my $list_count = $self->get('list_count');
125 25         61 my $size = $datify->numify( scalar @$_ );
126 25 100       64 return [ subst( $list_count, i => 0, n => 0 ), undef ]
127             if ( $size eq '0' );
128              
129 19         69 my $format = subst(
130             $list_count,
131             i => '%' . length($size) . 's',
132             n => $size
133             );
134              
135 19         1264 my @structure;
136 19         78 while ( my ( $i, $v ) = each @$_ ) {
137 101         211 my $key = sprintf( $format, $datify->numify( 1 + $i ) );
138 101         260 $self->_push_position($key);
139 101         170 push @structure, map { [ $key, $_ ] } $self->pathify($v);
  170         323  
140 100         187 $self->_pop_position();
141             }
142 18         70 return @structure;
143             }
144              
145             __PACKAGE__->set(
146             path_separator => '/',
147             );
148              
149             sub _hash {
150 36     36   51 my $self = &self;
151 36 50       67 local $_ = shift if @_;
152              
153 36         60 my $path_separator = $self->get('path_separator');
154 36 100       94 return [ $path_separator, undef ]
155             if ( 0 == scalar keys %$_ );
156              
157 30         56 my $datify = $self->_datify;
158 30         34 my @structure;
159 30         68 foreach my $k ( $datify->hashkeys($_) ) {
160 87         156 my $key = $path_separator . $datify->keyify($k);
161 87         215 $self->_push_position($key);
162 87         171 push @structure, map { [ $key, $_ ] } $self->pathify( $_->{$k} );
  166         327  
163 86         166 $self->_pop_position();
164             }
165 29         100 return @structure;
166             }
167              
168             # TODO:
169             #{
170             # foo => bless(
171             # {
172             # alpha => {},
173             # bravo => [],
174             # charlie => 123,
175             # },
176             # 'Foo::Bar'
177             # )
178             #}
179             # /foo/Foo::Bar=alpha/
180             # /foo/Foo::Bar=bravo[0/0]
181             # /foo/Foo::Bar=charlie = 123
182             #sub _object {
183             #}
184              
185             sub _scalar {
186 174     174   291 my $self = &self;
187 174 50       352 local $_ = shift if @_;
188              
189 174 100       289 return undef unless defined;
190              
191             #if ( defined( my $blessed = Scalar::Util::blessed($_) ) ) {
192             # return $blessed eq 'Regexp' ? $self->_scalar("$_")
193             # : $self->_object($_);
194             #}
195              
196 164         241 my $ref = Scalar::Util::reftype $_;
197             return
198 164 0 0     481 not($ref) ? $_
    0          
    0          
    50          
    100          
    100          
199             : $ref eq 'ARRAY' ? $self->_array($_)
200             : $ref eq 'HASH' ? $self->_hash($_)
201             : $ref eq 'REGEXP' ? $self->_scalarify("$_")
202             : $ref eq 'SCALAR' ? $self->_scalarify($$_)
203             : $ref eq 'REF' && 'REF' ne Scalar::Util::reftype($$_)
204             ? $self->pathify($$_)
205             : die 'Cannot handle ', $ref;
206             }
207              
208             __PACKAGE__->set(
209             _cache_hit => 1,
210             nested => '$key$subkey',
211             );
212              
213             sub _cache_position {
214 63     63   68 my $self = shift;
215              
216 63         109 my $nest = $self->get('nested');
217             my $pos = List::Util::reduce(
218 12     12   80 sub { subst( $nest, key => $a, subkey => $b ) },
219 63   100     197 @{ $self->{_position} //= [] }
  63         267  
220             );
221 63   100     1614 return $pos // '';
222             }
223             sub _cache_add {
224 186     186   203 my $self = shift;
225 186         186 my $ref = shift;
226 186         198 my $value = shift;
227              
228 186 100       373 return $self unless my $refaddr = Scalar::Util::refaddr $ref;
229 73   50     130 my $_cache = $self->{_cache} //= {};
230 73   50     137 my $entry = $_cache->{$refaddr} //= [ [ \$self->_cache_position ] ];
231 73 100       124 push @$entry, $value if @$entry == $self->get('_cache_hit');
232              
233 73         119 return $self;
234             }
235             sub _cache_get {
236 194     194   231 my $self = shift;
237 194         193 my $item = shift;
238              
239 194 100       498 return unless my $refaddr = Scalar::Util::refaddr $item;
240              
241 81   100     167 my $_cache = $self->{_cache} //= {};
242 81 100       160 if ( my $entry = $_cache->{$refaddr} ) {
243 20         36 my $repr = $self->get('_cache_hit');
244 20   66     59 return $entry->[$repr]
245             // Carp::croak( 'Recursive structures not allowed at ',
246             $self->_cache_position );
247             } else {
248             # Pre-populate the cache, so that we can check for loops
249 61         114 $_cache->{$refaddr} = [ [ \$self->_cache_position ] ];
250 61         487 return;
251             }
252             }
253             sub _cache_reset {
254 4     4   8 my $self = shift;
255 4   50     7 %{ $self->{_cache} //= {} } = ();
  4         96  
256 4         8 delete $self->{_datify};
257 4         9 return $self;
258             }
259              
260              
261              
262             1;
263              
264             =pod
265              
266             =encoding UTF-8
267              
268             =head1 NAME
269              
270             Datify::Path - Describe structures like filesystem paths.
271              
272             =head1 METHODS
273              
274             =head2 C<< new( name => value, name => value, ... ) >>
275              
276             Create a C object with the following options.
277              
278             See L for a description of the options and their default values.
279              
280             =head2 C
281              
282             Determine if values exists for one or more settings.
283              
284             Can be called as a class method or an object method.
285              
286             =head2 C
287              
288             Get one or more existing values for one or more settings.
289             If passed no names, returns all parameters and values.
290              
291             Can be called as a class method or an object method.
292              
293             =head2 C<< set( name => value, name => value, ... ) >>
294              
295             Change the L settings.
296             When called as a class method, changes default options.
297             When called as an object method, changes the settings and returns a
298             new object.
299              
300             See L for a description of the options and their default values.
301              
302             B When called as a object method, this returns a new instance
303             with the values set, so you will need to capture the return if you'd like to
304             persist the change:
305              
306             $datify = $datify->set( ... );
307              
308             =head2 pathify( ... )
309              
310             =head1 BUGS
311              
312             Please report any bugs or feature requests on the bugtracker website
313             L
314              
315             When submitting a bug or request, please include a test-file or a
316             patch to an existing test-file that illustrates the bug or desired
317             feature.
318              
319             =head1 VERSION
320              
321             This document describes version v0.20.064 of this module.
322              
323             =head1 AUTHOR
324              
325             Bob Kleemann
326              
327             =head1 COPYRIGHT AND LICENSE
328              
329             This software is Copyright (c) 2014-2020 by Bob Kleemann.
330              
331             This is free software, licensed under:
332              
333             The Artistic License 2.0 (GPL Compatible)
334              
335             =cut
336              
337             __DATA__