[p5sagit/p5-mst-13.2.git] / ext / ExtUtils-MakeMaker / t / MM_OS2.t

#!/usr/bin/perl -w

BEGIN {
    unshift @INC, 't/lib';
}
chdir 't';

use strict;
use Test::More;
if ($^O =~ /os2/i) {
	plan( tests => 32 );
} else {
	plan( skip_all => "This is not 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' );


$mm->init_linker;

# PERL_ARCHIVE
is( $mm->{PERL_ARCHIVE}, '$(PERL_INC)/libperl$(LIB_EXT)', 'PERL_ARCHIVE' );

# PERL_ARCHIVE_AFTER
{
	my $aout = 0;
	local *OS2::is_aout;
	*OS2::is_aout = \$aout;
	
        $mm->init_linker;
	isnt( $mm->{PERL_ARCHIVE_AFTER}, '',
		'PERL_ARCHIVE_AFTER should be empty without $is_aout set' );
	$aout = 1;
	is( $mm->{PERL_ARCHIVE_AFTER}, 
            '$(PERL_INC)/libperl_override$(LIB_EXT)', 
		'... and has libperl_override if it is set' );
}

# EXPORT_LIST
is( $mm->{EXPORT_LIST}, '$(BASEEXT).def', 
	'EXPORT_LIST should add .def to BASEEXT member' );

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