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