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
|
#!perl -T
use strict;
use Config;
my $db_file;
BEGIN {
if (not eval "use Test::More; 1") {
print "1..0 # Skip: Test::More not available\n";
die "Test::More not available\n";
}
plan(skip_all => "these tests needs Perl 5.5+") if $] < 5.005;
use Config;
foreach (qw/SDBM_File GDBM_File ODBM_File NDBM_File DB_File/) {
if ($Config{extensions} =~ /\b$_\b/) {
$db_file = $_;
last;
}
}
}
my %modules = (
# ModuleName => q|code to check that it was loaded|,
'Cwd' => q| ::can_ok( 'Cwd' => 'fastcwd' ) |, # 5.7 ?
'File::Glob' => q| ::can_ok( 'File::Glob' => # 5.6
$] > 5.014
? 'bsd_glob' : 'doglob') |,
$db_file => q| ::can_ok( $db_file => 'TIEHASH' ) |, # 5.0
'Socket' => q| ::can_ok( 'Socket' => 'inet_aton' ) |, # 5.0
'Time::HiRes'=> q| ::can_ok( 'Time::HiRes' => 'usleep' ) |, # 5.7.3
);
plan tests => keys(%modules) * 3 + 9;
# Try to load the module
use_ok( 'XSLoader' );
# Check functions
can_ok( 'XSLoader' => 'load' );
can_ok( 'XSLoader' => 'bootstrap_inherit' );
# Check error messages
my @cases = (
[ 'Thwack', 'package Thwack; XSLoader::load(); 1' ],
[ 'Zlott' , 'package Thwack; XSLoader::load("Zlott"); 1' ],
);
for my $case (@cases) {
my ($should_load, $codestr) = @$case;
my $diag;
# determine the expected diagnostic
if ($Config{usedl}) {
if ($case->[0] eq "Thwack" and ($] == 5.008004 or $] == 5.008005)) {
# these versions had bugs with chained C<goto &>
$diag = "Usage: DynaLoader::bootstrap\\(module\\)";
} else {
# normal diagnostic for a perl with dynamic loading
$diag = "Can't locate loadable object for module $should_load in \@INC";
}
} else {
# a perl with no dynamic loading
$diag = "Can't load module $should_load, dynamic loading not available in this perl.";
}
is(eval $codestr, undef, "eval '$codestr' should die");
like($@, qr/^$diag/, "calling XSLoader::load() under a package with no XS part");
}
# Now try to load well known XS modules
my $extensions = $Config{'extensions'};
$extensions =~ s|/|::|g;
for my $module (sort keys %modules) {
SKIP: {
skip "$module not available", 3 if $extensions !~ /\b$module\b/;
eval qq{ package $module; XSLoader::load('$module', "12345678"); };
like( $@, "/^$module object version \\S+ does not match bootstrap parameter 12345678/",
"calling XSLoader::load() with a XS module and an incorrect version" );
eval qq{ package $module; XSLoader::load('$module'); };
is( $@, '', "XSLoader::load($module)");
eval qq{ package $module; $modules{$module}; };
}
}
SKIP: {
skip "Needs 5.15.6", 1 unless $] > 5.0150051;
skip "List::Util not available", 1 if $extensions !~ /\bList::Util\b/;
eval 'package List::Util; XSLoader::load(__PACKAGE__, "version")';
like $@, "/^Invalid version format/",
'correct error msg for invalid versions';
}
SKIP: {
skip "File::Path not available", 1
unless eval { require File::Path };
my $name = "phooo$$";
File::Path::make_path("$name/auto/Foo/Bar");
open my $fh,
">$name/auto/Foo/Bar/Bar.$Config::Config{'dlext'}";
close $fh;
my $fell_back;
local *XSLoader::bootstrap_inherit = sub {
$fell_back++;
# Break out of the calling subs
goto the_test;
};
eval <<END;
#line 1 $name
package Foo::Bar;
XSLoader::load("Foo::Bar");
END
the_test:
ok $fell_back,
'XSLoader will not load relative paths based on (caller)[1]';
File::Path::remove_tree($name);
}
|
