lib/ExtUtils/t/MM_OS2.t

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