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
185
186
187
188
189
190
191
192
193
194
195
196
|
#!/usr/bin/perl -wT
use strict;
use Config;
use Test::More;
my (%modules, %no_unload);
my $db_file;
BEGIN {
use Config;
foreach (qw/SDBM_File GDBM_File ODBM_File NDBM_File DB_File/) {
if ($Config{extensions} =~ /\b$_\b/) {
$db_file = $_;
last;
}
}
}
%modules = (
# ModuleName => q| code to check that it was loaded |,
'List::Util' => q| ::is( ref List::Util->can('first'), 'CODE' ) |, # 5.7.2
'Cwd' => q| ::is( ref Cwd->can('fastcwd'),'CODE' ) |, # 5.7 ?
'File::Glob' => q| ::is( ref File::Glob->can('doglob'),'CODE' ) |, # 5.6
$db_file => q| ::is( ref $db_file->can('TIEHASH'), 'CODE' ) |, # 5.0
'Socket' => q| ::is( ref Socket->can('inet_aton'),'CODE' ) |, # 5.0
'Time::HiRes'=> q| ::is( ref Time::HiRes->can('usleep'),'CODE' ) |, # 5.7.3
'B' => q| ::is( ref B->can('svref_2object'),'CODE' ) |, # Test::Builder loads this.
'Encode' => q| ::is( ref Encode->can('decode'),'CODE' ) |, # Test::Builder loads this.
);
# These modules must not be unloaded since they are needed by Test::Builder
%no_unload = (
'B' => 1,
'Encode' => 1,
'List::Util' => 1,
);
# Try to load the module
use_ok( 'DynaLoader' );
# Some tests need to be skipped on old Darwin versions.
# Commit ce12ed1954 added the skip originally, without specifying which
# darwin version needed it. I know OS X 10.6 (Snow Leopard; darwin 10)
# supports it, so skip anything before that.
my $old_darwin = $^O eq 'darwin' && ($Config{osvers} =~ /^(\d+)/)[0] < 10;
# Check functions
can_ok( 'DynaLoader' => 'bootstrap' ); # defined in Perl section
can_ok( 'DynaLoader' => 'dl_load_flags' ); # defined in Perl section
can_ok( 'DynaLoader' => 'dl_error' ); # defined in XS section
if ($Config{usedl}) {
can_ok( 'DynaLoader' => 'dl_find_symbol' ); # defined in XS section
can_ok( 'DynaLoader' => 'dl_install_xsub' ); # defined in XS section
can_ok( 'DynaLoader' => 'dl_load_file' ); # defined in XS section
can_ok( 'DynaLoader' => 'dl_undef_symbols' ); # defined in XS section
SKIP: {
skip "unloading unsupported on $^O", 1 if ($old_darwin || $^O eq 'VMS');
can_ok( 'DynaLoader' => 'dl_unload_file' ); # defined in XS section
}
} else {
foreach my $symbol (qw(dl_find_symbol dl_install_sub dl_load_file
dl_undef_symbols dl_unload_file)) {
is(DynaLoader->can($symbol), undef,
"Without dynamic loading, DynaLoader should not have $symbol");
}
}
can_ok( 'DynaLoader' => 'dl_expandspec' );
can_ok( 'DynaLoader' => 'dl_findfile' );
can_ok( 'DynaLoader' => 'dl_find_symbol_anywhere' );
# Check error messages
# .. for bootstrap()
eval { DynaLoader::bootstrap() };
like( $@, q{/^Usage: DynaLoader::bootstrap\(module\)/},
"calling DynaLoader::bootstrap() with no argument" );
eval { package egg_bacon_sausage_and_spam; DynaLoader::bootstrap("egg_bacon_sausage_and_spam") };
if ($Config{usedl}) {
like( $@, q{/^Can't locate loadable object for module egg_bacon_sausage_and_spam/},
"calling DynaLoader::bootstrap() with a package without binary object" );
} else {
like( $@, q{/^Can't load module egg_bacon_sausage_and_spam/},
"calling DynaLoader::bootstrap() with a package without binary object" );
}
# .. for dl_load_file()
SKIP: {
skip "no dl_load_file with dl_none.xs", 2 unless $Config{usedl};
eval { DynaLoader::dl_load_file() };
like( $@, q{/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/},
"calling DynaLoader::dl_load_file() with no argument" );
eval { no warnings 'uninitialized'; DynaLoader::dl_load_file(undef) };
is( $@, '', "calling DynaLoader::dl_load_file() with undefined argument" ); # is this expected ?
}
my ($dlhandle, $dlerr);
eval { $dlhandle = DynaLoader::dl_load_file("egg_bacon_sausage_and_spam") };
$dlerr = DynaLoader::dl_error();
SKIP: {
skip "dl_load_file() does not attempt to load file on VMS (and thus does not fail) when \@dl_require_symbols is empty", 1 if $^O eq 'VMS';
ok( !$dlhandle, "calling DynaLoader::dl_load_file() without an existing library should fail" );
}
ok( defined $dlerr, "dl_error() returning an error message: '$dlerr'" );
# Checking for any particular error messages or numeric codes
# is very unportable, please do not try to do that. A failing
# dl_load_file() is not even guaranteed to set the $! or the $^E.
# ... dl_findfile()
SKIP: {
my @files = ();
eval { @files = DynaLoader::dl_findfile("c") };
is( $@, '', "calling dl_findfile()" );
# Some platforms are known to not have a "libc"
# (not at least by that name) that the dl_findfile()
# could find.
skip "dl_findfile test not appropriate on $^O", 1
if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos)/i;
# Play safe and only try this test if this system
# looks pretty much Unix-like.
skip "dl_findfile test not appropriate on $^O", 1
unless -d '/usr' && -f '/bin/ls';
skip "dl_findfile test not always appropriate when cross-compiling", 1
if $Config{usecrosscompile};
cmp_ok( scalar @files, '>=', 1, "array should contain one result result or more: libc => (@files)" );
}
# Now try to load well known XS modules
my $extensions = $Config{'dynamic_ext'};
$extensions =~ s|/|::|g;
for my $module (sort keys %modules) {
SKIP: {
if ($extensions !~ /\b$module\b/) {
delete($modules{$module});
skip "$module not available", 3;
}
eval "use $module";
is( $@, '', "loading $module" );
}
}
is( scalar @DynaLoader::dl_librefs, scalar keys %modules, "checking number of items in \@dl_librefs" );
is( scalar @DynaLoader::dl_modules, scalar keys %modules, "checking number of items in \@dl_modules" );
my @loaded_modules = @DynaLoader::dl_modules;
for my $libref (reverse @DynaLoader::dl_librefs) {
TODO: {
todo_skip "Can't safely unload with -DPERL_GLOBAL_STRUCT_PRIVATE (RT #119409)", 2
if $Config{ccflags} =~ /(?:^|\s)-DPERL_GLOBAL_STRUCT_PRIVATE\b/;
SKIP: {
skip "unloading unsupported on $^O", 2
if ($old_darwin || $^O eq 'VMS');
my $module = pop @loaded_modules;
next if $no_unload{$module};
skip "File::Glob sets PL_opfreehook", 2 if $module eq 'File::Glob';
my $r = eval { DynaLoader::dl_unload_file($libref) };
is( $@, '', "calling dl_unload_file() for $module" );
is( $r, 1, " - unload was successful" );
}
}
}
SKIP: {
skip "mod2fname not defined on this platform", 4
unless defined &DynaLoader::mod2fname && $Config{d_libname_unique};
is(
DynaLoader::mod2fname(["Hash", "Util"]),
"PL_Hash__Util",
"mod2fname + libname_unique works"
);
is(
DynaLoader::mod2fname([("Hash", "Util") x 25]),
"PL_" . join("_", ("Hash", "Util")x25),
"mod2fname + libname_unique collapses double __'s for long names"
);
is(
DynaLoader::mod2fname([("Haash", "Uttil") x 25]),
"PL_" . join("_", ("HAsh", "UTil")x25),
"mod2fname + libname_unique collapses repeated characters for long names"
);
is(
DynaLoader::mod2fname([("Hash", "Util")x30]),
substr(("PL_" . join("_", ("Hash", "Util")x30)), 0, 255 - (length($Config::Config{dlext})+1)),
"mod2fname + libname_unique correctly truncates long names"
);
}
done_testing;
|
