File Coverage

blib/lib/Path/ExpandTilde.pm
Criterion Covered Total %
statement 41 41 100.0
branch 9 14 64.2
condition 3 6 50.0
subroutine 10 10 100.0
pod 1 1 100.0
total 64 72 88.8


line stmt bran cond sub pod time code
1             package Path::ExpandTilde;
2              
3 1     1   464 use strict;
  1         8  
  1         28  
4 1     1   5 use warnings;
  1         2  
  1         26  
5 1     1   5 use Carp 'croak';
  1         1  
  1         86  
6 1     1   14 use Exporter;
  1         2  
  1         41  
7 1     1   20 use File::Glob ':glob';
  1         2  
  1         209  
8 1     1   7 use File::Spec;
  1         2  
  1         144  
9              
10             our $VERSION = '0.003';
11              
12             our @ISA = 'Exporter';
13             our @EXPORT = 'expand_tilde';
14              
15 1 50       146 use constant BSD_GLOB_FLAGS => GLOB_NOCHECK | GLOB_QUOTE | GLOB_TILDE | GLOB_ERR
16             # add GLOB_NOCASE as in File::Glob
17 1     1   7 | ($^O =~ m/\A(?:MSWin32|VMS|os2|dos|riscos)\z/ ? GLOB_NOCASE : 0);
  1         2  
18              
19             # File::Glob did not try %USERPROFILE% (set in Windows NT derivatives) for ~ before 5.16
20 1   33 1   7 use constant WINDOWS_USERPROFILE => $^O eq 'MSWin32' && $] < 5.016;
  1         1  
  1         79  
21              
22             # File::Glob does not have bsd_glob on 5.6.0, but its glob was the same then
23 1 50   1   321 BEGIN { *bsd_glob = \&File::Glob::glob if $] == 5.006 }
24              
25             sub expand_tilde {
26 18     18 1 7812 my ($dir) = @_;
27 18 50       49 return undef unless defined $dir;
28 18 100       97 return File::Spec->canonpath($dir) unless $dir =~ m/^~/;
29             # parse path into segments
30 13         91 my ($volume, $directories, $file) = File::Spec->splitpath($dir, 1);
31 13         65 my @parts = File::Spec->splitdir($directories);
32 13         25 my $first = shift @parts;
33 13 50       34 return File::Spec->canonpath($dir) unless defined $first;
34             # expand first segment
35 13         18 my $expanded;
36 13         32 if (WINDOWS_USERPROFILE and $first eq '~') {
37             $expanded = $ENV{HOME} || $ENV{USERPROFILE};
38             } else {
39 13         33 (my $pattern = $first) =~ s/([\\*?{[])/\\$1/g;
40 13         403 ($expanded) = bsd_glob($pattern, BSD_GLOB_FLAGS);
41 13 50       63 croak "Failed to expand $first: $!" if GLOB_ERROR;
42             }
43 13 100 66     79 return File::Spec->canonpath($dir) if !defined $expanded or $expanded eq $first;
44             # replace first segment with new path
45 12         73 ($volume, $directories) = File::Spec->splitpath($expanded, 1);
46 12         82 $directories = File::Spec->catdir($directories, @parts);
47 12         166 return File::Spec->catpath($volume, $directories, $file);
48             }
49              
50             1;
51              
52             =head1 NAME
53              
54             Path::ExpandTilde - Expand tilde (~) to homedir in file paths
55              
56             =head1 SYNOPSIS
57              
58             use Path::ExpandTilde;
59             my $homedir = expand_tilde('~');
60             my $bashrc = expand_tilde('~/.bashrc');
61             my $pg_home = expand_tilde('~postgres');
62              
63             =head1 DESCRIPTION
64              
65             This module uses C from L to portably expand a leading
66             tilde (C<~>) in a file path into the current or specified user's home
67             directory. No other L are
68             expanded.
69              
70             =head1 FUNCTIONS
71              
72             =head2 expand_tilde
73              
74             my $new_path = expand_tilde($path);
75              
76             Exported by default. If the path starts with C<~>, expands that to the current
77             user's home directory. If the path starts with C<< ~I >>, expands
78             that to the specified user's home directory. If the user doesn't exist, no
79             expansion is done. The returned path is canonicalized as by
80             L either way.
81              
82             =head1 NOTES
83              
84             The algorithm should be portable to most operating systems supported by Perl,
85             though the home directory may not be found by C on some.
86              
87             =head1 BUGS
88              
89             Report any issues on the public bugtracker.
90              
91             =head1 AUTHOR
92              
93             Dan Book
94              
95             =head1 COPYRIGHT AND LICENSE
96              
97             This software is Copyright (c) 2018 by Dan Book.
98              
99             This is free software, licensed under:
100              
101             The Artistic License 2.0 (GPL Compatible)
102              
103             =head1 SEE ALSO
104              
105             L, L, L