1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
########################################################################
# housekeeping
########################################################################
package FindBin::Parents v0.1.0;
use v5.40;
use parent qw( Exporter );
use Carp qw( croak );
use List::Util qw( reduce );
use Storable qw( dclone );
use File::Spec::Functions
qw
(
splitpath
splitdir
catdir
catpath
rel2abs
canonpath
);
########################################################################
# package variables and sanity checks
########################################################################
our @EXPORT_OK
= qw
(
dir_paths
clear_parent_cache
);
my %path2dirz = ();
########################################################################
# utility subs
########################################################################
########################################################################
# exported
########################################################################
# avoid issues with repeated use on different paths.
sub clear_parent_cache()
{
%path2dirz = ();
}
sub dir_paths( $path, $assume_dir = 1 )
{
$path
or croak 'Bogus dir_paths: false path argument.';
my $dirz
= $path2dirz{ $path . $; . $assume_dir }
||= do
{
# treat non-existant paths as dir's, mainly for testing.
my $is_dir = $assume_dir || -d $path;
my ( $vol, $dir ) = splitpath $path, $is_dir;
# ditch the starting directory.
my @dirz = splitdir rel2abs canonpath $dir;
# fix for File::Spec::VMS missing the leading empty
# string on a split. this can be removed once File::Spec
# is fixed -- which appears to be never.
my $tmp
= $dirz[0]
? ''
: shift @dirz
;
[
reverse
map
{
catpath $vol => $_, ''
}
map
{
$tmp = catdir $tmp, $_
}
( '' => @dirz )
]
};
wantarray
? @$dirz
: [ @$dirz ]
}
1
__END__
=head1 NAME
FindBin::Parents - List parent dirs of the given path from curr to root.
=head1 SYNOPSIS
use FindBin::Parents qw( dir_paths );
# on *NIX (incl. OSX)
# '/foo/bar/bim/bam' yields
# /foo/bar/bim/bam
# /foo/bar/bim
# /foo/bar
# /foo
#
# on VMS
# 'Bletch$Blort:[foo.bar.bim.bam]' yields
# Bletch$Blort:[foo.bar.bim.bam]
# Bletch$Blort:[foo.bar.bim]
# Bletch$Blort:[foo.bar]
# Bletch$Blort:[foo]
#
# on MSW
# 'z:/foo/bar/bim/bam' yields
# z:/foo/bar/bim/bam
# z:/foo/bar/bim
# z:/foo/bar
# z:/foo
#
# $path is first passed through rel2abs and canonpath
# which should yield clean, absolute paths.
#
# note that the return vlaue is context-sensitive:
my $array_ref = dir_paths $path;
my @array = dir_paths $path;
# for any non-directory /foo/bar/bletch/blort, the final
# 'blort' is dropped and the paths leading to it are returned:
dir_paths $0;
# /foo/bar/bletch # parent dir of blort
# /foo/bar
# /foo
# Note: non-existant paths are processed, but may require
# an extra assume-dir argument to treat the argument as a
# directory (or not, no way to tell unless it exists, eh?).
#
# the default is true, these are equivalent:
my @found
= dir_paths '/foo/bar/bletch/blort/non-existent';
my @found
= dir_paths '/foo/bar/bletch/blort/non-existent', 1;
# /foo/bar/bletch/blort/non-existant
# /foo/bar/bletch/blort
# /foo/bar/bletch
# /foo/bar/bletch
# /foo/bar
# /foo
# false value drops the last entry:
my @found
= dir_paths '/foo/bar/bletch/blort/non-existant', 0;
# /foo/bar/bletch/blort
# /foo/bar/bletch
# /foo/bar/bletch
# /foo/bar
# /foo
|
