1#!/usr/bin/perl -wT
2
3use strict;
4use Config;
5push @INC, '.';
6if (-f 't/test.pl') {
7  require './t/test.pl';
8} else {
9  require '../../t/test.pl';
10}
11
12my %modules;
13
14my $db_file;
15BEGIN {
16    use Config;
17    foreach (qw/SDBM_File GDBM_File ODBM_File NDBM_File DB_File/) {
18        if ($Config{extensions} =~ /\b$_\b/) {
19            $db_file = $_;
20            last;
21        }
22    }
23}
24
25%modules = (
26   # ModuleName   => q| code to check that it was loaded |,
27    'List::Util'  => q| ::is( ref List::Util->can('first'), 'CODE' ) |,  # 5.7.2
28    'Cwd'         => q| ::is( ref Cwd->can('fastcwd'),'CODE' ) |,         # 5.7 ?
29    'File::Glob'  => q| ::is( ref File::Glob->can('doglob'),'CODE' ) |,   # 5.6
30    $db_file      => q| ::is( ref $db_file->can('TIEHASH'), 'CODE' ) |,  # 5.0
31    'Socket'      => q| ::is( ref Socket->can('inet_aton'),'CODE' ) |,    # 5.0
32    'Time::HiRes' => q| ::is( ref Time::HiRes->can('usleep'),'CODE' ) |,  # 5.7.3
33);
34
35plan (26 + keys(%modules) * 3);
36
37# Try to load the module
38use_ok( 'DynaLoader' );
39
40# Some tests need to be skipped on old Darwin versions.
41# Commit ce12ed1954 added the skip originally, without specifying which
42# darwin version needed it.  I know OS X 10.6 (Snow Leopard; darwin 10)
43# supports it, so skip anything before that.
44my $old_darwin = $^O eq 'darwin' && ($Config{osvers} =~ /^(\d+)/)[0] < 10;
45
46# Check functions
47can_ok( 'DynaLoader' => 'bootstrap'               ); # defined in Perl section
48can_ok( 'DynaLoader' => 'dl_load_flags'           ); # defined in Perl section
49can_ok( 'DynaLoader' => 'dl_error'                ); # defined in XS section
50if ($Config{usedl}) {
51    can_ok( 'DynaLoader' => 'dl_find_symbol'      ); # defined in XS section
52    can_ok( 'DynaLoader' => 'dl_install_xsub'     ); # defined in XS section
53    can_ok( 'DynaLoader' => 'dl_load_file'        ); # defined in XS section
54    can_ok( 'DynaLoader' => 'dl_undef_symbols'    ); # defined in XS section
55    SKIP: {
56        skip( "unloading unsupported on $^O", 1 ) if ($old_darwin || $^O eq 'VMS');
57        can_ok( 'DynaLoader' => 'dl_unload_file'  ); # defined in XS section
58    }
59} else {
60    foreach my $symbol (qw(dl_find_symbol dl_install_sub dl_load_file
61			   dl_undef_symbols dl_unload_file)) {
62	is(DynaLoader->can($symbol), undef,
63	   "Without dynamic loading, DynaLoader should not have $symbol");
64    }
65}
66
67can_ok( 'DynaLoader' => 'dl_expandspec'           );
68can_ok( 'DynaLoader' => 'dl_findfile'             );
69can_ok( 'DynaLoader' => 'dl_find_symbol_anywhere' );
70
71
72# Check error messages
73# .. for bootstrap()
74eval { DynaLoader::bootstrap() };
75like( $@, qr/^Usage: DynaLoader::bootstrap\(module\)/,
76        "calling DynaLoader::bootstrap() with no argument" );
77
78eval { package egg_bacon_sausage_and_spam; DynaLoader::bootstrap("egg_bacon_sausage_and_spam") };
79if ($Config{usedl}) {
80    like( $@, qr/^Can't locate loadable object for module egg_bacon_sausage_and_spam/,
81        "calling DynaLoader::bootstrap() with a package without binary object" );
82} else {
83     like( $@, qr/^Can't load module egg_bacon_sausage_and_spam/,
84        "calling DynaLoader::bootstrap() with a package without binary object" );
85}
86
87# .. for dl_load_file()
88SKIP: {
89    skip( "no dl_load_file with dl_none.xs", 2 ) unless $Config{usedl};
90    eval { DynaLoader::dl_load_file() };
91    like( $@, qr/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/,
92            "calling DynaLoader::dl_load_file() with no argument" );
93
94    eval { no warnings 'uninitialized'; DynaLoader::dl_load_file(undef) };
95    is( $@, '', "calling DynaLoader::dl_load_file() with undefined argument" );     # is this expected ?
96}
97
98my ($dlhandle, $dlerr);
99eval { $dlhandle = DynaLoader::dl_load_file("egg_bacon_sausage_and_spam") };
100$dlerr = DynaLoader::dl_error();
101SKIP: {
102    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';
103    ok( !$dlhandle, "calling DynaLoader::dl_load_file() without an existing library should fail" );
104}
105ok( defined $dlerr, "dl_error() returning an error message: '$dlerr'" );
106
107# Checking for any particular error messages or numeric codes
108# is very unportable, please do not try to do that.  A failing
109# dl_load_file() is not even guaranteed to set the $! or the $^E.
110
111# ... dl_findfile()
112SKIP: {
113    my @files = ();
114    eval { @files = DynaLoader::dl_findfile("c") };
115    is( $@, '', "calling dl_findfile()" );
116    # Some platforms are known to not have a "libc"
117    # (not at least by that name) that the dl_findfile()
118    # could find.
119    skip( "dl_findfile test not appropriate on $^O", 1 )
120	if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos|os390)/i;
121    # Play safe and only try this test if this system
122    # looks pretty much Unix-like.
123    skip( "dl_findfile test not appropriate on $^O", 1 )
124	unless -d '/usr' && -f '/bin/ls';
125    skip( "dl_findfile test not always appropriate when cross-compiling", 1 )
126        if $Config{usecrosscompile};
127    cmp_ok( scalar @files, '>=', 1, "array should contain one result or more: libc => (@files)" );
128}
129
130# Now try to load well known XS modules
131my $extensions = $Config{'dynamic_ext'};
132$extensions =~ s|/|::|g;
133
134for my $module (sort keys %modules) {
135    SKIP: {
136        if ($extensions !~ /\b$module\b/) {
137            delete($modules{$module});
138            skip( "$module not available", 3);
139        }
140        eval "use $module";
141        is( $@, '', "loading $module" );
142    }
143}
144
145# checking internal consistency
146is( scalar @DynaLoader::dl_librefs, scalar keys %modules, "checking number of items in \@dl_librefs" );
147is( scalar @DynaLoader::dl_modules, scalar keys %modules, "checking number of items in \@dl_modules" );
148
149my @loaded_modules = @DynaLoader::dl_modules;
150for my $libref (reverse @DynaLoader::dl_librefs) {
151SKIP: {
152        skip( "unloading unsupported on $^O", 2 )
153            if ($old_darwin || $^O eq 'VMS');
154        my $module = pop @loaded_modules;
155        skip( "File::Glob sets PL_opfreehook", 2 ) if $module eq 'File::Glob';
156        my $r = eval { DynaLoader::dl_unload_file($libref) };
157        is( $@, '', "calling dl_unload_file() for $module" );
158        is( $r,  1, " - unload was successful" );
159    }
160}
161
162SKIP: {
163    skip( "mod2fname not defined on this platform", 4 )
164        unless defined &DynaLoader::mod2fname && $Config{d_libname_unique};
165
166    is(
167        DynaLoader::mod2fname(["Hash", "Util"]),
168        "PL_Hash__Util",
169        "mod2fname + libname_unique works"
170    );
171
172    is(
173        DynaLoader::mod2fname([("Hash", "Util") x 25]),
174        "PL_" . join("_", ("Hash", "Util")x25),
175        "mod2fname + libname_unique collapses double __'s for long names"
176    );
177
178    is(
179        DynaLoader::mod2fname([("Haash", "Uttil") x 25]),
180        "PL_" . join("_", ("HAsh", "UTil")x25),
181        "mod2fname + libname_unique collapses repeated characters for long names"
182    );
183
184    is(
185        DynaLoader::mod2fname([("Hash", "Util")x30]),
186        substr(("PL_" . join("_", ("Hash", "Util")x30)), 0, 255 - (length($Config::Config{dlext})+1)),
187        "mod2fname + libname_unique correctly truncates long names"
188    );
189}
190
191