Re: lib, ext, cpan and dist [PATCH] (take 2)
[perl.git] / ext / ExtUtils-MakeMaker / t / MM_OS2.t
1 #!/usr/bin/perl -w
2
3 BEGIN {
4     unshift @INC, 't/lib';
5 }
6 chdir 't';
7
8 use strict;
9 use Test::More;
10 if ($^O =~ /os2/i) {
11         plan( tests => 32 );
12 } else {
13         plan( skip_all => "This is not OS/2" );
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
244
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
251 {
252         my $aout = 0;
253         local *OS2::is_aout;
254         *OS2::is_aout = \$aout;
255         
256         $mm->init_linker;
257         isnt( $mm->{PERL_ARCHIVE_AFTER}, '',
258                 'PERL_ARCHIVE_AFTER should be empty without $is_aout set' );
259         $aout = 1;
260         is( $mm->{PERL_ARCHIVE_AFTER}, 
261             '$(PERL_INC)/libperl_override$(LIB_EXT)', 
262                 '... and has libperl_override if it is set' );
263 }
264
265 # EXPORT_LIST
266 is( $mm->{EXPORT_LIST}, '$(BASEEXT).def', 
267         'EXPORT_LIST should add .def to BASEEXT member' );
268
269 END {
270         use File::Path;
271         rmtree('tmp_imp');
272         unlink 'tmpimp.imp';
273 }