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