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