File Coverage

blib/lib/Pcore/Util/Path.pm
Criterion Covered Total %
statement 93 153 60.7
branch 33 68 48.5
condition 4 20 20.0
subroutine 19 28 67.8
pod 0 6 0.0
total 149 275 54.1


line stmt bran cond sub pod time code
1             package Pcore::Util::Path;
2              
3 5     5   33 use Pcore -class;
  5         10  
  5         35  
4 5     5   2245 use Storable qw[];
  5         12216  
  5         142  
5 5     5   35 use Pcore::Util::Scalar qw[is_blessed_ref is_plain_arrayref];
  5         10  
  5         41  
6 5     5   1721 use Pcore::Util::URI;
  5         19  
  5         1271  
7              
8             use overload #
9             q[""] => sub {
10 50     50   965 return $_[0]->to_string;
11             },
12             q[cmp] => sub {
13 29 50   29   628 return !$_[2] ? $_[0]->to_string cmp $_[1] : $_[1] cmp $_[0]->to_string;
14             },
15             q[~~] => sub {
16 0 0   0   0 return !$_[2] ? $_[0]->to_string ~~ $_[1] : $_[1] ~~ $_[0]->to_string;
17             },
18             q[-X] => sub {
19 0     0   0 return eval "-$_[1] '@{[$_[0]->encoded]}'"; ## no critic qw[BuiltinFunctions::ProhibitStringyEval]
  0         0  
20             },
21 5     5   43 fallback => undef;
  5         9  
  5         62  
22              
23             has to_string => ( is => 'lazy', init_arg => undef );
24             has to_uri => ( is => 'lazy', init_arg => undef );
25             has encoded => ( is => 'lazy', init_arg => undef );
26              
27             has lazy => ( is => 'ro', default => 0 );
28             has is_abs => ( is => 'ro', required => 1 );
29             has is_dir => ( is => 'lazy', init_arg => undef );
30             has is_file => ( is => 'lazy', init_arg => undef );
31              
32             has volume => ( is => 'ro', default => q[] );
33             has path => ( is => 'ro', required => 1 ); # contains normalized path with volume
34             has canonpath => ( is => 'lazy', isa => Str, init_arg => undef );
35              
36             has dirname => ( is => 'lazy', isa => Str, init_arg => undef );
37             has dirname_canon => ( is => 'lazy', isa => Str, init_arg => undef );
38             has filename => ( is => 'lazy', isa => Str, init_arg => undef );
39             has filename_base => ( is => 'lazy', isa => Str, init_arg => undef );
40             has suffix => ( is => 'lazy', isa => Str, init_arg => undef );
41              
42             has default_mime_type => ( is => 'lazy', isa => Str, default => 'application/octet-stream' );
43             has mime_type => ( is => 'ro', isa => Str );
44             has mime_category => ( is => 'lazy', isa => Str );
45              
46             around new => sub ( $orig, $self, $path = q[], @ ) {
47             my %args = (
48             is_dir => 0,
49             mswin => $MSWIN,
50             base => q[],
51             lazy => 0,
52             from_uri => 0,
53             splice @_, 3,
54             );
55              
56             $self = ref $self if is_blessed_ref $self;
57              
58             my $path_args = {
59             path => $path,
60             volume => q[],
61             is_abs => 0,
62             lazy => $args{lazy},
63             };
64              
65             # speed optimizations
66             if ( $path_args->{path} eq q[] ) {
67             if ( $args{base} eq q[] ) {
68             return bless {
69             path => q[],
70             volume => q[],
71             is_abs => 0,
72             },
73             $self;
74             }
75             else {
76             $path_args->{path} = delete $args{base};
77             }
78             }
79             elsif ( $path_args->{path} eq q[/] ) {
80             return bless {
81             path => q[/],
82             volume => q[],
83             is_abs => 1,
84             },
85             $self;
86             }
87              
88             # unescape and decode URI
89             if ( $args{from_uri} && !ref $path_args->{path} ) {
90             $path_args->{path} = URI::Escape::XS::decodeURIComponent( $path_args->{path} );
91              
92             utf8::decode( $path_args->{path} );
93             }
94              
95             # convert "\" to "/"
96             $path_args->{path} =~ s[\\+][/]smg;
97              
98             # convert "//" -> "/"
99             $path_args->{path} =~ s[/{2,}][/]smg;
100              
101             # parse MSWIN volume
102             if ( $args{mswin} ) {
103             if ( $args{from_uri} ) {
104             if ( $path_args->{path} =~ s[\A/([[:alpha:]]):/][/]smi ) {
105             $path_args->{volume} = lc $1;
106              
107             $path_args->{is_abs} = 1;
108             }
109             }
110             elsif ( $path_args->{path} =~ s[\A([[:alpha:]]):/][/]smi ) {
111             $path_args->{volume} = lc $1;
112              
113             $path_args->{is_abs} = 1;
114             }
115             }
116              
117             # detect if path is absolute
118             $path_args->{is_abs} = 1 if substr( $path_args->{path}, 0, 1 ) eq q[/];
119              
120             # add trailing "/" if path marked as dir
121             $path_args->{path} .= q[/] if $args{is_dir} && substr( $path_args->{path}, -1, 1 ) ne q[/];
122              
123             # inherit from base path
124             if ( defined $args{base} && $args{base} ne q[] && !$path_args->{is_abs} ) {
125              
126             # create base path object
127             $args{base} = $self->new( $args{base}, mswin => $args{mswin}, from_uri => $args{from_uri} ) if !ref $args{base};
128              
129             # inherit base path attributes
130             $path_args->{is_abs} = $args{base}->{is_abs};
131              
132             if ( $args{base}->{volume} ) {
133             $path_args->{volume} = $args{base}->{volume};
134              
135             # remove volume from base path dirname
136             $path_args->{path} = $args{base}->dirname =~ s[\A[[:alpha:]]:][]smr . $path_args->{path};
137             }
138             else {
139             $path_args->{path} = $args{base}->dirname . $path_args->{path};
140             }
141             }
142              
143             # normalize, remove dot segments
144             if ( index( $path_args->{path}, q[.] ) > -1 ) {
145              
146             # perform full normalization only if path contains "."
147             my @segments;
148              
149             my @split = split m[/]sm, $path_args->{path};
150              
151             for my $seg (@split) {
152             next if $seg eq q[] || $seg eq q[.];
153              
154             if ( $seg eq q[..] ) {
155             if ( !$path_args->{is_abs} ) {
156             if ( !@segments || $segments[-1] eq q[..] ) {
157             push @segments, $seg;
158             }
159             else {
160             pop @segments;
161             }
162             }
163             else {
164             pop @segments;
165             }
166             }
167             else {
168             push @segments, $seg;
169             }
170             }
171              
172             # add leading "/" for abs path
173             unshift @segments, q[] if $path_args->{is_abs};
174              
175             # preserve last "/"
176             push @segments, q[] if substr( $path_args->{path}, -1, 1 ) eq q[/] || $split[-1] eq q[.] || $split[-1] eq q[..];
177              
178             # concatenate path segments
179             $path_args->{path} = join q[/], @segments;
180             }
181              
182             # add volume
183             $path_args->{path} = $path_args->{volume} . q[:] . $path_args->{path} if $path_args->{volume};
184              
185             return bless $path_args, $self;
186             };
187              
188             around mime_type => sub ( $orig, $self, $shebang = undef ) {
189             return q[] if !$self->is_file;
190              
191             if ( $shebang && !$self->{mime_type} && !$self->{_mime_type_shebang} ) {
192             $self->{_mime_type_shebang} = 1;
193              
194             delete $self->{mime_type};
195             }
196              
197             if ( !exists $self->{mime_type} ) {
198             \my $mime_types = \$self->_get_mime_types;
199              
200             if ( exists $mime_types->{filename}->{ $self->filename } ) {
201             $self->{mime_type} = $mime_types->{filename}->{ $self->filename };
202             }
203             elsif ( my $suffix = $self->suffix ) {
204             if ( exists $mime_types->{suffix}->{$suffix} ) {
205             $self->{mime_type} = $mime_types->{suffix}->{$suffix};
206             }
207             elsif ( exists $mime_types->{suffix}->{ lc $suffix } ) {
208             $self->{mime_type} = $mime_types->{suffix}->{ lc $suffix };
209             }
210             }
211              
212             if ( $shebang && !exists $self->{mime_type} ) {
213             my $buf_ref;
214              
215             if ( ref $shebang ) {
216             $buf_ref = $shebang;
217             }
218             elsif ( -f $self ) {
219              
220             # read first 50 bytes
221             P->file->read_bin(
222             $self,
223             buf_size => 50,
224             cb => sub {
225             $buf_ref = $_[0] if $_[0];
226              
227             return;
228             }
229             );
230             }
231              
232             if ( $buf_ref && $buf_ref->$* =~ /\A(#!.+?)$/sm ) {
233             for my $mime_type ( keys $mime_types->{shebang}->%* ) {
234             if ( $1 =~ $mime_types->{shebang}->{$mime_type} ) {
235             $self->{mime_type} = $mime_type;
236              
237             last;
238             }
239             }
240             }
241             }
242              
243             $self->{mime_type} //= q[];
244             }
245              
246             return $self->{mime_type} || $self->default_mime_type;
247             };
248              
249             # apache MIME types
250             # http://svn.apache.org/viewvc/httpd/httpd/trunk/docs/conf/mime.types?view=co
251             our $MIME_TYPES;
252              
253 81     81   680 sub _build_to_string ($self) {
  81         114  
  81         108  
254 81         202 my $path = $self->path;
255              
256 81 100       196 if ( $self->{lazy} ) {
257 5         14 $self->{lazy} = 0;
258              
259 5 50 33     79 if ( $self->is_dir && !-d $path ) {
    50 33        
260 0         0 P->file->mkpath($path);
261             }
262             elsif ( $self->is_file && !-f $path ) {
263 0         0 P->file->mkpath( $self->dirname );
264              
265 0         0 P->file->touch($path);
266             }
267             }
268              
269 81         803 return $path;
270             }
271              
272 43     43   337 sub _build_to_uri ($self) {
  43         58  
  43         52  
273 43         48 my $uri;
274              
275 43 50       131 $uri .= q[/] if $self->volume;
276              
277 43         95 $uri .= $self->path;
278              
279 43 50       97 utf8::encode($uri) if utf8::is_utf8($uri);
280              
281             # http://tools.ietf.org/html/rfc3986#section-3.3
282 43         746 $uri =~ s/([$Pcore::Util::URI::ESCAPE_RE])/$Pcore::Util::URI::ESC_CHARS->{$1}/smg;
283              
284 43         284 return $uri;
285             }
286              
287 0     0   0 sub _build_encoded ($self) {
  0         0  
  0         0  
288 0         0 return P->file->encode_path( $self->path );
289             }
290              
291 130     130   976 sub _build_is_dir ($self) {
  130         160  
  130         137  
292              
293             # empty path is dir
294 130 100       332 return 1 if $self->path eq q[];
295              
296             # is dir if path ended with "/"
297 127 100       797 return substr( $self->path, -1, 1 ) eq q[/] ? 1 : 0;
298             }
299              
300 10     10   101 sub _build_is_file ($self) {
  10         21  
  10         17  
301 10         159 return !$self->is_dir;
302             }
303              
304 31     31   263 sub _build_dirname ($self) {
  31         44  
  31         40  
305 31         476 return substr $self->path, 0, rindex( $self->path, q[/] ) + 1;
306             }
307              
308 0     0   0 sub _build_dirname_canon ($self) {
  0         0  
  0         0  
309 0         0 return $self->dirname =~ s[/\z][]smr;
310             }
311              
312 15     15   140 sub _build_filename ($self) {
  15         24  
  15         20  
313 15 100       63 return q[] if $self->path eq q[];
314              
315 14         246 return substr $self->path, rindex( $self->path, q[/] ) + 1;
316             }
317              
318 0     0   0 sub _build_filename_base ($self) {
  0         0  
  0         0  
319 0 0       0 if ( $self->filename ne q[] ) {
320 0 0       0 if ( ( my $idx = rindex $self->filename, q[.] ) > 0 ) {
321 0         0 return substr $self->filename, 0, $idx;
322             }
323             else {
324 0         0 return $self->filename;
325             }
326             }
327              
328 0         0 return q[];
329             }
330              
331 3     3   33 sub _build_suffix ($self) {
  3         5  
  3         4  
332 3 50       61 if ( $self->filename ne q[] ) {
333 3 100       58 if ( ( my $idx = rindex $self->filename, q[.] ) > 0 ) {
334 1         19 return substr $self->filename, $idx + 1;
335             }
336             }
337              
338 2         38 return q[];
339             }
340              
341             # path without trailing "/"
342 55     55   467 sub _build_canonpath ($self) {
  55         76  
  55         58  
343 55 100       147 return q[] if $self->path eq q[];
344              
345 54 100       118 return q[/] if $self->path eq q[/];
346              
347 53 50 33     139 return $self->path if $self->volume && $self->path eq $self->volume . q[:/];
348              
349 53 100       752 if ( $self->is_dir ) {
350 52         742 return substr $self->path, 0, -1;
351             }
352             else {
353 1         16 return $self->path;
354             }
355             }
356              
357 1     1 0 2 sub clone ($self) {
  1         2  
  1         1  
358 1         150 return Storable::dclone($self);
359             }
360              
361 62     62 0 91 sub realpath ($self) {
  62         75  
  62         66  
362 62 100 33     1038 if ( $self->is_dir ) {
    50          
363 57 50       157 my $path = $self->path eq q[] ? './' : $self->path;
364              
365 57 100       648 return if !-d $path;
366              
367 55         1764 return $self->new( Cwd::realpath($path), is_dir => 1 ); # Cwd::realpath always return path without trailing "/"
368             }
369             elsif ( $self->is_file && -f $self->path ) {
370 5         336 return $self->new( Cwd::realpath( Cwd::realpath( $self->path ) ) );
371             }
372             else {
373 0         0 return;
374             }
375             }
376              
377             # return new path object
378 2     2 0 3 sub to_abs ( $self, $abs_path = q[.] ) {
  2         5  
  2         3  
  2         3  
379 2 100       7 if ( $self->is_abs ) {
380 1         4 return $self->clone;
381             }
382             else {
383 1         16 return $self->new( $self->to_string, base => $abs_path );
384             }
385             }
386              
387 5     5 0 11 sub parent ($self) {
  5         10  
  5         8  
388 5 50       93 if ( $self->dirname ) {
389 5         112 my $parent = $self->new( $self->dirname . q[../] );
390              
391 5 50       106 return $parent if $parent ne $self->to_string;
392             }
393              
394 0           return;
395             }
396              
397 0     0 0   sub is_root ($self) {
  0            
  0            
398 0 0         if ( $self->is_abs ) {
399 0 0 0       if ( $self->volume && $self->dirname eq $self->volume . q[:/] ) {
    0          
400 0           return 1;
401             }
402             elsif ( $self->dirname eq q[/] ) {
403 0           return 1;
404             }
405             }
406              
407 0           return;
408             }
409              
410             # MIME
411 0     0     sub _get_mime_types ($self) {
  0            
  0            
412 0 0         unless ($MIME_TYPES) {
413 0           $MIME_TYPES = P->cfg->load( $ENV->share->get('/data/mime.json') );
414              
415             # index MIME categories
416 0           for my $suffix ( keys $MIME_TYPES->{suffix}->%* ) {
417 0           my $type;
418              
419 0 0         if ( is_plain_arrayref $MIME_TYPES->{suffix}->{$suffix} ) {
420 0           $type = $MIME_TYPES->{suffix}->{$suffix}->[0];
421              
422 0 0         $MIME_TYPES->{category}->{$type} = $MIME_TYPES->{suffix}->{$suffix}->[1] if $MIME_TYPES->{suffix}->{$suffix}->[1];
423              
424 0           $MIME_TYPES->{suffix}->{$suffix} = $type;
425             }
426             else {
427 0           $type = $MIME_TYPES->{suffix}->{$suffix};
428             }
429              
430 0 0 0       if ( !$MIME_TYPES->{category}->{$type} && $type =~ m[\A(.+?)/]sm ) {
431 0           $MIME_TYPES->{category}->{$type} = $1;
432             }
433             }
434              
435             # compile shebang
436 0           for my $key ( keys $MIME_TYPES->{shebang}->%* ) {
437 0           $MIME_TYPES->{shebang}->{$key} = qr/$MIME_TYPES->{shebang}->{$key}/sm;
438             }
439             }
440              
441 0           return $MIME_TYPES;
442             }
443              
444 0     0     sub _build_mime_category ($self) {
  0            
  0            
445 0 0         if ( $self->mime_type ) {
446 0   0       return $self->_get_mime_types->{category}->{ $self->mime_type } // q[];
447             }
448             else {
449 0           return q[];
450             }
451             }
452              
453             # INTERNALS
454             sub TO_DUMP {
455 0     0 0   my $self = shift;
456              
457 0           my $res;
458             my $tags;
459              
460 0           $res = q[path: "] . $self->path . q["];
461 0 0         $res .= qq[\nMIME type: "] . $self->mime_type . q["] if $self->mime_type;
462              
463 0           return $res, $tags;
464             }
465              
466             1;
467             ## -----SOURCE FILTER LOG BEGIN-----
468             ##
469             ## PerlCritic profile "pcore-script" policy violations:
470             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
471             ## | Sev. | Lines | Policy |
472             ## |======+======================+================================================================================================================|
473             ## | 3 | 1 | Modules::ProhibitExcessMainComplexity - Main code has high complexity score (58) |
474             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
475             ## | 3 | 19 | ErrorHandling::RequireCheckingReturnValueOfEval - Return value of eval not tested |
476             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
477             ##
478             ## -----SOURCE FILTER LOG END-----
479             __END__
480             =pod
481              
482             =encoding utf8
483              
484             =head1 NAME
485              
486             Pcore::Util::Path
487              
488             =head1 SYNOPSIS
489              
490             =head1 DESCRIPTION
491              
492             =cut