Profile of File/Path.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/File/Path.pm
Statements | Executed 30 statements in 2.08ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 946µs | 1.03ms | File::Path::::BEGIN@7File::Path::BEGIN@7
1 | 1 | 1 | 12µs | 12µs | File::Path::::BEGIN@27File::Path::BEGIN@27
1 | 1 | 1 | 10µs | 10µs | File::Path::::BEGIN@3File::Path::BEGIN@3
1 | 1 | 1 | 5µs | 29µs | File::Path::::BEGIN@6File::Path::BEGIN@6
1 | 1 | 1 | 4µs | 8µs | File::Path::::BEGIN@29File::Path::BEGIN@29
1 | 1 | 1 | 4µs | 5µs | File::Path::::BEGIN@4File::Path::BEGIN@4
1 | 1 | 1 | 4µs | 31µs | File::Path::::BEGIN@20File::Path::BEGIN@20
1 | 1 | 1 | 2µs | 2µs | File::Path::::BEGIN@8File::Path::BEGIN@8
1 | 1 | 1 | 2µs | 2µs | File::Path::::BEGIN@10File::Path::BEGIN@10
1 | 1 | 1 | 1µs | 1µs | File::Path::::BEGIN@19File::Path::BEGIN@19
1 | 1 | 1 | 400ns | 400ns | File::Path::::__ANON__File::Path::__ANON__ (xsub)
0 | 0 | 0 | 0s | 0s | File::Path::::__is_argFile::Path::__is_arg
0 | 0 | 0 | 0s | 0s | File::Path::::_carpFile::Path::_carp
0 | 0 | 0 | 0s | 0s | File::Path::::_croakFile::Path::_croak
0 | 0 | 0 | 0s | 0s | File::Path::::_errorFile::Path::_error
0 | 0 | 0 | 0s | 0s | File::Path::::_is_subdirFile::Path::_is_subdir
0 | 0 | 0 | 0s | 0s | File::Path::::_mkpathFile::Path::_mkpath
0 | 0 | 0 | 0s | 0s | File::Path::::_rmtreeFile::Path::_rmtree
0 | 0 | 0 | 0s | 0s | File::Path::::_slash_lcFile::Path::_slash_lc
0 | 0 | 0 | 0s | 0s | File::Path::::make_pathFile::Path::make_path
0 | 0 | 0 | 0s | 0s | File::Path::::mkpathFile::Path::mkpath
0 | 0 | 0 | 0s | 0s | File::Path::::remove_treeFile::Path::remove_tree
0 | 0 | 0 | 0s | 0s | File::Path::::rmtreeFile::Path::rmtree

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package File::Path;
2 |  |  |  |  |
3 | 2 | 33µs | 1 | 10µs | # spent 10µs within File::Path::BEGIN@3 which was called: # once (10µs+0s) by File::Temp::BEGIN@149 at line 3 use 5.005_04; # spent 10µs making 1 call to File::Path::BEGIN@3
4 | 2 | 15µs | 2 | 7µs | # spent 5µs (4+1) within File::Path::BEGIN@4 which was called: # once (4µs+1µs) by File::Temp::BEGIN@149 at line 4 use strict; # spent 5µs making 1 call to File::Path::BEGIN@4 # spent 1µs making 1 call to strict::import
5 |  |  |  |  |
6 | 2 | 14µs | 2 | 53µs | # spent 29µs (5+24) within File::Path::BEGIN@6 which was called: # once (5µs+24µs) by File::Temp::BEGIN@149 at line 6 use Cwd 'getcwd'; # spent 29µs making 1 call to File::Path::BEGIN@6 # spent 24µs making 1 call to Exporter::import
7 | 2 | 112µs | 1 | 1.03ms | # spent 1.03ms (946µs+84µs) within File::Path::BEGIN@7 which was called: # once (946µs+84µs) by File::Temp::BEGIN@149 at line 7 use File::Basename (); # spent 1.03ms making 1 call to File::Path::BEGIN@7
8 | 2 | 22µs | 1 | 2µs | # spent 2µs within File::Path::BEGIN@8 which was called: # once (2µs+0s) by File::Temp::BEGIN@149 at line 8 use File::Spec (); # spent 2µs making 1 call to File::Path::BEGIN@8
9 |  |  |  |  |
10 |  |  |  |  | # spent 2µs within File::Path::BEGIN@10 which was called: # once (2µs+0s) by File::Temp::BEGIN@149 at line 17 BEGIN {
11 | 1 | 2µs |  |  | if ( $] < 5.006 ) {
12 |  |  |  |  |
13 |  |  |  |  | # can't say 'opendir my $dh, $dirname'
14 |  |  |  |  | # need to initialise $dh
15 |  |  |  |  | eval 'use Symbol';
16 |  |  |  |  | }
17 | 1 | 9µs | 1 | 2µs | } # spent 2µs making 1 call to File::Path::BEGIN@10
18 |  |  |  |  |
19 | 2 | 12µs | 1 | 1µs | # spent 1µs within File::Path::BEGIN@19 which was called: # once (1µs+0s) by File::Temp::BEGIN@149 at line 19 use Exporter (); # spent 1µs making 1 call to File::Path::BEGIN@19
20 | 2 | 34µs | 2 | 58µs | # spent 31µs (4+27) within File::Path::BEGIN@20 which was called: # once (4µs+27µs) by File::Temp::BEGIN@149 at line 20 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); # spent 31µs making 1 call to File::Path::BEGIN@20 # spent 27µs making 1 call to vars::import
21 | 1 | 400ns |  |  | $VERSION = '2.18';
22 | 1 | 11µs |  |  | $VERSION = eval $VERSION; # spent 2µs executing statements in string eval
23 | 1 | 5µs |  |  | @ISA = qw(Exporter);
24 | 1 | 500ns |  |  | @EXPORT = qw(mkpath rmtree);
25 | 1 | 200ns |  |  | @EXPORT_OK = qw(make_path remove_tree);
26 |  |  |  |  |
27 |  |  |  |  | # spent 12µs (12+400ns) within File::Path::BEGIN@27 which was called: # once (12µs+400ns) by File::Temp::BEGIN@149 at line 42 BEGIN {
28 | 1 | 300ns |  |  | for (qw(VMS MacOS MSWin32 os2)) {
29 | 2 | 80µs | 2 | 12µs | # spent 8µs (4+4) within File::Path::BEGIN@29 which was called: # once (4µs+4µs) by File::Temp::BEGIN@149 at line 29 no strict 'refs'; # spent 8µs making 1 call to File::Path::BEGIN@29 # spent 4µs making 1 call to strict::unimport
30 | 4 | 5µs |  |  | *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
31 |  |  |  |  | }
32 |  |  |  |  |
33 |  |  |  |  | # These OSes complain if you want to remove a file that you have no
34 |  |  |  |  | # write permission to:
35 |  |  |  |  | *_FORCE_WRITABLE = (
36 |  |  |  |  | grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
37 | 1 | 1µs |  |  | ) ? sub () { 1 } : sub () { 0 };
38 |  |  |  |  |
39 |  |  |  |  | # Unix-like systems need to stat each directory in order to detect
40 |  |  |  |  | # race condition. MS-Windows is immune to this particular attack.
41 | 1 | 5µs | 1 | 400ns | *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 }; # spent 400ns making 1 call to File::Path::__ANON__
42 | 1 | 1.71ms | 1 | 12µs | } # spent 12µs making 1 call to File::Path::BEGIN@27
43 |  |  |  |  |
44 |  |  |  |  | sub _carp {
45 |  |  |  |  | require Carp;
46 |  |  |  |  | goto &Carp::carp;
47 |  |  |  |  | }
48 |  |  |  |  |
49 |  |  |  |  | sub _croak {
50 |  |  |  |  | require Carp;
51 |  |  |  |  | goto &Carp::croak;
52 |  |  |  |  | }
53 |  |  |  |  |
54 |  |  |  |  | sub _error {
55 |  |  |  |  | my $arg = shift;
56 |  |  |  |  | my $message = shift;
57 |  |  |  |  | my $object = shift;
58 |  |  |  |  |
59 |  |  |  |  | if ( $arg->{error} ) {
60 |  |  |  |  | $object = '' unless defined $object;
61 |  |  |  |  | $message .= ": $!" if $!;
62 |  |  |  |  | push @{ ${ $arg->{error} } }, { $object => $message };
63 |  |  |  |  | }
64 |  |  |  |  | else {
65 |  |  |  |  | _carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
66 |  |  |  |  | }
67 |  |  |  |  | }
68 |  |  |  |  |
69 |  |  |  |  | sub __is_arg {
70 |  |  |  |  | my ($arg) = @_;
71 |  |  |  |  |
72 |  |  |  |  | # If client code blessed an array ref to HASH, this will not work
73 |  |  |  |  | # properly. We could have done $arg->isa() wrapped in eval, but
74 |  |  |  |  | # that would be expensive. This implementation should suffice.
75 |  |  |  |  | # We could have also used Scalar::Util:blessed, but we choose not
76 |  |  |  |  | # to add this dependency
77 |  |  |  |  | return ( ref $arg eq 'HASH' );
78 |  |  |  |  | }
79 |  |  |  |  |
80 |  |  |  |  | sub make_path {
81 |  |  |  |  | push @_, {} unless @_ and __is_arg( $_[-1] );
82 |  |  |  |  | goto &mkpath;
83 |  |  |  |  | }
84 |  |  |  |  |
85 |  |  |  |  | sub mkpath {
86 |  |  |  |  | my $old_style = !( @_ and __is_arg( $_[-1] ) );
87 |  |  |  |  |
88 |  |  |  |  | my $data;
89 |  |  |  |  | my $paths;
90 |  |  |  |  |
91 |  |  |  |  | if ($old_style) {
92 |  |  |  |  | my ( $verbose, $mode );
93 |  |  |  |  | ( $paths, $verbose, $mode ) = @_;
94 |  |  |  |  | $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
95 |  |  |  |  | $data->{verbose} = $verbose;
96 |  |  |  |  | $data->{mode} = defined $mode ? $mode : oct '777';
97 |  |  |  |  | }
98 |  |  |  |  | else {
99 |  |  |  |  | my %args_permitted = map { $_ => 1 } ( qw|
100 |  |  |  |  | chmod
101 |  |  |  |  | error
102 |  |  |  |  | group
103 |  |  |  |  | mask
104 |  |  |  |  | mode
105 |  |  |  |  | owner
106 |  |  |  |  | uid
107 |  |  |  |  | user
108 |  |  |  |  | verbose
109 |  |  |  |  | | );
110 |  |  |  |  | my %not_on_win32_args = map { $_ => 1 } ( qw|
111 |  |  |  |  | group
112 |  |  |  |  | owner
113 |  |  |  |  | uid
114 |  |  |  |  | user
115 |  |  |  |  | | );
116 |  |  |  |  | my @bad_args = ();
117 |  |  |  |  | my @win32_implausible_args = ();
118 |  |  |  |  | my $arg = pop @_;
119 |  |  |  |  | for my $k (sort keys %{$arg}) {
120 |  |  |  |  | if (! $args_permitted{$k}) {
121 |  |  |  |  | push @bad_args, $k;
122 |  |  |  |  | }
123 |  |  |  |  | elsif ($not_on_win32_args{$k} and _IS_MSWIN32) {
124 |  |  |  |  | push @win32_implausible_args, $k;
125 |  |  |  |  | }
126 |  |  |  |  | else {
127 |  |  |  |  | $data->{$k} = $arg->{$k};
128 |  |  |  |  | }
129 |  |  |  |  | }
130 |  |  |  |  | _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args")
131 |  |  |  |  | if @bad_args;
132 |  |  |  |  | _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args")
133 |  |  |  |  | if @win32_implausible_args;
134 |  |  |  |  | $data->{mode} = delete $data->{mask} if exists $data->{mask};
135 |  |  |  |  | $data->{mode} = oct '777' unless exists $data->{mode};
136 |  |  |  |  | ${ $data->{error} } = [] if exists $data->{error};
137 |  |  |  |  | unless (@win32_implausible_args) {
138 |  |  |  |  | $data->{owner} = delete $data->{user} if exists $data->{user};
139 |  |  |  |  | $data->{owner} = delete $data->{uid} if exists $data->{uid};
140 |  |  |  |  | if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) {
141 |  |  |  |  | my $uid = ( getpwnam $data->{owner} )[2];
142 |  |  |  |  | if ( defined $uid ) {
143 |  |  |  |  | $data->{owner} = $uid;
144 |  |  |  |  | }
145 |  |  |  |  | else {
146 |  |  |  |  | _error( $data,
147 |  |  |  |  | "unable to map $data->{owner} to a uid, ownership not changed"
148 |  |  |  |  | );
149 |  |  |  |  | delete $data->{owner};
150 |  |  |  |  | }
151 |  |  |  |  | }
152 |  |  |  |  | if ( exists $data->{group} and $data->{group} =~ /\D/ ) {
153 |  |  |  |  | my $gid = ( getgrnam $data->{group} )[2];
154 |  |  |  |  | if ( defined $gid ) {
155 |  |  |  |  | $data->{group} = $gid;
156 |  |  |  |  | }
157 |  |  |  |  | else {
158 |  |  |  |  | _error( $data,
159 |  |  |  |  | "unable to map $data->{group} to a gid, group ownership not changed"
160 |  |  |  |  | );
161 |  |  |  |  | delete $data->{group};
162 |  |  |  |  | }
163 |  |  |  |  | }
164 |  |  |  |  | if ( exists $data->{owner} and not exists $data->{group} ) {
165 |  |  |  |  | $data->{group} = -1; # chown will leave group unchanged
166 |  |  |  |  | }
167 |  |  |  |  | if ( exists $data->{group} and not exists $data->{owner} ) {
168 |  |  |  |  | $data->{owner} = -1; # chown will leave owner unchanged
169 |  |  |  |  | }
170 |  |  |  |  | }
171 |  |  |  |  | $paths = [@_];
172 |  |  |  |  | }
173 |  |  |  |  | return _mkpath( $data, $paths );
174 |  |  |  |  | }
175 |  |  |  |  |
176 |  |  |  |  | sub _mkpath {
177 |  |  |  |  | my $data = shift;
178 |  |  |  |  | my $paths = shift;
179 |  |  |  |  |
180 |  |  |  |  | my ( @created );
181 |  |  |  |  | foreach my $path ( @{$paths} ) {
182 |  |  |  |  | next unless defined($path) and length($path);
183 |  |  |  |  | $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT
184 |  |  |  |  |
185 |  |  |  |  | # Logic wants Unix paths, so go with the flow.
186 |  |  |  |  | if (_IS_VMS) {
187 |  |  |  |  | next if $path eq '/';
188 |  |  |  |  | $path = VMS::Filespec::unixify($path);
189 |  |  |  |  | }
190 |  |  |  |  | next if -d $path;
191 |  |  |  |  | my $parent = File::Basename::dirname($path);
192 |  |  |  |  | # Coverage note: It's not clear how we would test the condition:
193 |  |  |  |  | # '-d $parent or $path eq $parent'
194 |  |  |  |  | unless ( -d $parent or $path eq $parent ) {
195 |  |  |  |  | push( @created, _mkpath( $data, [$parent] ) );
196 |  |  |  |  | }
197 |  |  |  |  | print "mkdir $path\n" if $data->{verbose};
198 |  |  |  |  | if ( mkdir( $path, $data->{mode} ) ) {
199 |  |  |  |  | push( @created, $path );
200 |  |  |  |  | if ( exists $data->{owner} ) {
201 |  |  |  |  |
202 |  |  |  |  | # NB: $data->{group} guaranteed to be set during initialisation
203 |  |  |  |  | if ( !chown $data->{owner}, $data->{group}, $path ) {
204 |  |  |  |  | _error( $data,
205 |  |  |  |  | "Cannot change ownership of $path to $data->{owner}:$data->{group}"
206 |  |  |  |  | );
207 |  |  |  |  | }
208 |  |  |  |  | }
209 |  |  |  |  | if ( exists $data->{chmod} ) {
210 |  |  |  |  | # Coverage note: It's not clear how we would trigger the next
211 |  |  |  |  | # 'if' block. Failure of 'chmod' might first result in a
212 |  |  |  |  | # system error: "Permission denied".
213 |  |  |  |  | if ( !chmod $data->{chmod}, $path ) {
214 |  |  |  |  | _error( $data,
215 |  |  |  |  | "Cannot change permissions of $path to $data->{chmod}" );
216 |  |  |  |  | }
217 |  |  |  |  | }
218 |  |  |  |  | }
219 |  |  |  |  | else {
220 |  |  |  |  | my $save_bang = $!;
221 |  |  |  |  |
222 |  |  |  |  | # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented
223 |  |  |  |  | # as:
224 |  |  |  |  | # Error information specific to the current operating system. At the
225 |  |  |  |  | # moment, this differs from "$!" under only VMS, OS/2, and Win32
226 |  |  |  |  | # (and for MacPerl). On all other platforms, $^E is always just the
227 |  |  |  |  | # same as $!.
228 |  |  |  |  |
229 |  |  |  |  | my ( $e, $e1 ) = ( $save_bang, $^E );
230 |  |  |  |  | $e .= "; $e1" if $e ne $e1;
231 |  |  |  |  |
232 |  |  |  |  | # allow for another process to have created it meanwhile
233 |  |  |  |  | if ( ! -d $path ) {
234 |  |  |  |  | $! = $save_bang;
235 |  |  |  |  | if ( $data->{error} ) {
236 |  |  |  |  | push @{ ${ $data->{error} } }, { $path => $e };
237 |  |  |  |  | }
238 |  |  |  |  | else {
239 |  |  |  |  | _croak("mkdir $path: $e");
240 |  |  |  |  | }
241 |  |  |  |  | }
242 |  |  |  |  | }
243 |  |  |  |  | }
244 |  |  |  |  | return @created;
245 |  |  |  |  | }
246 |  |  |  |  |
247 |  |  |  |  | sub remove_tree {
248 |  |  |  |  | push @_, {} unless @_ and __is_arg( $_[-1] );
249 |  |  |  |  | goto &rmtree;
250 |  |  |  |  | }
251 |  |  |  |  |
252 |  |  |  |  | sub _is_subdir {
253 |  |  |  |  | my ( $dir, $test ) = @_;
254 |  |  |  |  |
255 |  |  |  |  | my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 );
256 |  |  |  |  | my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
257 |  |  |  |  |
258 |  |  |  |  | # not on same volume
259 |  |  |  |  | return 0 if $dv ne $tv;
260 |  |  |  |  |
261 |  |  |  |  | my @d = File::Spec->splitdir($dd);
262 |  |  |  |  | my @t = File::Spec->splitdir($td);
263 |  |  |  |  |
264 |  |  |  |  | # @t can't be a subdir if it's shorter than @d
265 |  |  |  |  | return 0 if @t < @d;
266 |  |  |  |  |
267 |  |  |  |  | return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
268 |  |  |  |  | }
269 |  |  |  |  |
270 |  |  |  |  | sub rmtree {
271 |  |  |  |  | my $old_style = !( @_ and __is_arg( $_[-1] ) );
272 |  |  |  |  |
273 |  |  |  |  | my ($arg, $data, $paths);
274 |  |  |  |  |
275 |  |  |  |  | if ($old_style) {
276 |  |  |  |  | my ( $verbose, $safe );
277 |  |  |  |  | ( $paths, $verbose, $safe ) = @_;
278 |  |  |  |  | $data->{verbose} = $verbose;
279 |  |  |  |  | $data->{safe} = defined $safe ? $safe : 0;
280 |  |  |  |  |
281 |  |  |  |  | if ( defined($paths) and length($paths) ) {
282 |  |  |  |  | $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
283 |  |  |  |  | }
284 |  |  |  |  | else {
285 |  |  |  |  | _carp("No root path(s) specified\n");
286 |  |  |  |  | return 0;
287 |  |  |  |  | }
288 |  |  |  |  | }
289 |  |  |  |  | else {
290 |  |  |  |  | my %args_permitted = map { $_ => 1 } ( qw|
291 |  |  |  |  | error
292 |  |  |  |  | keep_root
293 |  |  |  |  | result
294 |  |  |  |  | safe
295 |  |  |  |  | verbose
296 |  |  |  |  | | );
297 |  |  |  |  | my @bad_args = ();
298 |  |  |  |  | my $arg = pop @_;
299 |  |  |  |  | for my $k (sort keys %{$arg}) {
300 |  |  |  |  | if (! $args_permitted{$k}) {
301 |  |  |  |  | push @bad_args, $k;
302 |  |  |  |  | }
303 |  |  |  |  | else {
304 |  |  |  |  | $data->{$k} = $arg->{$k};
305 |  |  |  |  | }
306 |  |  |  |  | }
307 |  |  |  |  | _carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
308 |  |  |  |  | if @bad_args;
309 |  |  |  |  | ${ $data->{error} } = [] if exists $data->{error};
310 |  |  |  |  | ${ $data->{result} } = [] if exists $data->{result};
311 |  |  |  |  |
312 |  |  |  |  | # Wouldn't it make sense to do some validation on @_ before assigning
313 |  |  |  |  | # to $paths here?
314 |  |  |  |  | # In the $old_style case we guarantee that each path is both defined
315 |  |  |  |  | # and non-empty. We don't check that here, which means we have to
316 |  |  |  |  | # check it later in the first condition in this line:
317 |  |  |  |  | # if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
318 |  |  |  |  | # Granted, that would be a change in behavior for the two
319 |  |  |  |  | # non-old-style interfaces.
320 |  |  |  |  |
321 |  |  |  |  | $paths = [@_];
322 |  |  |  |  | }
323 |  |  |  |  |
324 |  |  |  |  | $data->{prefix} = '';
325 |  |  |  |  | $data->{depth} = 0;
326 |  |  |  |  |
327 |  |  |  |  | my @clean_path;
328 |  |  |  |  | $data->{cwd} = getcwd() or do {
329 |  |  |  |  | _error( $data, "cannot fetch initial working directory" );
330 |  |  |  |  | return 0;
331 |  |  |  |  | };
332 |  |  |  |  | for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
333 |  |  |  |  |
334 |  |  |  |  | for my $p (@$paths) {
335 |  |  |  |  |
336 |  |  |  |  | # need to fixup case and map \ to / on Windows
337 |  |  |  |  | my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
338 |  |  |  |  | my $ortho_cwd =
339 |  |  |  |  | _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
340 |  |  |  |  | my $ortho_root_length = length($ortho_root);
341 |  |  |  |  | $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
342 |  |  |  |  | if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
343 |  |  |  |  | local $! = 0;
344 |  |  |  |  | _error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
345 |  |  |  |  | next;
346 |  |  |  |  | }
347 |  |  |  |  |
348 |  |  |  |  | if (_IS_MACOS) {
349 |  |  |  |  | $p = ":$p" unless $p =~ /:/;
350 |  |  |  |  | $p .= ":" unless $p =~ /:\z/;
351 |  |  |  |  | }
352 |  |  |  |  | elsif ( _IS_MSWIN32 ) {
353 |  |  |  |  | $p =~ s{[/\\]\z}{};
354 |  |  |  |  | }
355 |  |  |  |  | else {
356 |  |  |  |  | $p =~ s{/\z}{};
357 |  |  |  |  | }
358 |  |  |  |  | push @clean_path, $p;
359 |  |  |  |  | }
360 |  |  |  |  |
361 |  |  |  |  | @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
362 |  |  |  |  | _error( $data, "cannot stat initial working directory", $data->{cwd} );
363 |  |  |  |  | return 0;
364 |  |  |  |  | };
365 |  |  |  |  |
366 |  |  |  |  | return _rmtree( $data, \@clean_path );
367 |  |  |  |  | }
368 |  |  |  |  |
369 |  |  |  |  | sub _rmtree {
370 |  |  |  |  | my $data = shift;
371 |  |  |  |  | my $paths = shift;
372 |  |  |  |  |
373 |  |  |  |  | my $count = 0;
374 |  |  |  |  | my $curdir = File::Spec->curdir();
375 |  |  |  |  | my $updir = File::Spec->updir();
376 |  |  |  |  |
377 |  |  |  |  | my ( @files, $root );
378 |  |  |  |  | ROOT_DIR:
379 |  |  |  |  | foreach my $root (@$paths) {
380 |  |  |  |  |
381 |  |  |  |  | # since we chdir into each directory, it may not be obvious
382 |  |  |  |  | # to figure out where we are if we generate a message about
383 |  |  |  |  | # a file name. We therefore construct a semi-canonical
384 |  |  |  |  | # filename, anchored from the directory being unlinked (as
385 |  |  |  |  | # opposed to being truly canonical, anchored from the root (/).
386 |  |  |  |  |
387 |  |  |  |  | my $canon =
388 |  |  |  |  | $data->{prefix}
389 |  |  |  |  | ? File::Spec->catfile( $data->{prefix}, $root )
390 |  |  |  |  | : $root;
391 |  |  |  |  |
392 |  |  |  |  | my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
393 |  |  |  |  | or next ROOT_DIR;
394 |  |  |  |  |
395 |  |  |  |  | if ( -d _ ) {
396 |  |  |  |  | $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
397 |  |  |  |  | if _IS_VMS;
398 |  |  |  |  |
399 |  |  |  |  | if ( !chdir($root) ) {
400 |  |  |  |  |
401 |  |  |  |  | # see if we can escalate privileges to get in
402 |  |  |  |  | # (e.g. funny protection mask such as -w- instead of rwx)
403 |  |  |  |  | # This uses fchmod to avoid traversing outside of the proper
404 |  |  |  |  | # location (CVE-2017-6512)
405 |  |  |  |  | my $root_fh;
406 |  |  |  |  | if (open($root_fh, '<', $root)) {
407 |  |  |  |  | my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
408 |  |  |  |  | $perm &= oct '7777';
409 |  |  |  |  | my $nperm = $perm | oct '700';
410 |  |  |  |  | local $@;
411 |  |  |  |  | if (
412 |  |  |  |  | !(
413 |  |  |  |  | $data->{safe}
414 |  |  |  |  | or $nperm == $perm
415 |  |  |  |  | or !-d _
416 |  |  |  |  | or $fh_dev ne $ldev
417 |  |  |  |  | or $fh_inode ne $lino
418 |  |  |  |  | or eval { chmod( $nperm, $root_fh ) }
419 |  |  |  |  | )
420 |  |  |  |  | )
421 |  |  |  |  | {
422 |  |  |  |  | _error( $data,
423 |  |  |  |  | "cannot make child directory read-write-exec", $canon );
424 |  |  |  |  | next ROOT_DIR;
425 |  |  |  |  | }
426 |  |  |  |  | close $root_fh;
427 |  |  |  |  | }
428 |  |  |  |  | if ( !chdir($root) ) {
429 |  |  |  |  | _error( $data, "cannot chdir to child", $canon );
430 |  |  |  |  | next ROOT_DIR;
431 |  |  |  |  | }
432 |  |  |  |  | }
433 |  |  |  |  |
434 |  |  |  |  | my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
435 |  |  |  |  | or do {
436 |  |  |  |  | _error( $data, "cannot stat current working directory", $canon );
437 |  |  |  |  | next ROOT_DIR;
438 |  |  |  |  | };
439 |  |  |  |  |
440 |  |  |  |  | if (_NEED_STAT_CHECK) {
441 |  |  |  |  | ( $ldev eq $cur_dev and $lino eq $cur_inode )
442 |  |  |  |  | or _croak(
443 |  |  |  |  | "directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
444 |  |  |  |  | );
445 |  |  |  |  | }
446 |  |  |  |  |
447 |  |  |  |  | $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits
448 |  |  |  |  | my $nperm = $perm | oct '700';
449 |  |  |  |  |
450 |  |  |  |  | # notabene: 0700 is for making readable in the first place,
451 |  |  |  |  | # it's also intended to change it to writable in case we have
452 |  |  |  |  | # to recurse in which case we are better than rm -rf for
453 |  |  |  |  | # subtrees with strange permissions
454 |  |  |  |  |
455 |  |  |  |  | if (
456 |  |  |  |  | !(
457 |  |  |  |  | $data->{safe}
458 |  |  |  |  | or $nperm == $perm
459 |  |  |  |  | or chmod( $nperm, $curdir )
460 |  |  |  |  | )
461 |  |  |  |  | )
462 |  |  |  |  | {
463 |  |  |  |  | _error( $data, "cannot make directory read+writeable", $canon );
464 |  |  |  |  | $nperm = $perm;
465 |  |  |  |  | }
466 |  |  |  |  |
467 |  |  |  |  | my $d;
468 |  |  |  |  | $d = gensym() if $] < 5.006;
469 |  |  |  |  | if ( !opendir $d, $curdir ) {
470 |  |  |  |  | _error( $data, "cannot opendir", $canon );
471 |  |  |  |  | @files = ();
472 |  |  |  |  | }
473 |  |  |  |  | else {
474 |  |  |  |  | if ( !defined ${^TAINT} or ${^TAINT} ) {
475 |  |  |  |  | # Blindly untaint dir names if taint mode is active
476 |  |  |  |  | @files = map { /\A(.*)\z/s; $1 } readdir $d;
477 |  |  |  |  | }
478 |  |  |  |  | else {
479 |  |  |  |  | @files = readdir $d;
480 |  |  |  |  | }
481 |  |  |  |  | closedir $d;
482 |  |  |  |  | }
483 |  |  |  |  |
484 |  |  |  |  | if (_IS_VMS) {
485 |  |  |  |  |
486 |  |  |  |  | # Deleting large numbers of files from VMS Files-11
487 |  |  |  |  | # filesystems is faster if done in reverse ASCIIbetical order.
488 |  |  |  |  | # include '.' to '.;' from blead patch #31775
489 |  |  |  |  | @files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
490 |  |  |  |  | }
491 |  |  |  |  |
492 |  |  |  |  | @files = grep { $_ ne $updir and $_ ne $curdir } @files;
493 |  |  |  |  |
494 |  |  |  |  | if (@files) {
495 |  |  |  |  |
496 |  |  |  |  | # remove the contained files before the directory itself
497 |  |  |  |  | my $narg = {%$data};
498 |  |  |  |  | @{$narg}{qw(device inode cwd prefix depth)} =
499 |  |  |  |  | ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
500 |  |  |  |  | $count += _rmtree( $narg, \@files );
501 |  |  |  |  | }
502 |  |  |  |  |
503 |  |  |  |  | # restore directory permissions of required now (in case the rmdir
504 |  |  |  |  | # below fails), while we are still in the directory and may do so
505 |  |  |  |  | # without a race via '.'
506 |  |  |  |  | if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
507 |  |  |  |  | _error( $data, "cannot reset chmod", $canon );
508 |  |  |  |  | }
509 |  |  |  |  |
510 |  |  |  |  | # don't leave the client code in an unexpected directory
511 |  |  |  |  | chdir( $data->{cwd} )
512 |  |  |  |  | or
513 |  |  |  |  | _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting.");
514 |  |  |  |  |
515 |  |  |  |  | # ensure that a chdir upwards didn't take us somewhere other
516 |  |  |  |  | # than we expected (see CVE-2002-0435)
517 |  |  |  |  | ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
518 |  |  |  |  | or _croak(
519 |  |  |  |  | "cannot stat prior working directory $data->{cwd}: $!, aborting."
520 |  |  |  |  | );
521 |  |  |  |  |
522 |  |  |  |  | if (_NEED_STAT_CHECK) {
523 |  |  |  |  | ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode )
524 |  |  |  |  | or _croak( "previous directory $data->{cwd} "
525 |  |  |  |  | . "changed before entering $canon, "
526 |  |  |  |  | . "expected dev=$ldev ino=$lino, "
527 |  |  |  |  | . "actual dev=$cur_dev ino=$cur_inode, aborting."
528 |  |  |  |  | );
529 |  |  |  |  | }
530 |  |  |  |  |
531 |  |  |  |  | if ( $data->{depth} or !$data->{keep_root} ) {
532 |  |  |  |  | if ( $data->{safe}
533 |  |  |  |  | && ( _IS_VMS
534 |  |  |  |  | ? !&VMS::Filespec::candelete($root)
535 |  |  |  |  | : !-w $root ) )
536 |  |  |  |  | {
537 |  |  |  |  | print "skipped $root\n" if $data->{verbose};
538 |  |  |  |  | next ROOT_DIR;
539 |  |  |  |  | }
540 |  |  |  |  | if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
541 |  |  |  |  | _error( $data, "cannot make directory writeable", $canon );
542 |  |  |  |  | }
543 |  |  |  |  | print "rmdir $root\n" if $data->{verbose};
544 |  |  |  |  | if ( rmdir $root ) {
545 |  |  |  |  | push @{ ${ $data->{result} } }, $root if $data->{result};
546 |  |  |  |  | ++$count;
547 |  |  |  |  | }
548 |  |  |  |  | else {
549 |  |  |  |  | _error( $data, "cannot remove directory", $canon );
550 |  |  |  |  | if (
551 |  |  |  |  | _FORCE_WRITABLE
552 |  |  |  |  | && !chmod( $perm,
553 |  |  |  |  | ( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
554 |  |  |  |  | )
555 |  |  |  |  | )
556 |  |  |  |  | {
557 |  |  |  |  | _error(
558 |  |  |  |  | $data,
559 |  |  |  |  | sprintf( "cannot restore permissions to 0%o",
560 |  |  |  |  | $perm ),
561 |  |  |  |  | $canon
562 |  |  |  |  | );
563 |  |  |  |  | }
564 |  |  |  |  | }
565 |  |  |  |  | }
566 |  |  |  |  | }
567 |  |  |  |  | else {
568 |  |  |  |  | # not a directory
569 |  |  |  |  | $root = VMS::Filespec::vmsify("./$root")
570 |  |  |  |  | if _IS_VMS
571 |  |  |  |  | && !File::Spec->file_name_is_absolute($root)
572 |  |  |  |  | && ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax
573 |  |  |  |  |
574 |  |  |  |  | if (
575 |  |  |  |  | $data->{safe}
576 |  |  |  |  | && (
577 |  |  |  |  | _IS_VMS
578 |  |  |  |  | ? !&VMS::Filespec::candelete($root)
579 |  |  |  |  | : !( -l $root || -w $root )
580 |  |  |  |  | )
581 |  |  |  |  | )
582 |  |  |  |  | {
583 |  |  |  |  | print "skipped $root\n" if $data->{verbose};
584 |  |  |  |  | next ROOT_DIR;
585 |  |  |  |  | }
586 |  |  |  |  |
587 |  |  |  |  | my $nperm = $perm & oct '7777' | oct '600';
588 |  |  |  |  | if ( _FORCE_WRITABLE
589 |  |  |  |  | and $nperm != $perm
590 |  |  |  |  | and not chmod $nperm, $root )
591 |  |  |  |  | {
592 |  |  |  |  | _error( $data, "cannot make file writeable", $canon );
593 |  |  |  |  | }
594 |  |  |  |  | print "unlink $canon\n" if $data->{verbose};
595 |  |  |  |  |
596 |  |  |  |  | # delete all versions under VMS
597 |  |  |  |  | for ( ; ; ) {
598 |  |  |  |  | if ( unlink $root ) {
599 |  |  |  |  | push @{ ${ $data->{result} } }, $root if $data->{result};
600 |  |  |  |  | }
601 |  |  |  |  | else {
602 |  |  |  |  | _error( $data, "cannot unlink file", $canon );
603 |  |  |  |  | _FORCE_WRITABLE and chmod( $perm, $root )
604 |  |  |  |  | or _error( $data,
605 |  |  |  |  | sprintf( "cannot restore permissions to 0%o", $perm ),
606 |  |  |  |  | $canon );
607 |  |  |  |  | last;
608 |  |  |  |  | }
609 |  |  |  |  | ++$count;
610 |  |  |  |  | last unless _IS_VMS && lstat $root;
611 |  |  |  |  | }
612 |  |  |  |  | }
613 |  |  |  |  | }
614 |  |  |  |  | return $count;
615 |  |  |  |  | }
616 |  |  |  |  |
617 |  |  |  |  | sub _slash_lc {
618 |  |  |  |  |
619 |  |  |  |  | # fix up slashes and case on MSWin32 so that we can determine that
620 |  |  |  |  | # c:\path\to\dir is underneath C:/Path/To
621 |  |  |  |  | my $path = shift;
622 |  |  |  |  | $path =~ tr{\\}{/};
623 |  |  |  |  | return lc($path);
624 |  |  |  |  | }
625 |  |  |  |  |
626 | 1 | 3µs |  |  | 1;
627 |  |  |  |  |
628 |  |  |  |  | __END__
|  |  |  |  | # spent 400ns within File::Path::__ANON__ which was called: # once (400ns+0s) by File::Path::BEGIN@27 at line 41 sub File::Path::__ANON__; # xsub