line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Data::PathSimple; |
2
|
|
|
|
|
|
|
|
3
|
4
|
|
|
4
|
|
299291
|
use strict; |
|
4
|
|
|
|
|
32
|
|
|
4
|
|
|
|
|
122
|
|
4
|
4
|
|
|
4
|
|
20
|
use warnings; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
147
|
|
5
|
|
|
|
|
|
|
|
6
|
4
|
|
|
4
|
|
1721
|
use version 0.77; |
|
4
|
|
|
|
|
8067
|
|
|
4
|
|
|
|
|
29
|
|
7
|
|
|
|
|
|
|
our $VERSION = qv("v2.0.1"); |
8
|
|
|
|
|
|
|
|
9
|
4
|
|
|
4
|
|
422
|
use Scalar::Util qw[ reftype ]; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
218
|
|
10
|
|
|
|
|
|
|
|
11
|
4
|
|
|
4
|
|
24
|
use base 'Exporter'; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
3879
|
|
12
|
|
|
|
|
|
|
our @EXPORT_OK = qw{ |
13
|
|
|
|
|
|
|
get |
14
|
|
|
|
|
|
|
set |
15
|
|
|
|
|
|
|
}; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub _error { |
18
|
99
|
100
|
|
99
|
|
589
|
'CODE' eq ref $_[0] ? $_[0]->() : $_[0]; |
19
|
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub get { |
22
|
|
|
|
|
|
|
|
23
|
522
|
|
|
522
|
1
|
4135894
|
my ( $root_ref, $root_path, $options ) = @_; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
my %opts = ( path_sep => '/', |
26
|
|
|
|
|
|
|
error => undef, |
27
|
522
|
|
100
|
|
|
1301
|
%{ $options // {} }, |
|
522
|
|
|
|
|
5877
|
|
28
|
|
|
|
|
|
|
); |
29
|
|
|
|
|
|
|
|
30
|
522
|
100
|
|
|
|
2306
|
return _error( $opts{error} ) unless defined $root_path; |
31
|
|
|
|
|
|
|
|
32
|
516
|
|
|
|
|
1622
|
my $path_sep = $opts{path_sep}; |
33
|
516
|
100
|
100
|
|
|
7710
|
$path_sep = qr/\Q$path_sep\E/ |
34
|
|
|
|
|
|
|
unless ( reftype( $path_sep ) // '' ) eq 'REGEXP'; |
35
|
|
|
|
|
|
|
|
36
|
516
|
|
|
|
|
4515
|
$root_path =~ s/^$path_sep//; |
37
|
|
|
|
|
|
|
|
38
|
516
|
|
|
|
|
3426
|
my @root_parts = split $path_sep, $root_path; |
39
|
516
|
|
|
|
|
1114
|
my $current_ref = $root_ref; |
40
|
|
|
|
|
|
|
|
41
|
516
|
100
|
|
|
|
1652
|
return _error( $opts{error} ) unless @root_parts; |
42
|
|
|
|
|
|
|
|
43
|
507
|
|
|
|
|
1588
|
foreach my $current_part ( @root_parts ) { |
44
|
1743
|
100
|
|
|
|
4530
|
if ( ref $current_ref eq 'HASH' ) { |
|
|
100
|
|
|
|
|
|
45
|
865
|
100
|
|
|
|
2281
|
if ( exists $current_ref->{$current_part} ) { |
46
|
860
|
|
|
|
|
1593
|
$current_ref = $current_ref->{$current_part}; |
47
|
860
|
|
|
|
|
1375
|
next; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
elsif ( ref $current_ref eq 'ARRAY' ) { |
51
|
870
|
100
|
|
|
|
3665
|
return _error( $opts{error} ) if $current_part !~ /^\d+$/; |
52
|
|
|
|
|
|
|
|
53
|
865
|
100
|
|
|
|
2181
|
if ( exists $current_ref->[$current_part] ) { |
54
|
860
|
|
|
|
|
1426
|
$current_ref = $current_ref->[$current_part]; |
55
|
860
|
|
|
|
|
1546
|
next; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
18
|
|
|
|
|
53
|
return _error( $opts{error} ); |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
484
|
|
|
|
|
2508
|
return $current_ref; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub set { |
66
|
|
|
|
|
|
|
|
67
|
567
|
|
|
567
|
1
|
4177450
|
my ( $root_ref, $root_path, $value, $options ) = @_; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
my %opts = ( path_sep => '/', |
70
|
|
|
|
|
|
|
error => undef, |
71
|
567
|
|
100
|
|
|
1399
|
%{ $options // {} }, |
|
567
|
|
|
|
|
5230
|
|
72
|
|
|
|
|
|
|
); |
73
|
|
|
|
|
|
|
|
74
|
567
|
100
|
|
|
|
2196
|
return _error( $opts{error} ) unless defined $root_path; |
75
|
|
|
|
|
|
|
|
76
|
552
|
|
|
|
|
1381
|
my $path_sep = $opts{path_sep}; |
77
|
552
|
100
|
100
|
|
|
7276
|
$path_sep = qr/\Q$path_sep\E/ |
78
|
|
|
|
|
|
|
unless ( reftype( $path_sep ) // '' ) eq 'REGEXP'; |
79
|
|
|
|
|
|
|
|
80
|
552
|
|
|
|
|
4320
|
$root_path =~ s/^$path_sep//; |
81
|
|
|
|
|
|
|
|
82
|
552
|
|
|
|
|
3346
|
my @root_parts = split $path_sep, $root_path; |
83
|
552
|
|
|
|
|
1135
|
my $current_ref = $root_ref; |
84
|
|
|
|
|
|
|
|
85
|
552
|
100
|
|
|
|
1724
|
return _error( $opts{error} ) unless @root_parts; |
86
|
|
|
|
|
|
|
|
87
|
534
|
|
|
|
|
2395
|
for ( my $i = 0; $i < ( @root_parts - 1 ); $i++ ) { |
88
|
1300
|
|
|
|
|
2675
|
my $current_part = $root_parts[ $i ]; |
89
|
1300
|
|
|
|
|
2378
|
my $next_part = $root_parts[ $i + 1 ]; |
90
|
|
|
|
|
|
|
|
91
|
1300
|
100
|
|
|
|
3920
|
if ( ref $current_ref eq 'HASH' ) { |
|
|
100
|
|
|
|
|
|
92
|
648
|
100
|
|
|
|
2116
|
if ( not ref $current_ref->{$current_part} ) { |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# don't use an integer as a hash key if need to |
95
|
|
|
|
|
|
|
# create the next level in the tree |
96
|
32
|
100
|
|
|
|
192
|
return undef if $current_part =~ /^\d+$/; |
97
|
|
|
|
|
|
|
|
98
|
24
|
50
|
|
|
|
94
|
$current_ref->{$current_part} |
99
|
|
|
|
|
|
|
= $next_part =~ /^\d+$/ |
100
|
|
|
|
|
|
|
? [] |
101
|
|
|
|
|
|
|
: {}; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
640
|
|
|
|
|
1050
|
$current_ref = $current_ref->{$current_part}; |
105
|
640
|
|
|
|
|
1571
|
next; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
elsif ( ref $current_ref eq 'ARRAY' ) { |
108
|
641
|
100
|
|
|
|
2569
|
return _error( $opts{error} ) if $current_part !~ /^\d+$/; |
109
|
|
|
|
|
|
|
|
110
|
633
|
100
|
|
|
|
2200
|
if ( not ref $current_ref->[$current_part] ) { |
111
|
16
|
50
|
|
|
|
111
|
$current_ref->[$current_part] |
112
|
|
|
|
|
|
|
= $next_part =~ /^\d+$/ |
113
|
|
|
|
|
|
|
? [] |
114
|
|
|
|
|
|
|
: {}; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
633
|
|
|
|
|
1005
|
$current_ref = $current_ref->[$current_part]; |
118
|
633
|
|
|
|
|
1676
|
next; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# ! ref $root_ref && @root_parts > 1 |
122
|
11
|
|
|
|
|
31
|
return _error( $opts{error} ); |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
507
|
|
|
|
|
1255
|
my $last_part = pop @root_parts; |
126
|
|
|
|
|
|
|
|
127
|
507
|
100
|
|
|
|
1360
|
if ( ref $current_ref eq 'HASH' ) { |
128
|
248
|
|
|
|
|
1683
|
return $current_ref->{$last_part} = $value; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
259
|
100
|
|
|
|
593
|
if ( ref $current_ref eq 'ARRAY' ) { |
132
|
256
|
100
|
|
|
|
860
|
return _error( $opts{error} ) if $last_part !~ /^\d+$/; |
133
|
250
|
|
|
|
|
1823
|
return $current_ref->[$last_part] = $value; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# ! ref $root_ref && @root_parts == 1 |
137
|
3
|
|
|
|
|
10
|
return _error( $opts{error} ); |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
1; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
__END__ |