4 if( $ENV{PERL_CORE} ) {
19 plan( skip_all => "This is not OS/2" );
22 # for dlsyms, overridden in tests
24 package ExtUtils::MM_OS2;
25 use subs 'system', 'unlink';
31 use_ok( 'ExtUtils::MM_OS2' );
32 ok( grep( 'ExtUtils::MM_OS2', @MM::ISA),
33 'ExtUtils::MM_OS2 should be parent of MM' );
41 }, 'ExtUtils::MM_OS2');
43 is( $mm->dlsyms(), '',
44 'dlsyms() should return nothing with dynamic flag set' );
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' );
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' );
64 $can_write = open(OUT, '>tmp_imp');
68 skip("Cannot write test files: $!", 7) unless $can_write;
70 $mm->{IMPORTS} = { foo => 'bar' };
73 eval { $mm->dlsyms() };
74 like( $@, qr/Can.t mkdir tmp_imp/,
75 '... should die if directory cannot be made' );
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');
81 $mm->{IMPORTS} = { foo => 'bar.baz' };
83 my @sysfail = ( 1, 0, 1 );
84 my ($sysargs, $unlinked);
86 *ExtUtils::MM_OS2::system = sub {
88 return shift @sysfail;
91 *ExtUtils::MM_OS2::unlink = sub {
95 eval { $mm->dlsyms() };
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' );
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' );
107 # make both syscalls succeed
110 eval { $mm->dlsyms() };
111 is( $@, '', '... should not die if both syscalls succeed' );
118 # avoid "used only once"
119 local *ExtUtils::MM_Unix::static_lib;
120 *ExtUtils::MM_Unix::static_lib = sub {
122 return "\n\ncalled static_lib\n\nline2\nline3\n\nline4";
125 my $args = bless({ IMPORTS => {}, }, 'MM');
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' );
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' );
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' );
151 my ($dir, $noext, $exe, $cmd);
154 my ($curdir, $updir) = (File::Spec->curdir, File::Spec->updir);
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.
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) {
172 next if ( -x $file . '.exe' or -x $file . '.cmd' );
180 if ($file =~ s/\.(exe|cmd)\z//) {
183 # skip executable files with names too similar
188 unless (defined $noext) {
195 unless (defined $exe) {
202 unless (defined $cmd) {
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' );
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' );
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' );
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' );
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' );
254 is( $mm->{PERL_ARCHIVE}, '$(PERL_INC)/libperl$(LIB_EXT)', 'PERL_ARCHIVE' );
260 *OS2::is_aout = \$aout;
263 isnt( $mm->{PERL_ARCHIVE_AFTER}, '',
264 'PERL_ARCHIVE_AFTER should be empty without $is_aout set' );
266 is( $mm->{PERL_ARCHIVE_AFTER}, '$(PERL_INC)/libperl_override$(LIB_EXT)',
267 '... and `$(PERL_INC)/libperl_override$(LIB_EXT)\' if it is set' );
271 is( $mm->{EXPORT_LIST}, '$(BASEEXT).def',
272 'EXPORT_LIST should add .def to BASEEXT member' );