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
177
178
179
180
181
182
183
184
|
#!/usr/bin/perl -w
use strict;
use Test::More tests => 55;
use File::Spec::Functions qw/canonpath splitdir catdir splitpath catpath/;
use Cwd qw/getcwd/;
BEGIN { use_ok('File::chdir') }
#--------------------------------------------------------------------------#
# Fixtures and utility subs
#--------------------------------------------------------------------------#-
# _catdir has OS-specific path separators so do the same for getcwd
sub _getcwd { canonpath( getcwd ) }
# reassemble
sub _catpath {
my ($vol, @dirs) = @_;
return catpath( $vol, catdir(q{}, @dirs), q{} );
}
# get $vol here and use it later
my ($vol,$cwd) = splitpath(canonpath(getcwd),1);
# get directory list the way a user would use it -- without empty leading dir
# as returned by splitdir;
my @cwd = grep { length } splitdir($cwd);
# Utility sub for checking cases
sub _check_cwd {
# report failures at the calling line
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $label = pop @_;
my @expect = @_;
is( _getcwd, _catpath($vol,@expect), "$label works" );
ok( eq_array(\@CWD, [@expect]), '... and value of @CWD is correct' );
is( $CWD, _catpath($vol,@expect), '... and value of $CWD is correct' );
}
#--------------------------------------------------------------------------#-
# Tying test
#--------------------------------------------------------------------------#-
ok( tied @CWD, '@CWD is fit to be tied' );
#--------------------------------------------------------------------------#
# Assignment tests
#--------------------------------------------------------------------------#
# Non-local
@CWD = (@cwd, 't');
_check_cwd( @cwd, 't', 'Ordinary assignment');
# Reset
@CWD = @cwd;
# Localized
{
# localizing tied arrays doesn't work, perl bug. :(
# this is a work around.
local $CWD;
@CWD = (@cwd, 't');
_check_cwd( @cwd, 't', 'Localized assignment' );
}
# Check that localizing $CWD/@CWD reverts properly
_check_cwd( @cwd, 'Reset of localized assignment' );
#--------------------------------------------------------------------------#
# Push tests
#--------------------------------------------------------------------------#
# Non-local
push @CWD, 't';
_check_cwd( @cwd, 't', 'Ordinary push');
# Reset
@CWD = @cwd;
# Localized
{
# localizing tied arrays doesn't work, perl bug. :(
# this is a work around.
local $CWD;
push @CWD, 't';
_check_cwd( @cwd, 't', 'Localized push' );
}
# Check that localizing $CWD/@CWD reverts properly
_check_cwd( @cwd, 'Reset of localized push' );
#--------------------------------------------------------------------------#
# Pop tests
#--------------------------------------------------------------------------#
# Non-local
my $popped_dir = pop @CWD;
_check_cwd( @cwd[0 .. $#cwd-1], 'Ordinary pop');
is( $popped_dir, $cwd[-1], '... and pop returned popped dir' );
# Reset
@CWD = @cwd;
# Localized
{
# localizing tied arrays doesn't work, perl bug. :(
# this is a work around.
local $CWD;
my $popped_dir = pop @CWD;
_check_cwd( @cwd[0 .. $#cwd-1], 'Localized pop');
}
# Check that localizing $CWD/@CWD reverts properly
_check_cwd( @cwd, 'Reset of localized pop' );
#--------------------------------------------------------------------------#
# Splice tests
#--------------------------------------------------------------------------#
# Non-local
my @spliced_dirs;
# splice multiple dirs from end
push @CWD, 't', 'lib';
@spliced_dirs = splice @CWD, -2;
_check_cwd( @cwd, 'Ordinary splice (from end)');
is( @spliced_dirs, 2, '... and returns right number of dirs' );
ok( eq_array(\@spliced_dirs, [qw/t lib/]), "... and they're correct" );
# splice a single dir from the middle
push @CWD, 't', 'lib';
@spliced_dirs = splice @CWD, -2, 1;
_check_cwd( @cwd, 'lib', 'Ordinary splice (from middle)');
is( @spliced_dirs, 1, '... and returns right number of dirs' );
ok( eq_array(\@spliced_dirs, ['t']), "... and it's correct" );
# Reset
@CWD = @cwd;
# Localized
{
# localizing tied arrays doesn't work, perl bug. :(
# this is a work around.
local $CWD;
# splice multiple dirs from end
push @CWD, 't', 'lib';
@spliced_dirs = splice @CWD, -2;
_check_cwd( @cwd, 'Localized splice (from end)');
is( @spliced_dirs, 2, '... and returns right number of dirs' );
ok( eq_array(\@spliced_dirs, [qw/t lib/]), "... and they're correct" );
# splice a single dir from the middle
push @CWD, 't', 'lib';
@spliced_dirs = splice @CWD, -2, 1;
_check_cwd( @cwd, 'lib', 'Localized splice (from middle)');
is( @spliced_dirs, 1, '... and returns right number of dirs' );
ok( eq_array(\@spliced_dirs, ['t']), "... and it's correct" );
}
# Check that localizing $CWD/@CWD reverts properly
_check_cwd( @cwd, 'Reset of localized splice' );
#--------------------------------------------------------------------------#
# Exceptions
#--------------------------------------------------------------------------#
# Change to invalid directory
my $target = "doesnt_exist";
eval { $CWD[@CWD] = $target };
my $err = $@;
ok( $err, 'Failure to chdir throws an error' );
#_check_cwd( @cwd, 'Still in original directory' );
my $missing_dir = quotemeta(File::Spec->catfile($CWD,$target));
like( $err, "/Failed to change directory to '$missing_dir'/",
'... and the error message is correct');
|
