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
|
### make sure we can find our conf.pl file
BEGIN {
use FindBin;
require "$FindBin::Bin/inc/conf.pl";
}
use strict;
### make sure to keep the plan -- this is the only test
### supported for 'older' T::H (pre 2.28) -- see Makefile.PL for details
use Test::More tests => 40;
use Cwd;
use Data::Dumper;
use File::Spec;
use File::Basename;
use CPANPLUS::Error;
use CPANPLUS::Internals::Utils;
# File::Spec and Cwd might return different values for a
# symlinked directory, so we need to be careful.
sub paths_are_same {
my($have, $want, $name) = @_;
$have = _resolve_symlinks($have);
$want = _resolve_symlinks($want);
my $builder = Test::More->builder;
return $builder->like( $have, qr/\Q$want/i, $name );
}
# Resolve any symlinks in a path
sub _resolve_symlinks {
my $path = shift;
my($vol, $dirs, $file) = File::Spec->splitpath($path);
my $resolved = File::Spec->catpath( $vol, "", "" );
for my $dir (File::Spec->splitdir($dirs)) {
# Resolve the next part of the path
my $next = File::Spec->catdir( $resolved, $dir );
$next = eval { readlink $next } || $next;
# If its absolute, use it.
# Otherwise tack it onto the end of the previous path.
$resolved = File::Spec->file_name_is_absolute($next)
? $next
: File::Spec->catdir( $resolved, $next );
}
return File::Spec->catfile($resolved, $file);
}
my $Cwd = File::Spec->rel2abs(cwd());
my $Class = 'CPANPLUS::Internals::Utils';
my $Dir = 'foo';
my $Move = 'bar';
my $File = 'zot';
rmdir $Move if -d $Move;
rmdir $Dir if -d $Dir;
### test _mdkir ###
{ ok( $Class->_mkdir( dir => $Dir), "Created dir '$Dir'" );
ok( -d $Dir, " '$Dir' is a dir" );
}
### test _chdir ###
{ ok( $Class->_chdir( dir => $Dir), "Chdir to '$Dir'" );
my $abs = File::Spec->rel2abs(File::Spec->catdir($Cwd,$Dir));
paths_are_same( File::Spec->rel2abs(cwd()), $abs,
" Cwd() is '$Dir'");
ok( $Class->_chdir( dir => $Cwd), "Chdir back to '$Cwd'" );
paths_are_same( File::Spec->rel2abs(cwd()), $Cwd,
" Cwd() is '$Cwd'" );
}
### test _move ###
{ ok( $Class->_move( file => $Dir, to => $Move ),
"Move from '$Dir' to '$Move'" );
ok( -d $Move, " Dir '$Move' exists" );
ok( !-d $Dir, " Dir '$Dir' no longer exists" );
{ local $CPANPLUS::Error::ERROR_FH = output_handle();
### now try to move it somewhere it can't ###
ok( !$Class->_move( file => $Move, to => 'inc' ),
" Impossible move detected" );
like( CPANPLUS::Error->stack_as_string, qr/Failed to move/,
" Expected error found" );
}
}
### test _rmdir ###
{ ok( -d $Move, "Dir '$Move' exists" );
ok( $Class->_rmdir( dir => $Move ), " Deleted dir '$Move'" );
ok(!-d $Move, " Dir '$Move' no longer exists" );
}
### _get_file_contents tests ###
{ my $contents = $Class->_get_file_contents( file => basename($0) );
ok( $contents, "Got file contents" );
like( $contents, qr/BEGIN/, " Proper contents found" );
like( $contents, qr/CPANPLUS/, " Proper contents found" );
}
### _perl_version tests ###
{ my $version = $Class->_perl_version( perl => $^X );
ok( $version, "Perl version found" );
like( $version, qr/\d.\d+.\d+/, " Looks like a proper version" );
}
### _version_to_number tests ###
{ my $map = {
'1' => '1',
'1.2' => '1.2',
'.2' => '.2',
'foo' => '0.0',
'a.1' => '0.0',
};
while( my($try,$expect) = each %$map ) {
my $ver = $Class->_version_to_number( version => $try );
ok( $ver, "Version returned" );
is( $ver, $expect, " Value as expected" );
}
}
### _whoami tests ###
{ sub foo {
my $me = $Class->_whoami;
ok( $me, "_whoami returned a result" );
is( $me, 'foo', " Value as expected" );
}
foo();
}
### _mode_plus_w tests ###
{ open my $fh, ">$File" or die "Could not open $File for writing: $!";
close $fh;
### remove perms
ok( -e $File, "File '$File' created" );
ok( chmod( 000, $File ), " File permissions set to 000" );
ok( $Class->_mode_plus_w( file => $File ),
" File permissions set to +w" );
ok( -w $File, " File is writable" );
1 while unlink $File;
ok( !-e $File, " File removed" );
}
### uri encode/decode tests
{ my $org = 'file://foo/bar';
my $enc = $Class->_uri_encode( uri => $org );
ok( $enc, "String '$org' encoded" );
like( $enc, qr/%/, " Contents as expected" );
my $dec = $Class->_uri_decode( uri => $enc );
ok( $dec, "String '$enc' decoded" );
is( $dec, $org, " Decoded properly" );
}
# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
|
