File Coverage

/usr/share/perl/5.22/File/Basename.pm
Criterion Covered Total %
statement n/a
branch n/a
condition n/a
subroutine n/a
total n/a


line stmt bran cond sub time code
1           package File::Basename;
2            
3           # File::Basename is used during the Perl build, when the re extension may
4           # not be available, but we only actually need it if running under tainting.
5           BEGIN {
6           if (${^TAINT}) {
7           require re;
8           re->import('taint');
9           }
10           }
11            
12           use strict;
13           use 5.006;
14           use warnings;
15           our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
16           require Exporter;
17           @ISA = qw(Exporter);
18           @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
19           $VERSION = "2.85";
20            
21           fileparse_set_fstype($^O);
22            
23           sub fileparse {
24           my($fullname,@suffices) = @_;
25            
26           unless (defined $fullname) {
27           require Carp;
28           Carp::croak("fileparse(): need a valid pathname");
29           }
30            
31           my $orig_type = '';
32           my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
33            
34           my($taint) = substr($fullname,0,0); # Is $fullname tainted?
35            
36           if ($type eq "VMS" and $fullname =~ m{/} ) {
37           # We're doing Unix emulation
38           $orig_type = $type;
39           $type = 'Unix';
40           }
41            
42           my($dirpath, $basename);
43            
44           if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
45           ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
46           $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
47           }
48           elsif ($type eq "OS2") {
49           ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
50           $dirpath = './' unless $dirpath; # Can't be 0
51           $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
52           }
53           elsif ($type eq "MacOS") {
54           ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
55           $dirpath = ':' unless $dirpath;
56           }
57           elsif ($type eq "AmigaOS") {
58           ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
59           $dirpath = './' unless $dirpath;
60           }
61           elsif ($type eq 'VMS' ) {
62           ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
63           $dirpath ||= ''; # should always be defined
64           }
65           else { # Default to Unix semantics.
66           ($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
67           if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
68           # dev:[000000] is top of VMS tree, similar to Unix '/'
69           # so strip it off and treat the rest as "normal"
70           my $devspec = $1;
71           my $remainder = $3;
72           ($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
73           $dirpath ||= ''; # should always be defined
74           $dirpath = $devspec.$dirpath;
75           }
76           $dirpath = './' unless $dirpath;
77           }
78          
79            
80           my $tail = '';
81           my $suffix = '';
82           if (@suffices) {
83           foreach $suffix (@suffices) {
84           my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
85           if ($basename =~ s/$pat//s) {
86           $taint .= substr($suffix,0,0);
87           $tail = $1 . $tail;
88           }
89           }
90           }
91            
92           # Ensure taint is propagated from the path to its pieces.
93           $tail .= $taint;
94           wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
95           : ($basename .= $taint);
96           }
97            
98           sub basename {
99           my($path) = shift;
100            
101           # From BSD basename(1)
102           # The basename utility deletes any prefix ending with the last slash '/'
103           # character present in string (after first stripping trailing slashes)
104           _strip_trailing_sep($path);
105            
106           my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
107            
108           # From BSD basename(1)
109           # The suffix is not stripped if it is identical to the remaining
110           # characters in string.
111           if( length $suffix and !length $basename ) {
112           $basename = $suffix;
113           }
114          
115           # Ensure that basename '/' == '/'
116           if( !length $basename ) {
117           $basename = $dirname;
118           }
119            
120           return $basename;
121           }
122            
123           sub dirname {
124           my $path = shift;
125            
126           my($type) = $Fileparse_fstype;
127            
128           if( $type eq 'VMS' and $path =~ m{/} ) {
129           # Parse as Unix
130           local($File::Basename::Fileparse_fstype) = '';
131           return dirname($path);
132           }
133            
134           my($basename, $dirname) = fileparse($path);
135            
136           if ($type eq 'VMS') {
137           $dirname ||= $ENV{DEFAULT};
138           }
139           elsif ($type eq 'MacOS') {
140           if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
141           _strip_trailing_sep($dirname);
142           ($basename,$dirname) = fileparse $dirname;
143           }
144           $dirname .= ":" unless $dirname =~ /:\z/;
145           }
146           elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
147           _strip_trailing_sep($dirname);
148           unless( length($basename) ) {
149           ($basename,$dirname) = fileparse $dirname;
150           _strip_trailing_sep($dirname);
151           }
152           }
153           elsif ($type eq 'AmigaOS') {
154           if ( $dirname =~ /:\z/) { return $dirname }
155           chop $dirname;
156           $dirname =~ s{[^:/]+\z}{} unless length($basename);
157           }
158           else {
159           _strip_trailing_sep($dirname);
160           unless( length($basename) ) {
161           ($basename,$dirname) = fileparse $dirname;
162           _strip_trailing_sep($dirname);
163           }
164           }
165            
166           $dirname;
167           }
168            
169           # Strip the trailing path separator.
170           sub _strip_trailing_sep {
171           my $type = $Fileparse_fstype;
172            
173           if ($type eq 'MacOS') {
174           $_[0] =~ s/([^:]):\z/$1/s;
175           }
176           elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
177           $_[0] =~ s/([^:])[\\\/]*\z/$1/;
178           }
179           else {
180           $_[0] =~ s{(.)/*\z}{$1}s;
181           }
182           }
183            
184           BEGIN {
185            
186           my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
187           my @Types = (@Ignore_Case, qw(Unix));
188            
189           sub fileparse_set_fstype {
190           my $old = $Fileparse_fstype;
191            
192           if (@_) {
193           my $new_type = shift;
194            
195           $Fileparse_fstype = 'Unix'; # default
196           foreach my $type (@Types) {
197           $Fileparse_fstype = $type if $new_type =~ /^$type/i;
198           }
199            
200           $Fileparse_igncase =
201           (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
202           }
203            
204           return $old;
205           }
206            
207           }
208            
209           1;
210