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