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