File Coverage

lib/ExtUtils/MM_Win32.pm
Criterion Covered Total %
statement 30 180 16.7
branch 4 86 4.7
condition 1 51 2.0
subroutine 8 33 24.2
total 43 350 12.3


line stmt bran cond sub time code
1           package ExtUtils::MM_Win32;
2            
3 2     2 23283 use strict;
  2       5  
  2       90  
4            
5            
6           =head1 NAME
7            
8           ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
9            
10           =head1 SYNOPSIS
11            
12           use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed
13            
14           =head1 DESCRIPTION
15            
16           See ExtUtils::MM_Unix for a documentation of the methods provided
17           there. This package overrides the implementation of these methods, not
18           the semantics.
19            
20           =cut
21            
22 2     2 286 use ExtUtils::MakeMaker::Config;
  2       480  
  2       21  
23 2     2 158 use File::Basename;
  2       5  
  2       202  
24 2     2 12 use File::Spec;
  2       5  
  2       64  
25 2     2 849 use ExtUtils::MakeMaker qw( neatvalue );
  2       63249  
  2       7592  
26            
27           require ExtUtils::MM_Any;
28           require ExtUtils::MM_Unix;
29           our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
30           our $VERSION = '6.74';
31            
32           $ENV{EMXSHELL} = 'sh'; # to run `commands`
33            
34           my ( $BORLAND, $GCC, $DLLTOOL ) = _identify_compiler_environment( \%Config );
35            
36           sub _identify_compiler_environment {
37 2     2 6 my ( $config ) = @_;
38            
39 2 50     17 my $BORLAND = $config->{cc} =~ /^bcc/i ? 1 : 0;
40 2 50     10 my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0;
41 2   50   24 my $DLLTOOL = $config->{dlltool} || 'dlltool';
42            
43 2       12 return ( $BORLAND, $GCC, $DLLTOOL );
44           }
45            
46            
47           =head2 Overridden methods
48            
49           =over 4
50            
51           =item B
52            
53           =cut
54            
55           sub dlsyms {
56 0     0 0 my($self,%attribs) = @_;
57            
58 0   0   0 my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
59 0   0   0 my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
60 0   0   0 my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
61 0   0   0 my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
62 0       0 my(@m);
63            
64 0 0     0 if (not $self->{SKIPHASH}{'dynamic'}) {
65 0       0 push(@m,"
66           $self->{BASEEXT}.def: Makefile.PL
67           ",
68           q! $(PERLRUN) -MExtUtils::Mksymlists \\
69           -e "Mksymlists('NAME'=>\"!, $self->{NAME},
70           q!\", 'DLBASE' => '!,$self->{DLBASE},
71           # The above two lines quoted differently to work around
72           # a bug in the 4DOS/4NT command line interpreter. The visible
73           # result of the bug was files named q('extension_name',) *with the
74           # single quotes and the comma* in the extension build directories.
75           q!', 'DL_FUNCS' => !,neatvalue($funcs),
76           q!, 'FUNCLIST' => !,neatvalue($funclist),
77           q!, 'IMPORTS' => !,neatvalue($imports),
78           q!, 'DL_VARS' => !, neatvalue($vars), q!);"
79           !);
80           }
81 0       0 join('',@m);
82           }
83            
84           =item replace_manpage_separator
85            
86           Changes the path separator with .
87            
88           =cut
89            
90           sub replace_manpage_separator {
91 0     0 0 my($self,$man) = @_;
92 0       0 $man =~ s,/+,.,g;
93 0       0 $man;
94           }
95            
96            
97           =item B
98            
99           Since Windows has nothing as simple as an executable bit, we check the
100           file extension.
101            
102           The PATHEXT env variable will be used to get a list of extensions that
103           might indicate a command, otherwise .com, .exe, .bat and .cmd will be
104           used by default.
105            
106           =cut
107            
108           sub maybe_command {
109 0     0 0 my($self,$file) = @_;
110 0 0     0 my @e = exists($ENV{'PATHEXT'})
111           ? split(/;/, $ENV{PATHEXT})
112           : qw(.com .exe .bat .cmd);
113 0       0 my $e = '';
114 0       0 for (@e) { $e .= "\Q$_\E|" }
  0       0  
115 0       0 chop $e;
116           # see if file ends in one of the known extensions
117 0 0     0 if ($file =~ /($e)$/i) {
118 0 0     0 return $file if -e $file;
119           }
120           else {
121 0       0 for (@e) {
122 0 0     0 return "$file$_" if -e "$file$_";
123           }
124           }
125 0       0 return;
126           }
127            
128            
129           =item B
130            
131           Using \ for Windows.
132            
133           =cut
134            
135           sub init_DIRFILESEP {
136 0     0 0 my($self) = shift;
137            
138           # The ^ makes sure its not interpreted as an escape in nmake
139 0 0     0 $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' :
    0        
140           $self->is_make_type('dmake') ? '\\\\'
141           : '\\';
142           }
143            
144           =item init_tools
145            
146           Override some of the slower, portable commands with Windows specific ones.
147            
148           =cut
149            
150           sub init_tools {
151 0     0 0 my ($self) = @_;
152            
153 0   0   0 $self->{NOOP} ||= 'rem';
154 0   0   0 $self->{DEV_NULL} ||= '> NUL';
155            
156 0 0 0   0 $self->{FIXIN} ||= $self->{PERL_CORE} ?
157           "\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" :
158           'pl2bat.bat';
159            
160 0       0 $self->SUPER::init_tools;
161            
162           # Setting SHELL from $Config{sh} can break dmake. Its ok without it.
163 0       0 delete $self->{SHELL};
164            
165 0       0 return;
166           }
167            
168            
169           =item init_others
170            
171           Override the default link and compile tools.
172            
173           LDLOADLIBS's default is changed to $Config{libs}.
174            
175           Adjustments are made for Borland's quirks needing -L to come first.
176            
177           =cut
178            
179           sub init_others {
180 0     0 0 my $self = shift;
181            
182 0   0   0 $self->{LD} ||= 'link';
183 0   0   0 $self->{AR} ||= 'lib';
184            
185 0       0 $self->SUPER::init_others;
186            
187 0   0   0 $self->{LDLOADLIBS} ||= $Config{libs};
188           # -Lfoo must come first for Borland, so we put it in LDDLFLAGS
189 0 0     0 if ($BORLAND) {
190 0       0 my $libs = $self->{LDLOADLIBS};
191 0       0 my $libpath = '';
192 0       0 while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
193 0 0     0 $libpath .= ' ' if length $libpath;
194 0       0 $libpath .= $1;
195           }
196 0       0 $self->{LDLOADLIBS} = $libs;
197 0   0   0 $self->{LDDLFLAGS} ||= $Config{lddlflags};
198 0       0 $self->{LDDLFLAGS} .= " $libpath";
199           }
200            
201 0       0 return;
202           }
203            
204            
205           =item init_platform
206            
207           Add MM_Win32_VERSION.
208            
209           =item platform_constants
210            
211           =cut
212            
213           sub init_platform {
214 0     0 0 my($self) = shift;
215            
216 0       0 $self->{MM_Win32_VERSION} = $VERSION;
217            
218 0       0 return;
219           }
220            
221           sub platform_constants {
222 0     0 0 my($self) = shift;
223 0       0 my $make_frag = '';
224            
225 0       0 foreach my $macro (qw(MM_Win32_VERSION))
226           {
227 0 0     0 next unless defined $self->{$macro};
228 0       0 $make_frag .= "$macro = $self->{$macro}\n";
229           }
230            
231 0       0 return $make_frag;
232           }
233            
234            
235           =item constants
236            
237           Add MAXLINELENGTH for dmake before all the constants are output.
238            
239           =cut
240            
241           sub constants {
242 0     0 0 my $self = shift;
243            
244 0       0 my $make_text = $self->SUPER::constants;
245 0 0     0 return $make_text unless $self->is_make_type('dmake');
246            
247           # dmake won't read any single "line" (even those with escaped newlines)
248           # larger than a certain size which can be as small as 8k. PM_TO_BLIB
249           # on large modules like DateTime::TimeZone can create lines over 32k.
250           # So we'll crank it up to a WHOPPING 64k.
251           #
252           # This has to come here before all the constants and not in
253           # platform_constants which is after constants.
254 0   0   0 my $size = $self->{MAXLINELENGTH} || 800000;
255 0       0 my $prefix = qq{
256           # Get dmake to read long commands like PM_TO_BLIB
257           MAXLINELENGTH = $size
258            
259           };
260            
261 0       0 return $prefix . $make_text;
262           }
263            
264            
265           =item special_targets
266            
267           Add .USESHELL target for dmake.
268            
269           =cut
270            
271           sub special_targets {
272 0     0 0 my($self) = @_;
273            
274 0       0 my $make_frag = $self->SUPER::special_targets;
275            
276 0 0     0 $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake');
277           .USESHELL :
278           MAKE_FRAG
279            
280 0       0 return $make_frag;
281           }
282            
283            
284           =item static_lib
285            
286           Changes how to run the linker.
287            
288           The rest is duplicate code from MM_Unix. Should move the linker code
289           to its own method.
290            
291           =cut
292            
293           sub static_lib {
294 0     0 0 my($self) = @_;
295 0 0     0 return '' unless $self->has_link_code;
296            
297 0       0 my(@m);
298 0       0 push(@m, <<'END');
299           $(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
300           $(RM_RF) $@
301           END
302            
303           # If this extension has its own library (eg SDBM_File)
304           # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
305 0 0     0 push @m, <<'MAKE_FRAG' if $self->{MYEXTLIB};
306           $(CP) $(MYEXTLIB) $@
307           MAKE_FRAG
308            
309 0 0     0 push @m,
    0        
310           q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
311           : ($GCC ? '-ru $@ $(OBJECT)'
312           : '-out:$@ $(OBJECT)')).q{
313           $(CHMOD) $(PERM_RWX) $@
314           $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
315           };
316            
317           # Old mechanism - still available:
318 0 0 0   0 push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
319           $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
320           MAKE_FRAG
321            
322 0       0 join('', @m);
323           }
324            
325            
326           =item dynamic_lib
327            
328           Complicated stuff for Win32 that I don't understand. :(
329            
330           =cut
331            
332           sub dynamic_lib {
333 0     0 0 my($self, %attribs) = @_;
334 0 0     0 return '' unless $self->needs_linking(); #might be because of a subdir
335            
336 0 0     0 return '' unless $self->has_link_code;
337            
338 0   0   0 my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
339 0   0   0 my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
340 0       0 my($ldfrom) = '$(LDFROM)';
341 0       0 my(@m);
342            
343 0       0 push(@m,'
344           # This section creates the dynamically loadable $(INST_DYNAMIC)
345           # from $(OBJECT) and possibly $(MYEXTLIB).
346           OTHERLDFLAGS = '.$otherldflags.'
347           INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
348            
349           $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
350           ');
351 0 0     0 if ($GCC) {
    0        
352 0       0 push(@m,
353           q{ }.$DLLTOOL.q{ --def $(EXPORT_LIST) --output-exp dll.exp
354           $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
355           }.$DLLTOOL.q{ --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
356           $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp });
357           } elsif ($BORLAND) {
358 0 0     0 push(@m,
359           q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,}
360           .($self->is_make_type('dmake')
361           ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) }
362           .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)}
363           : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) }
364           .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))})
365           .q{,$(RESFILES)});
366           } else { # VC
367 0       0 push(@m,
368           q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
369           .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)});
370            
371           # Embed the manifest file if it exists
372 0       0 push(@m, q{
373           if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
374           if exist $@.manifest del $@.manifest});
375           }
376 0       0 push @m, '
377           $(CHMOD) $(PERM_RWX) $@
378           ';
379            
380 0       0 join('',@m);
381           }
382            
383           =item extra_clean_files
384            
385           Clean out some extra dll.{base,exp} files which might be generated by
386           gcc. Otherwise, take out all *.pdb files.
387            
388           =cut
389            
390           sub extra_clean_files {
391 0     0 0 my $self = shift;
392            
393 0 0     0 return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb');
394           }
395            
396           =item init_linker
397            
398           =cut
399            
400           sub init_linker {
401 0     0 0 my $self = shift;
402            
403 0       0 $self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}";
404 0       0 $self->{PERL_ARCHIVE_AFTER} = '';
405 0       0 $self->{EXPORT_LIST} = '$(BASEEXT).def';
406           }
407            
408            
409           =item perl_script
410            
411           Checks for the perl program under several common perl extensions.
412            
413           =cut
414            
415           sub perl_script {
416 0     0 0 my($self,$file) = @_;
417 0 0 0   0 return $file if -r $file && -f _;
418 0 0 0   0 return "$file.pl" if -r "$file.pl" && -f _;
419 0 0 0   0 return "$file.plx" if -r "$file.plx" && -f _;
420 0 0 0   0 return "$file.bat" if -r "$file.bat" && -f _;
421 0       0 return;
422           }
423            
424            
425           =item xs_o
426            
427           This target is stubbed out. Not sure why.
428            
429           =cut
430            
431           sub xs_o {
432 0     0 0 return ''
433           }
434            
435            
436           =item pasthru
437            
438           All we send is -nologo to nmake to prevent it from printing its damned
439           banner.
440            
441           =cut
442            
443           sub pasthru {
444 0     0 0 my($self) = shift;
445 0 0     0 return "PASTHRU = " . ($self->is_make_type('nmake') ? "-nologo" : "");
446           }
447            
448            
449           =item arch_check (override)
450            
451           Normalize all arguments for consistency of comparison.
452            
453           =cut
454            
455           sub arch_check {
456 0     0 0 my $self = shift;
457            
458           # Win32 is an XS module, minperl won't have it.
459           # arch_check() is not critical, so just fake it.
460 0 0     0 return 1 unless $self->can_load_xs;
461 0       0 return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_);
  0       0  
462           }
463            
464           sub _normalize_path_name {
465 0     0 0 my $self = shift;
466 0       0 my $file = shift;
467            
468 0       0 require Win32;
469 0       0 my $short = Win32::GetShortPathName($file);
470 0 0     0 return defined $short ? lc $short : lc $file;
471           }
472            
473            
474           =item oneliner
475            
476           These are based on what command.com does on Win98. They may be wrong
477           for other Windows shells, I don't know.
478            
479           =cut
480            
481           sub oneliner {
482 0     0 0 my($self, $cmd, $switches) = @_;
483 0 0     0 $switches = [] unless defined $switches;
484            
485           # Strip leading and trailing newlines
486 0       0 $cmd =~ s{^\n+}{};
487 0       0 $cmd =~ s{\n+$}{};
488            
489 0       0 $cmd = $self->quote_literal($cmd);
490 0       0 $cmd = $self->escape_newlines($cmd);
491            
492 0       0 $switches = join ' ', @$switches;
493            
494 0       0 return qq{\$(ABSPERLRUN) $switches -e $cmd --};
495           }
496            
497            
498           sub quote_literal {
499 0     0 0 my($self, $text, $opts) = @_;
500 0 0     0 $opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
501            
502           # See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP
503            
504           # Apply the Microsoft C/C++ parsing rules
505 0       0 $text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\"
506 0       0 $text =~ s{(? \\\"
507 0       0 $text =~ s{(? \"
508 0 0     0 $text = qq{"$text"} if $text =~ /[ \t]/;
509            
510           # Apply the Command Prompt parsing rules (cmd.exe)
511 0       0 my @text = split /("[^"]*")/, $text;
512           # We should also escape parentheses, but it breaks one-liners containing
513           # $(MACRO)s in makefiles.
514 0       0 s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text;
  0       0  
515 0       0 $text = join('', @text);
516            
517           # dmake expands {{ to { and }} to }.
518 0 0     0 if( $self->is_make_type('dmake') ) {
519 0       0 $text =~ s/{/{{/g;
520 0       0 $text =~ s/}/}}/g;
521           }
522            
523 0 0     0 $text = $opts->{allow_variables}
524           ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
525            
526 0       0 return $text;
527           }
528            
529            
530           sub escape_newlines {
531 0     0 0 my($self, $text) = @_;
532            
533           # Escape newlines
534 0       0 $text =~ s{\n}{\\\n}g;
535            
536 0       0 return $text;
537           }
538            
539            
540           =item cd
541            
542           dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It
543           wants:
544            
545           cd dir1\dir2
546           command
547           another_command
548           cd ..\..
549            
550           =cut
551            
552           sub cd {
553 2     2 152682 my($self, $dir, @cmds) = @_;
554            
555 2 100     14 return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake');
556            
557 1       65 my $cmd = join "\n\t", map "$_", @cmds;
558            
559 1       24 my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir));
  2       34  
560            
561           # No leading tab and no trailing newline makes for easier embedding.
562 1       8 my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs;
563           cd %s
564           %s
565           cd %s
566           MAKE_FRAG
567            
568 1       5 chomp $make_frag;
569            
570 1       9 return $make_frag;
571           }
572            
573            
574           =item max_exec_len
575            
576           nmake 1.50 limits command length to 2048 characters.
577            
578           =cut
579            
580           sub max_exec_len {
581 0     0 0 my $self = shift;
582            
583 0   0   0 return $self->{_MAX_EXEC_LEN} ||= 2 * 1024;
584           }
585            
586            
587           =item os_flavor
588            
589           Windows is Win32.
590            
591           =cut
592            
593           sub os_flavor {
594 0     0 0 return('Win32');
595           }
596            
597            
598           =item cflags
599            
600           Defines the PERLDLL symbol if we are configured for static building since all
601           code destined for the perl5xx.dll must be compiled with the PERLDLL symbol
602           defined.
603            
604           =cut
605            
606           sub cflags {
607 0     0 0 my($self,$libperl)=@_;
608 0 0     0 return $self->{CFLAGS} if $self->{CFLAGS};
609 0 0     0 return '' unless $self->needs_linking();
610            
611 0       0 my $base = $self->SUPER::cflags($libperl);
612 0       0 foreach (split /\n/, $base) {
613 0 0     0 /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
614           };
615 0 0     0 $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static');
616            
617 0       0 return $self->{CFLAGS} = qq{
618           CCFLAGS = $self->{CCFLAGS}
619           OPTIMIZE = $self->{OPTIMIZE}
620           PERLTYPE = $self->{PERLTYPE}
621           };
622            
623           }
624            
625           sub is_make_type {
626 2     2 6 my($self, $type) = @_;
627 2       8 return !! ($self->make =~ /\b$type(?:\.exe)?$/);
628           }
629            
630           1;
631           __END__