From: chromatic <chromatic@wgz.org>
Date: Thu, 20 Dec 2001 16:09:10 +0000 (-0700)
Subject: Tests for ExtUtils::MM_OS2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ae8b271bc537db16fdadeadaf4b731ebf8380685;p=p5sagit%2Fp5-mst-13.2.git
Tests for ExtUtils::MM_OS2
Message-ID: <20011220230948.18010.qmail@onion.perl.org>
p4raw-id: //depot/perl@13825
---
diff --git a/MANIFEST b/MANIFEST
index 0fa46a2..248cd78 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -948,6 +948,7 @@ lib/ExtUtils/t/Installed.t See if ExtUtils::Installed works
lib/ExtUtils/t/Manifest.t See if ExtUtils::Manifest works
lib/ExtUtils/t/Mkbootstrap.t See if ExtUtils::Mkbootstrap works
lib/ExtUtils/t/MM_Cygwin.t See if ExtUtils::MM_Cygwin works
+lib/ExtUtils/t/MM_OS2.t See if ExtUtils::MM_OS2 works
lib/ExtUtils/t/MM_Unix.t See if ExtUtils::MM_UNIX works
lib/ExtUtils/t/MM_VMS.t See if ExtUtils::MM_VMS works
lib/ExtUtils/t/Packlist.t See if Packlist works
diff --git a/lib/ExtUtils/t/MM_OS2.t b/lib/ExtUtils/t/MM_OS2.t
new file mode 100644
index 0000000..6e8bce9
--- /dev/null
+++ b/lib/ExtUtils/t/MM_OS2.t
@@ -0,0 +1,270 @@
+#!./perl -w
+
+use strict;
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Test::More;
+if ($^O =~ /os2/i) {
+ plan( tests => 32 );
+} else {
+ plan( skip_all => "This does not appear to be OS/2" );
+}
+
+# for dlsyms, overridden in tests
+BEGIN {
+ package ExtUtils::MM_OS2;
+ use subs 'system', 'unlink';
+}
+
+# for maybe_command
+use File::Spec;
+
+use_ok( 'ExtUtils::MM_OS2' );
+ok( grep( 'ExtUtils::MM_OS2', @MM::ISA),
+ 'ExtUtils::MM_OS2 should be parent of MM' );
+
+# dlsyms
+my $mm = bless({
+ SKIPHASH => {
+ dynamic => 1
+ },
+ NAME => 'foo:bar::',
+}, 'ExtUtils::MM_OS2');
+
+is( $mm->dlsyms(), '',
+ 'dlsyms() should return nothing with dynamic flag set' );
+
+$mm->{BASEEXT} = 'baseext';
+delete $mm->{SKIPHASH};
+my $res = $mm->dlsyms();
+like( $res, qr/baseext\.def: Makefile/,
+ '... without flag, should return make targets' );
+like( $res, qr/"DL_FUNCS" => { }/,
+ '... should provide empty hash refs where necessary' );
+like( $res, qr/"DL_VARS" => \[]/, '... and empty array refs too' );
+
+$mm->{FUNCLIST} = 'funclist';
+$res = $mm->dlsyms( IMPORTS => 'imports' );
+like( $res, qr/"FUNCLIST" => .+funclist/,
+ '... should pick up values from object' );
+like( $res, qr/"IMPORTS" => .+imports/, '... and allow parameter options too' );
+
+my $can_write;
+{
+ local *OUT;
+ $can_write = open(OUT, '>tmp_imp');
+}
+
+SKIP: {
+ skip("Cannot write test files: $!", 7) unless $can_write;
+
+ $mm->{IMPORTS} = { foo => 'bar' };
+
+ local $@;
+ eval { $mm->dlsyms() };
+ like( $@, qr/Can.t mkdir tmp_imp/,
+ '... should die if directory cannot be made' );
+
+ unlink('tmp_imp') or skip("Cannot remove test file: $!", 9);
+ eval { $mm->dlsyms() };
+ like( $@, qr/Malformed IMPORT/, 'should die from malformed import symbols');
+
+ $mm->{IMPORTS} = { foo => 'bar.baz' };
+
+ my @sysfail = ( 1, 0, 1 );
+ my ($sysargs, $unlinked);
+
+ *ExtUtils::MM_OS2::system = sub {
+ $sysargs = shift;
+ return shift @sysfail;
+ };
+
+ *ExtUtils::MM_OS2::unlink = sub {
+ $unlinked++;
+ };
+
+ eval { $mm->dlsyms() };
+
+ like( $sysargs, qr/^emximp/, '... should try to call system() though' );
+ like( $@, qr/Cannot make import library/,
+ '... should die if emximp syscall fails' );
+
+ # sysfail is 0 now, call emximp call should succeed
+ eval { $mm->dlsyms() };
+ is( $unlinked, 1, '... should attempt to unlink temp files' );
+ like( $@, qr/Cannot extract import/,
+ '... should die if other syscall fails' );
+
+ # make both syscalls succeed
+ @sysfail = (0, 0);
+ local $@;
+ eval { $mm->dlsyms() };
+ is( $@, '', '... should not die if both syscalls succeed' );
+}
+
+# static_lib
+{
+ my $called = 0;
+
+ # avoid "used only once"
+ local *ExtUtils::MM_Unix::static_lib;
+ *ExtUtils::MM_Unix::static_lib = sub {
+ $called++;
+ return "\n\ncalled static_lib\n\nline2\nline3\n\nline4";
+ };
+
+ my $args = bless({ IMPORTS => {}, }, 'MM');
+
+ # without IMPORTS as a populated hash, there will be no extra data
+ my $ret = ExtUtils::MM_OS2::static_lib( $args );
+ is( $called, 1, 'static_lib() should call parent method' );
+ like( $ret, qr/^called static_lib/m,
+ '... should return parent data unless IMPORTS exists' );
+
+ $args->{IMPORTS} = { foo => 1};
+ $ret = ExtUtils::MM_OS2::static_lib( $args );
+ is( $called, 2, '... should call parent method if extra imports passed' );
+ like( $ret, qr/^called static_lib\n\t\$\(AR\) \$\(AR_STATIC_ARGS\)/m,
+ '... should append make tags to first line from parent method' );
+ like( $ret, qr/\$@\n\n\nline2\nline3\n\nline4/m,
+ '... should include remaining data from parent method' );
+
+}
+
+# replace_manpage_separator
+my $sep = '//a///b//c/de';
+is( ExtUtils::MM_OS2->replace_manpage_separator($sep), '.a.b.c.de',
+ 'replace_manpage_separator() should turn multiple slashes into periods' );
+
+# maybe_command
+{
+ local *DIR;
+ my ($dir, $noext, $exe, $cmd);
+ my $found = 0;
+
+ my ($curdir, $updir) = (File::Spec->curdir, File::Spec->updir);
+
+ # we need:
+ # 1) a directory
+ # 2) an executable file with no extension
+ # 3) an executable file with the .exe extension
+ # 4) an executable file with the .cmd extension
+ # we assume there will be one somewhere in the path
+ # in addition, we need them to be unique enough they do not trip
+ # an earlier file test in maybe_command(). Portability.
+
+ foreach my $path (split(/:/, $ENV{PATH})) {
+ opendir(DIR, $path) or next;
+ while (defined(my $file = readdir(DIR))) {
+ next if $file eq $curdir or $file eq $updir;
+ $file = File::Spec->catfile($path, $file);
+ unless (defined $dir) {
+ if (-d $file) {
+ next if ( -x $file . '.exe' or -x $file . '.cmd' );
+
+ $dir = $file;
+ $found++;
+ }
+ }
+ if (-x $file) {
+ my $ext;
+ if ($file =~ s/\.(exe|cmd)\z//) {
+ $ext = $1;
+
+ # skip executable files with names too similar
+ next if -x $file;
+ $file .= '.' . $ext;
+
+ } else {
+ unless (defined $noext) {
+ $noext = $file;
+ $found++;
+ }
+ next;
+ }
+
+ unless (defined $exe) {
+ if ($ext eq 'exe') {
+ $exe = $file;
+ $found++;
+ next;
+ }
+ }
+ unless (defined $cmd) {
+ if ($ext eq 'cmd') {
+ $cmd = $file;
+ $found++;
+ next;
+ }
+ }
+ }
+ last if $found == 4;
+ }
+ last if $found == 4;
+ }
+
+ SKIP: {
+ skip('No appropriate directory found', 1) unless defined $dir;
+ is( ExtUtils::MM_OS2->maybe_command( $dir ), undef,
+ 'maybe_command() should ignore directories' );
+ }
+
+ SKIP: {
+ skip('No non-exension command found', 1) unless defined $noext;
+ is( ExtUtils::MM_OS2->maybe_command( $noext ), $noext,
+ 'maybe_command() should find executable lacking file extension' );
+ }
+
+ SKIP: {
+ skip('No .exe command found', 1) unless defined $exe;
+ (my $noexe = $exe) =~ s/\.exe\z//;
+ is( ExtUtils::MM_OS2->maybe_command( $noexe ), $exe,
+ 'maybe_command() should find .exe file lacking extension' );
+ }
+
+ SKIP: {
+ skip('No .cmd command found', 1) unless defined $cmd;
+ (my $nocmd = $cmd) =~ s/\.cmd\z//;
+ is( ExtUtils::MM_OS2->maybe_command( $nocmd ), $cmd,
+ 'maybe_command() should find .cmd file lacking extension' );
+ }
+}
+
+# file_name_is_absolute
+ok( ExtUtils::MM_OS2->file_name_is_absolute( 's:/' ),
+ 'file_name_is_absolute() should be true for paths with volume and slash' );
+ok( ExtUtils::MM_OS2->file_name_is_absolute( '\foo' ),
+ '... and for paths with leading slash but no volume' );
+ok( ! ExtUtils::MM_OS2->file_name_is_absolute( 'arduk' ),
+ '... but not for paths with no leading slash or volume' );
+
+# perl_archive
+is( ExtUtils::MM_OS2->perl_archive(), '$(PERL_INC)/libperl$(LIB_EXT)',
+ 'perl_archive() should return a static string' );
+
+# perl_archive_after
+{
+ my $aout = 0;
+ local *OS2::is_aout;
+ *OS2::is_aout = \$aout;
+
+ isnt( ExtUtils::MM_OS2->perl_archive_after(), '',
+ 'perl_archive_after() should return string without $is_aout set' );
+ $aout = 1;
+ is( ExtUtils::MM_OS2->perl_archive_after(), '',
+ '... and blank string if it is set' );
+}
+
+# export_list
+is( ExtUtils::MM_OS2::export_list({ BASEEXT => 'foo' }), 'foo.def',
+ 'export_list() should add .def to BASEEXT member' );
+
+END {
+ use File::Path;
+ rmtree('tmp_imp');
+ unlink 'tmpimp.imp';
+}