Commit | Line | Data |
---|---|---|
39234879 | 1 | #!/usr/bin/perl -w |
ae8b271b | 2 | |
ae8b271b | 3 | BEGIN { |
39234879 MS |
4 | if( $ENV{PERL_CORE} ) { |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
7 | } | |
f6d6199c MS |
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 | ||
ae8b271b | 250 | |
2139708b MS |
251 | $mm->init_linker; |
252 | ||
253 | # PERL_ARCHIVE | |
254 | is( $mm->{PERL_ARCHIVE}, '$(PERL_INC)/libperl$(LIB_EXT)', 'PERL_ARCHIVE' ); | |
255 | ||
256 | # PERL_ARCHIVE_AFTER | |
ae8b271b | 257 | { |
258 | my $aout = 0; | |
259 | local *OS2::is_aout; | |
260 | *OS2::is_aout = \$aout; | |
261 | ||
2139708b MS |
262 | $mm->init_linker; |
263 | isnt( $mm->{PERL_ARCHIVE_AFTER}, '', | |
264 | 'PERL_ARCHIVE_AFTER should be empty without $is_aout set' ); | |
ae8b271b | 265 | $aout = 1; |
18729d3e JH |
266 | is( $mm->{PERL_ARCHIVE_AFTER}, '$(PERL_INC)/libperl_override$(LIB_EXT)', |
267 | '... and `$(PERL_INC)/libperl_override$(LIB_EXT)\' if it is set' ); | |
ae8b271b | 268 | } |
269 | ||
2139708b MS |
270 | # EXPORT_LIST |
271 | is( $mm->{EXPORT_LIST}, '$(BASEEXT).def', | |
272 | 'EXPORT_LIST should add .def to BASEEXT member' ); | |
ae8b271b | 273 | |
274 | END { | |
275 | use File::Path; | |
276 | rmtree('tmp_imp'); | |
277 | unlink 'tmpimp.imp'; | |
278 | } |