1#!perl -T 2 3use strict; 4use warnings; 5 6use Config; 7 8my $db_file; 9BEGIN { 10 use Config; 11 foreach (qw/SDBM_File GDBM_File ODBM_File NDBM_File DB_File/) { 12 if ($Config{extensions} =~ /\b$_\b/) { 13 $db_file = $_; 14 last; 15 } 16 } 17} 18 19# mini test implementation. We're going to be playing with the XS bits of 20# various modules that may be used by Test::More, so it's best to avoid. Since 21# XSLoader is dual life, we can't use something like perl's t/test.pl 22my $planned_tests; 23my $tests; 24my $passed_tests; 25sub ok ($;$) { 26 my ($ok, $name) = @_; 27 $tests++; 28 $passed_tests += 1 if $ok; 29 print STDOUT "not " 30 if !$ok; 31 print STDOUT "ok $tests"; 32 print STDOUT " - $name" 33 if defined $name; 34 print "\n"; 35 return $ok; 36} 37sub is ($$;$) { 38 my ($got, $want, $name) = @_; 39 40 my $ok 41 = !defined $want && !defined $got 42 || defined $want && defined $got && $got eq $want; 43 44 defined $_ or $_ = '[undef]' 45 for $got, $want; 46 47 ok($ok, $name) 48 or diag("Got: $got\nExpected: $want"); 49 50 return $ok; 51} 52sub can_ok ($@) { 53 my ($inv, @methods) = @_; 54 die "only supports one method" 55 if @methods != 1; 56 ok $inv->can($methods[0]), "$inv->can('$methods[0]')"; 57} 58sub skip ($$) { 59 my ($message, $count) = @_; 60 die "bad skip" 61 if !$count || $count =~ /[^0-9]/; 62 for (1..$count) { 63 $tests++; 64 print STDOUT "ok $tests # skip $message\n"; 65 } 66 $passed_tests += $count; 67 no warnings 'exiting'; 68 last SKIP; 69} 70sub like ($$;$) { 71 my ($got, $want_re, $name) = @_; 72 if (!ref $want_re) { 73 $want_re =~ m{\A/(.*)/([a-z]*)\z} 74 or die "bad regex $want_re"; 75 $want_re = (length $2 ? "(?$2)" : '') . $1; 76 } 77 my $ok = $got =~ $want_re; 78 ok($ok, $name) 79 or diag("Got: $got\nExpected: $want_re"); 80 return $ok; 81} 82sub diag { 83 my ($message) = @_; 84 $message =~ s/\n?\z/\n/; 85 $message =~ s/^/# /gm; 86 print STDERR $message; 87} 88END { 89 if (!defined $planned_tests) { 90 print STDERR "# No plan was declared!\n"; 91 $? = 254; 92 return; 93 } 94 95 if ($tests != $planned_tests) { 96 print STDERR "# Looks like you planned $planned_tests test but ran $tests.\n"; 97 $? = abs($planned_tests - $tests); 98 } 99 elsif ($passed_tests != $tests) { 100 my $failed = $tests - $passed_tests; 101 print STDERR "# Looks like you failed $failed test but ran $tests.\n"; 102 } 103} 104sub plan { 105 my %opts = @_; 106 die "already planned" 107 if defined $planned_tests; 108 if (my $skip_all = $opts{skip_all}) { 109 print STDOUT "1..0 # SKIP $skip_all\n"; 110 $planned_tests = 0; 111 exit 0; 112 } 113 elsif ($planned_tests = $opts{tests}) { 114 print STDOUT "1..$planned_tests\n"; 115 } 116} 117 118### 119 120my %modules = ( 121 # ModuleName => q|code to check that it was loaded|, 122 'Cwd' => q| ::can_ok( 'Cwd' => 'fastcwd' ) |, # 5.7 ? 123 'File::Glob' => q| ::can_ok( 'File::Glob' => # 5.6 124 $] > 5.014 125 ? 'bsd_glob' : 'doglob') |, 126 $db_file => q| ::can_ok( $db_file => 'TIEHASH' ) |, # 5.0 127 'Socket' => q| ::can_ok( 'Socket' => 'inet_aton' ) |, # 5.0 128 'Time::HiRes'=> q| ::can_ok( 'Time::HiRes' => 'usleep' ) |, # 5.7.3 129); 130 131plan tests => keys(%modules) * 3 + 9; 132 133use XSLoader; 134 135# Check functions 136can_ok( 'XSLoader' => 'load' ); 137can_ok( 'XSLoader' => 'bootstrap_inherit' ); 138 139# Check error messages 140my @cases = ( 141 [ 'Thwack', 'package Thwack; XSLoader::load(); 1' ], 142 [ 'Zlott' , 'package Thwack; XSLoader::load("Zlott"); 1' ], 143); 144 145for my $case (@cases) { 146 my ($should_load, $codestr) = @$case; 147 my $diag; 148 149 # determine the expected diagnostic 150 if ($Config{usedl}) { 151 if ($case->[0] eq "Thwack" and ($] == 5.008004 or $] == 5.008005)) { 152 # these versions had bugs with chained C<goto &> 153 $diag = "Usage: DynaLoader::bootstrap\\(module\\)"; 154 } else { 155 # normal diagnostic for a perl with dynamic loading 156 $diag = "Can't locate loadable object for module $should_load in \@INC"; 157 } 158 } else { 159 # a perl with no dynamic loading 160 $diag = "Can't load module $should_load, dynamic loading not available in this perl."; 161 } 162 163 is(eval $codestr, undef, "eval '$codestr' should die"); 164 like($@, qr/^$diag/, "calling XSLoader::load() under a package with no XS part"); 165} 166 167# Now try to load well known XS modules 168my $extensions = $Config{'extensions'}; 169$extensions =~ s|/|::|g; 170 171for my $module (sort keys %modules) { 172 SKIP: { 173 skip "$module not available", 3 if $extensions !~ /\b$module\b/; 174 175 eval qq{ package $module; XSLoader::load('$module', "12345678"); }; 176 like( $@, "/^$module object version \\S+ does not match bootstrap parameter 12345678/", 177 "calling XSLoader::load() with a XS module and an incorrect version" ); 178 179 eval qq{ package $module; XSLoader::load('$module'); }; 180 is( $@, '', "XSLoader::load($module)"); 181 182 eval qq{ package $module; $modules{$module}; }; 183 } 184} 185 186SKIP: { 187 skip "Needs 5.15.6", 1 unless $] > 5.0150051; 188 skip "List::Util not available", 1 if $extensions !~ /\bList::Util\b/; 189 eval 'package List::Util; XSLoader::load(__PACKAGE__, "version")'; 190 like $@, "/^Invalid version format/", 191 'correct error msg for invalid versions'; 192} 193 194SKIP: { 195 skip "Devel::Peek not available", 1 196 unless $extensions =~ /\bDevel::Peek\b/; 197 198 # XSLoader::load() assumes it's being called from a module, so 199 # pretend it is, first find where Devel/Peek.pm is 200 my $peek_file = "Devel/Peek.pm"; 201 my $module_path; 202 for my $dir (@INC) { 203 if (-f "$dir/$peek_file") { 204 $module_path = "$dir/Not/Devel/Peek.pm"; 205 last; 206 } 207 } 208 209 skip "Cannot find $peek_file", 1 210 unless $module_path; 211 212 # [perl #122455] 213 # die instead of falling back to DynaLoader 214 no warnings 'redefine'; 215 local *XSLoader::bootstrap_inherit = sub { die "Fallback to DynaLoader\n" }; 216 ::ok( eval <<EOS, "test correct path searched for modules") 217package Not::Devel::Peek; 218#line 1 "$module_path" 219XSLoader::load("Devel::Peek"); 220EOS 221 or ::diag $@; 222} 223 224SKIP: { 225 skip "File::Path not available", 1 226 unless eval { require File::Path }; 227 my $name = "phooo$$"; 228 File::Path::mkpath("$name/auto/Foo/Bar"); 229 open my $fh, 230 ">$name/auto/Foo/Bar/Bar.$Config::Config{'dlext'}"; 231 close $fh; 232 my $fell_back; 233 no warnings 'redefine'; 234 local *XSLoader::bootstrap_inherit = sub { 235 $fell_back++; 236 # Break out of the calling subs 237 goto the_test; 238 }; 239 eval <<END; 240#line 1 $name 241package Foo::Bar; 242XSLoader::load("Foo::Bar"); 243END 244 the_test: 245 ok $fell_back, 246 'XSLoader will not load relative paths based on (caller)[1]'; 247 File::Path::rmtree($name); 248} 249