lib/ExtUtils/t/MM_OS2.t

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