1#!/usr/bin/perl -w
2
3BEGIN {
4    if( $ENV{PERL_CORE} ) {
5        chdir 't' if -d 't';
6        @INC = '../lib';
7    }
8    else {
9        unshift @INC, 't/lib';
10    }
11}
12chdir 't';
13
14use strict;
15use Test::More;
16if ($^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
23BEGIN {
24	package ExtUtils::MM_OS2;
25	use subs 'system', 'unlink';
26}
27
28# for maybe_command
29use File::Spec;
30
31use_ok( 'ExtUtils::MM_OS2' );
32ok( grep( 'ExtUtils::MM_OS2',  @MM::ISA),
33	'ExtUtils::MM_OS2 should be parent of MM' );
34
35# dlsyms
36my $mm = bless({
37	SKIPHASH => {
38		dynamic => 1
39	},
40	NAME => 'foo:bar::',
41}, 'ExtUtils::MM_OS2');
42
43is( $mm->dlsyms(), '',
44	'dlsyms() should return nothing with dynamic flag set' );
45
46$mm->{BASEEXT} = 'baseext';
47delete $mm->{SKIPHASH};
48my $res = $mm->dlsyms();
49like( $res, qr/baseext\.def: Makefile/,
50	'... without flag, should return make targets' );
51like( $res, qr/"DL_FUNCS" => {  }/,
52	'... should provide empty hash refs where necessary' );
53like( $res, qr/"DL_VARS" => \[]/, '... and empty array refs too' );
54
55$mm->{FUNCLIST} = 'funclist';
56$res = $mm->dlsyms( IMPORTS => 'imports' );
57like( $res, qr/"FUNCLIST" => .+funclist/,
58	'... should pick up values from object' );
59like( $res, qr/"IMPORTS" => .+imports/, '... and allow parameter options too' );
60
61my $can_write;
62{
63	local *OUT;
64	$can_write = open(OUT, '>tmp_imp');
65}
66
67SKIP: {
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
144my $sep = '//a///b//c/de';
145is( 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
243ok( ExtUtils::MM_OS2->file_name_is_absolute( 's:/' ),
244	'file_name_is_absolute() should be true for paths with volume and slash' );
245ok( ExtUtils::MM_OS2->file_name_is_absolute( '\foo' ),
246	'... and for paths with leading slash but no volume' );
247ok( ! 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
254is( $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},
267            '$(PERL_INC)/libperl_override$(LIB_EXT)',
268		'... and has libperl_override if it is set' );
269}
270
271# EXPORT_LIST
272is( $mm->{EXPORT_LIST}, '$(BASEEXT).def',
273	'EXPORT_LIST should add .def to BASEEXT member' );
274
275END {
276	use File::Path;
277	rmtree('tmp_imp');
278	unlink 'tmpimp.imp';
279}
280