1#!/usr/bin/perl -w 2 3BEGIN { 4 unshift @INC, 't/lib'; 5} 6chdir 't'; 7 8use strict; 9use warnings; 10use Test::More; 11if ($^O =~ /os2/i) { 12 plan( tests => 32 ); 13} else { 14 plan( skip_all => "This is not OS/2" ); 15} 16 17# for dlsyms, overridden in tests 18BEGIN { 19 package ExtUtils::MM_OS2; 20 use subs 'system', 'unlink'; 21} 22 23# for maybe_command 24use File::Spec; 25 26use_ok( 'ExtUtils::MM_OS2' ); 27ok( grep( 'ExtUtils::MM_OS2', @MM::ISA), 28 'ExtUtils::MM_OS2 should be parent of MM' ); 29 30# dlsyms 31my $mm = bless({ 32 SKIPHASH => { 33 dynamic => 1 34 }, 35 NAME => 'foo:bar::', 36}, 'ExtUtils::MM_OS2'); 37 38is( $mm->dlsyms(), '', 39 'dlsyms() should return nothing with dynamic flag set' ); 40 41$mm->{BASEEXT} = 'baseext'; 42delete $mm->{SKIPHASH}; 43my $res = $mm->dlsyms(); 44like( $res, qr/baseext\.def: Makefile/, 45 '... without flag, should return make targets' ); 46like( $res, qr/"DL_FUNCS" => \{ \}/, 47 '... should provide empty hash refs where necessary' ); 48like( $res, qr/"DL_VARS" => \[]/, '... and empty array refs too' ); 49 50$mm->{FUNCLIST} = 'funclist'; 51$res = $mm->dlsyms( IMPORTS => 'imports' ); 52like( $res, qr/"FUNCLIST" => .+funclist/, 53 '... should pick up values from object' ); 54like( $res, qr/"IMPORTS" => .+imports/, '... and allow parameter options too' ); 55 56my $can_write; 57{ 58 local *OUT; 59 $can_write = open(OUT, '>tmp_imp'); 60} 61 62SKIP: { 63 skip("Cannot write test files: $!", 7) unless $can_write; 64 65 $mm->{IMPORTS} = { foo => 'bar' }; 66 67 local $@; 68 eval { $mm->dlsyms() }; 69 like( $@, qr/Can.t mkdir tmp_imp/, 70 '... should die if directory cannot be made' ); 71 72 unlink('tmp_imp') or skip("Cannot remove test file: $!", 9); 73 eval { $mm->dlsyms() }; 74 like( $@, qr/Malformed IMPORT/, 'should die from malformed import symbols'); 75 76 $mm->{IMPORTS} = { foo => 'bar.baz' }; 77 78 my @sysfail = ( 1, 0, 1 ); 79 my ($sysargs, $unlinked); 80 81 *ExtUtils::MM_OS2::system = sub { 82 $sysargs = shift; 83 return shift @sysfail; 84 }; 85 86 *ExtUtils::MM_OS2::unlink = sub { 87 $unlinked++; 88 }; 89 90 eval { $mm->dlsyms() }; 91 92 like( $sysargs, qr/^emximp/, '... should try to call system() though' ); 93 like( $@, qr/Cannot make import library/, 94 '... should die if emximp syscall fails' ); 95 96 # sysfail is 0 now, call emximp call should succeed 97 eval { $mm->dlsyms() }; 98 is( $unlinked, 1, '... should attempt to unlink temp files' ); 99 like( $@, qr/Cannot extract import/, 100 '... should die if other syscall fails' ); 101 102 # make both syscalls succeed 103 @sysfail = (0, 0); 104 local $@; 105 eval { $mm->dlsyms() }; 106 is( $@, '', '... should not die if both syscalls succeed' ); 107} 108 109# static_lib 110{ 111 my $called = 0; 112 113 # avoid "used only once" 114 local *ExtUtils::MM_Unix::static_lib; 115 *ExtUtils::MM_Unix::static_lib = sub { 116 $called++; 117 return "\n\ncalled static_lib\n\nline2\nline3\n\nline4"; 118 }; 119 120 my $args = bless({ IMPORTS => {}, }, 'MM'); 121 122 # without IMPORTS as a populated hash, there will be no extra data 123 my $ret = ExtUtils::MM_OS2::static_lib( $args ); 124 is( $called, 1, 'static_lib() should call parent method' ); 125 like( $ret, qr/^called static_lib/m, 126 '... should return parent data unless IMPORTS exists' ); 127 128 $args->{IMPORTS} = { foo => 1}; 129 $ret = ExtUtils::MM_OS2::static_lib( $args ); 130 is( $called, 2, '... should call parent method if extra imports passed' ); 131 like( $ret, qr/^called static_lib\n\t\$\(AR\) \$\(AR_STATIC_ARGS\)/m, 132 '... should append make tags to first line from parent method' ); 133 like( $ret, qr/\$@\n\n\nline2\nline3\n\nline4/m, 134 '... should include remaining data from parent method' ); 135 136} 137 138# replace_manpage_separator 139my $sep = '//a///b//c/de'; 140is( ExtUtils::MM_OS2->replace_manpage_separator($sep), '.a.b.c.de', 141 'replace_manpage_separator() should turn multiple slashes into periods' ); 142 143# maybe_command 144{ 145 local *DIR; 146 my ($dir, $noext, $exe, $cmd); 147 my $found = 0; 148 149 my ($curdir, $updir) = (File::Spec->curdir, File::Spec->updir); 150 151 # we need: 152 # 1) a directory 153 # 2) an executable file with no extension 154 # 3) an executable file with the .exe extension 155 # 4) an executable file with the .cmd extension 156 # we assume there will be one somewhere in the path 157 # in addition, we need them to be unique enough they do not trip 158 # an earlier file test in maybe_command(). Portability. 159 160 foreach my $path (split(/:/, $ENV{PATH})) { 161 opendir(DIR, $path) or next; 162 while (defined(my $file = readdir(DIR))) { 163 next if $file eq $curdir or $file eq $updir; 164 $file = File::Spec->catfile($path, $file); 165 unless (defined $dir) { 166 if (-d $file) { 167 next if ( -x $file . '.exe' or -x $file . '.cmd' ); 168 169 $dir = $file; 170 $found++; 171 } 172 } 173 if (-x $file) { 174 my $ext; 175 if ($file =~ s/\.(exe|cmd)\z//) { 176 $ext = $1; 177 178 # skip executable files with names too similar 179 next if -x $file; 180 $file .= '.' . $ext; 181 182 } else { 183 unless (defined $noext) { 184 $noext = $file; 185 $found++; 186 } 187 next; 188 } 189 190 unless (defined $exe) { 191 if ($ext eq 'exe') { 192 $exe = $file; 193 $found++; 194 next; 195 } 196 } 197 unless (defined $cmd) { 198 if ($ext eq 'cmd') { 199 $cmd = $file; 200 $found++; 201 next; 202 } 203 } 204 } 205 last if $found == 4; 206 } 207 last if $found == 4; 208 } 209 210 SKIP: { 211 skip('No appropriate directory found', 1) unless defined $dir; 212 is( ExtUtils::MM_OS2->maybe_command( $dir ), undef, 213 'maybe_command() should ignore directories' ); 214 } 215 216 SKIP: { 217 skip('No non-exension command found', 1) unless defined $noext; 218 is( ExtUtils::MM_OS2->maybe_command( $noext ), $noext, 219 'maybe_command() should find executable lacking file extension' ); 220 } 221 222 SKIP: { 223 skip('No .exe command found', 1) unless defined $exe; 224 (my $noexe = $exe) =~ s/\.exe\z//; 225 is( ExtUtils::MM_OS2->maybe_command( $noexe ), $exe, 226 'maybe_command() should find .exe file lacking extension' ); 227 } 228 229 SKIP: { 230 skip('No .cmd command found', 1) unless defined $cmd; 231 (my $nocmd = $cmd) =~ s/\.cmd\z//; 232 is( ExtUtils::MM_OS2->maybe_command( $nocmd ), $cmd, 233 'maybe_command() should find .cmd file lacking extension' ); 234 } 235} 236 237# file_name_is_absolute 238ok( ExtUtils::MM_OS2->file_name_is_absolute( 's:/' ), 239 'file_name_is_absolute() should be true for paths with volume and slash' ); 240ok( ExtUtils::MM_OS2->file_name_is_absolute( '\foo' ), 241 '... and for paths with leading slash but no volume' ); 242ok( ! ExtUtils::MM_OS2->file_name_is_absolute( 'arduk' ), 243 '... but not for paths with no leading slash or volume' ); 244 245 246$mm->init_linker; 247 248# PERL_ARCHIVE 249is( $mm->{PERL_ARCHIVE}, '$(PERL_INC)/libperl$(LIB_EXT)', 'PERL_ARCHIVE' ); 250 251# PERL_ARCHIVE_AFTER 252{ 253 my $aout = 0; 254 local *OS2::is_aout; 255 *OS2::is_aout = \$aout; 256 257 $mm->init_linker; 258 isnt( $mm->{PERL_ARCHIVE_AFTER}, '', 259 'PERL_ARCHIVE_AFTER should be empty without $is_aout set' ); 260 $aout = 1; 261 is( $mm->{PERL_ARCHIVE_AFTER}, 262 '$(PERL_INC)/libperl_override$(LIB_EXT)', 263 '... and has libperl_override if it is set' ); 264} 265 266# EXPORT_LIST 267is( $mm->{EXPORT_LIST}, '$(BASEEXT).def', 268 'EXPORT_LIST should add .def to BASEEXT member' ); 269 270END { 271 use File::Path; 272 rmtree('tmp_imp') if -e 'tmp_imp'; 273 unlink 'tmpimp.imp'; 274} 275