This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH]Re: [perl #36417] IO::Handle::getline() doco should note an important...
[perl5.git] / lib / File / Basename.t
CommitLineData
b3eb6a9b 1#!./perl -T
78201403 2
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
78201403 6}
7
8use File::Basename qw(fileparse basename dirname);
9
084592ab 10print "1..41\n";
78201403 11
12# import correctly?
13print +(defined(&basename) && !defined(&fileparse_set_fstype) ?
14 '' : 'not '),"ok 1\n";
15
16# set fstype -- should replace non-null default
17print +(length(File::Basename::fileparse_set_fstype('unix')) ?
18 '' : 'not '),"ok 2\n";
19
20# Unix syntax tests
3b421ef0 21($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',qr'\.book\d+');
78201403 22if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') {
23 print "ok 3\n";
24}
25else {
26 print "not ok 3 |$base|$path|$type|\n";
27}
28print +(basename('/arma/virumque.cano') eq 'virumque.cano' ?
29 '' : 'not '),"ok 4\n";
30print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n";
31print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n";
32print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n";
33
34
35# set fstype -- should replace non-null default
36print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ?
37 '' : 'not '),"ok 8\n";
38
39# VMS syntax tests
3b421ef0 40($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7',qr{\.book\d+});
78201403 41if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') {
42 print "ok 9\n";
43}
44else {
45 print "not ok 9 |$base|$path|$type|\n";
46}
47print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ?
48 '' : 'not '),"ok 10\n";
49print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ?
50 '' : 'not '),"ok 11\n";
51print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ?
52 '' : 'not '),"ok 12\n";
53print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n";
2d6caab3 54$ENV{DEFAULT} = '' unless exists $ENV{DEFAULT};
78201403 55print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n";
56print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n";
57
58# set fstype -- should replace non-null default
59print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ?
60 '' : 'not '),"ok 16\n";
61
62# MSDOS syntax tests
63($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+');
64if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') {
65 print "ok 17\n";
66}
67else {
68 print "not ok 17 |$base|$path|$type|\n";
69}
70print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ?
71 '' : 'not '),"ok 18\n";
72print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ?
73 '' : 'not '),"ok 19\n";
74print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n";
75print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n";
76
77# Yes "/" is a legal path separator under MSDOS
78basename("lib/File/Basename.pm") eq "Basename.pm" or print "not ";
79print "ok 22\n";
80
81
82
83# set fstype -- should replace non-null default
84print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ?
85 '' : 'not '),"ok 23\n";
86
87# MacOS syntax tests
88($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+');
89if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') {
90 print "ok 24\n";
91}
92else {
93 print "not ok 24 |$base|$path|$type|\n";
94}
95print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ?
96 '' : 'not '),"ok 25\n";
97print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ?
98 '' : 'not '),"ok 26\n";
084592ab
CN
99print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n";
100print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n";
101print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n";
102print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n";
103print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n";
104print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n";
105print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n";
78201403 106
107
108# Check quoting of metacharacters in suffix arg by basename()
109print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ?
084592ab 110 '' : 'not '),"ok 34\n";
78201403 111print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ?
084592ab 112 '' : 'not '),"ok 35\n";
78201403 113
42568e28
RB
114# extra tests for a few specific bugs
115
116File::Basename::fileparse_set_fstype 'MSDOS';
117# perl5.003_18 gives C:/perl/.\
084592ab 118print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n";
42568e28 119# perl5.003_18 gives C:\perl\
084592ab 120print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n";
42568e28
RB
121
122File::Basename::fileparse_set_fstype 'UNIX';
123# perl5.003_18 gives '.'
084592ab 124print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n";
42568e28 125# perl5.003_18 gives '/perl/lib'
084592ab 126print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n";
b3eb6a9b
GS
127
128# The empty tainted value, for tainting strings
129my $TAINT = substr($^X, 0, 0);
130# How to identify taint when you see it
131sub any_tainted (@) {
132 not eval { join("",@_), kill 0; 1 };
133}
134sub tainted ($) {
135 any_tainted @_;
136}
137sub all_tainted (@) {
138 for (@_) { return 0 unless tainted $_ }
139 1;
140}
141
084592ab 142print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n";
b3eb6a9b 143print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'))
084592ab 144 ? '' : 'not '), "ok 41\n";