Commit | Line | Data |
39234879 |
1 | #!/usr/bin/perl -w |
ae8b271b |
2 | |
ae8b271b |
3 | BEGIN { |
39234879 |
4 | if( $ENV{PERL_CORE} ) { |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | } |
f6d6199c |
8 | else { |
9 | unshift @INC, 't/lib'; |
10 | } |
ae8b271b |
11 | } |
39234879 |
12 | chdir 't'; |
ae8b271b |
13 | |
f6d6199c |
14 | use strict; |
ae8b271b |
15 | use Test::More; |
16 | if ($^O =~ /os2/i) { |
17 | plan( tests => 32 ); |
18 | } else { |
91ec65b1 |
19 | plan( skip_all => "This is not OS/2" ); |
ae8b271b |
20 | } |
21 | |
22 | # for dlsyms, overridden in tests |
23 | BEGIN { |
24 | package ExtUtils::MM_OS2; |
25 | use subs 'system', 'unlink'; |
26 | } |
27 | |
28 | # for maybe_command |
29 | use File::Spec; |
30 | |
31 | use_ok( 'ExtUtils::MM_OS2' ); |
32 | ok( grep( 'ExtUtils::MM_OS2', @MM::ISA), |
33 | 'ExtUtils::MM_OS2 should be parent of MM' ); |
34 | |
35 | # dlsyms |
36 | my $mm = bless({ |
37 | SKIPHASH => { |
38 | dynamic => 1 |
39 | }, |
40 | NAME => 'foo:bar::', |
41 | }, 'ExtUtils::MM_OS2'); |
42 | |
43 | is( $mm->dlsyms(), '', |
44 | 'dlsyms() should return nothing with dynamic flag set' ); |
45 | |
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' ); |
54 | |
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' ); |
60 | |
61 | my $can_write; |
62 | { |
63 | local *OUT; |
64 | $can_write = open(OUT, '>tmp_imp'); |
65 | } |
66 | |
67 | SKIP: { |
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 |
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' ); |
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 |
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' ); |
249 | |
250 | # perl_archive |
251 | is( ExtUtils::MM_OS2->perl_archive(), '$(PERL_INC)/libperl$(LIB_EXT)', |
252 | 'perl_archive() should return a static string' ); |
253 | |
254 | # perl_archive_after |
255 | { |
256 | my $aout = 0; |
257 | local *OS2::is_aout; |
258 | *OS2::is_aout = \$aout; |
259 | |
260 | isnt( ExtUtils::MM_OS2->perl_archive_after(), '', |
261 | 'perl_archive_after() should return string without $is_aout set' ); |
262 | $aout = 1; |
263 | is( ExtUtils::MM_OS2->perl_archive_after(), '', |
264 | '... and blank string if it is set' ); |
265 | } |
266 | |
267 | # export_list |
268 | is( ExtUtils::MM_OS2::export_list({ BASEEXT => 'foo' }), 'foo.def', |
269 | 'export_list() should add .def to BASEEXT member' ); |
270 | |
271 | END { |
272 | use File::Path; |
273 | rmtree('tmp_imp'); |
274 | unlink 'tmpimp.imp'; |
275 | } |