lib/ExtUtils/MM_Win32.pm

   1 package ExtUtils::MM_Win32;
   2
   3 use strict;
   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 use Config;
  23 use File::Basename;
  24 use File::Spec;
  25 use ExtUtils::MakeMaker qw( neatvalue );
  26
  27 use vars qw(@ISA $VERSION $BORLAND $GCC $DMAKE $NMAKE);
  28
  29 require ExtUtils::MM_Any;
  30 require ExtUtils::MM_Unix;
  31 @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
  32 $VERSION = '1.08';
  33
  34 $ENV{EMXSHELL} = 'sh'; # to run `commands`
  35
  36 $BORLAND = 1 if $Config{'cc'} =~ /^bcc/i;
  37 $GCC     = 1 if $Config{'cc'} =~ /^gcc/i;
  38 $DMAKE = 1 if $Config{'make'} =~ /^dmake/i;
  39 $NMAKE = 1 if $Config{'make'} =~ /^nmake/i;
  40
  41
  42 =head2 Overridden methods
  43
  44 =over 4
  45
  46 =item B<dlsyms>
  47
  48 =cut
  49
  50 sub dlsyms {
  51     my($self,%attribs) = @_;
  52
  53     my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
  54     my($vars)  = $attribs{DL_VARS} || $self->{DL_VARS} || [];
  55     my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
  56     my($imports)  = $attribs{IMPORTS} || $self->{IMPORTS} || {};
  57     my(@m);
  58
  59     if (not $self->{SKIPHASH}{'dynamic'}) {
  60         push(@m,"
  61 $self->{BASEEXT}.def: Makefile.PL
  62 ",
  63      q! $(PERLRUN) -MExtUtils::Mksymlists \\
  64      -e "Mksymlists('NAME'=>\"!, $self->{NAME},
  65      q!\", 'DLBASE' => '!,$self->{DLBASE},
  66      # The above two lines quoted differently to work around
  67      # a bug in the 4DOS/4NT command line interpreter.  The visible
  68      # result of the bug was files named q('extension_name',) *with the
  69      # single quotes and the comma* in the extension build directories.
  70      q!', 'DL_FUNCS' => !,neatvalue($funcs),
  71      q!, 'FUNCLIST' => !,neatvalue($funclist),
  72      q!, 'IMPORTS' => !,neatvalue($imports),
  73      q!, 'DL_VARS' => !, neatvalue($vars), q!);"
  74 !);
  75     }
  76     join('',@m);
  77 }
  78
  79 =item replace_manpage_separator
  80
  81 Changes the path separator with .
  82
  83 =cut
  84
  85 sub replace_manpage_separator {
  86     my($self,$man) = @_;
  87     $man =~ s,/+,.,g;
  88     $man;
  89 }
  90
  91
  92 =item B<maybe_command>
  93
  94 Since Windows has nothing as simple as an executable bit, we check the
  95 file extension.
  96
  97 The PATHEXT env variable will be used to get a list of extensions that
  98 might indicate a command, otherwise .com, .exe, .bat and .cmd will be
  99 used by default.
 100
 101 =cut
 102
 103 sub maybe_command {
 104     my($self,$file) = @_;
 105     my @e = exists($ENV{'PATHEXT'})
 106           ? split(/;/, $ENV{PATHEXT})
 107           : qw(.com .exe .bat .cmd);
 108     my $e = '';
 109     for (@e) { $e .= "\Q$_\E|" }
 110     chop $e;
 111     # see if file ends in one of the known extensions
 112     if ($file =~ /($e)$/i) {
 113         return $file if -e $file;
 114     }
 115     else {
 116         for (@e) {
 117             return "$file$_" if -e "$file$_";
 118         }
 119     }
 120     return;
 121 }
 122
 123
 124 =item B<find_tests>
 125
 126 The Win9x shell does not expand globs and I'll play it safe and assume
 127 other Windows variants don't either.
 128
 129 So we do it for them.
 130
 131 =cut
 132
 133 sub find_tests {
 134     return join(' ', <t\\*.t>);
 135 }
 136
 137
 138 =item B<init_DIRFILESEP>
 139
 140 Using \ for Windows.
 141
 142 =cut
 143
 144 sub init_DIRFILESEP {
 145     my($self) = shift;
 146
 147     # The ^ makes sure its not interpreted as an escape in nmake
 148     $self->{DIRFILESEP} = $NMAKE ? '^\\' :
 149                           $DMAKE ? '\\\\'
 150                                  : '\\';
 151 }
 152
 153 =item B<init_others>
 154
 155 Override some of the Unix specific commands with portable
 156 ExtUtils::Command ones.
 157
 158 Also provide defaults for LD and AR in case the %Config values aren't
 159 set.
 160
 161 LDLOADLIBS's default is changed to $Config{libs}.
 162
 163 Adjustments are made for Borland's quirks needing -L to come first.
 164
 165 =cut
 166
 167 sub init_others {
 168     my ($self) = @_;
 169
 170     # Used in favor of echo because echo won't strip quotes. :(
 171     $self->{ECHO}     ||= $self->oneliner('print qq{@ARGV}', ['-l']);
 172     $self->{ECHO_N}   ||= $self->oneliner('print qq{@ARGV}');
 173
 174     $self->{TOUCH}    ||= '$(PERLRUN) -MExtUtils::Command -e touch';
 175     $self->{CHMOD}    ||= '$(PERLRUN) -MExtUtils::Command -e chmod';
 176     $self->{CP}       ||= '$(PERLRUN) -MExtUtils::Command -e cp';
 177     $self->{RM_F}     ||= '$(PERLRUN) -MExtUtils::Command -e rm_f';
 178     $self->{RM_RF}    ||= '$(PERLRUN) -MExtUtils::Command -e rm_rf';
 179     $self->{MV}       ||= '$(PERLRUN) -MExtUtils::Command -e mv';
 180     $self->{NOOP}     ||= 'rem';
 181     $self->{TEST_F}   ||= '$(PERLRUN) -MExtUtils::Command -e test_f';
 182     $self->{DEV_NULL} ||= '> NUL';
 183
 184     # technically speaking, these should be in init_main()
 185     $self->{LD}     ||= $Config{ld} || 'link';
 186     $self->{AR}     ||= $Config{ar} || 'lib';
 187
 188     $self->SUPER::init_others;
 189
 190     # Setting SHELL from $Config{sh} can break dmake.  Its ok without it.
 191     delete $self->{SHELL};
 192
 193     $self->{LDLOADLIBS} ||= $Config{libs};
 194     # -Lfoo must come first for Borland, so we put it in LDDLFLAGS
 195     if ($BORLAND) {
 196         my $libs = $self->{LDLOADLIBS};
 197         my $libpath = '';
 198         while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
 199             $libpath .= ' ' if length $libpath;
 200             $libpath .= $1;
 201         }
 202         $self->{LDLOADLIBS} = $libs;
 203         $self->{LDDLFLAGS} ||= $Config{lddlflags};
 204         $self->{LDDLFLAGS} .= " $libpath";
 205     }
 206
 207     return 1;
 208 }
 209
 210
 211 =item init_platform (o)
 212
 213 Add MM_Win32_VERSION.
 214
 215 =item platform_constants (o)
 216
 217 =cut
 218
 219 sub init_platform {
 220     my($self) = shift;
 221
 222     $self->{MM_Win32_VERSION} = $VERSION;
 223 }
 224
 225 sub platform_constants {
 226     my($self) = shift;
 227     my $make_frag = '';
 228
 229     foreach my $macro (qw(MM_Win32_VERSION))
 230     {
 231         next unless defined $self->{$macro};
 232         $make_frag .= "$macro = $self->{$macro}\n";
 233     }
 234
 235     return $make_frag;
 236 }
 237
 238
 239 =item special_targets (o)
 240
 241 Add .USESHELL target for dmake.
 242
 243 =cut
 244
 245 sub special_targets {
 246     my($self) = @_;
 247
 248     my $make_frag = $self->SUPER::special_targets;
 249
 250     $make_frag .= <<'MAKE_FRAG' if $DMAKE;
 251 .USESHELL :
 252 MAKE_FRAG
 253
 254     return $make_frag;
 255 }
 256
 257
 258 =item static_lib (o)
 259
 260 Changes how to run the linker.
 261
 262 The rest is duplicate code from MM_Unix.  Should move the linker code
 263 to its own method.
 264
 265 =cut
 266
 267 sub static_lib {
 268     my($self) = @_;
 269     return '' unless $self->has_link_code;
 270
 271     my(@m);
 272     push(@m, <<'END');
 273 $(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DIRFILESEP).exists
 274         $(RM_RF) $@
 275 END
 276
 277     # If this extension has its own library (eg SDBM_File)
 278     # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
 279     push @m, <<'MAKE_FRAG' if $self->{MYEXTLIB};
 280         $(CP) $(MYEXTLIB) $@
 281 MAKE_FRAG
 282
 283     push @m,
 284 q{      $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
 285                           : ($GCC ? '-ru $@ $(OBJECT)'
 286                                   : '-out:$@ $(OBJECT)')).q{
 287         $(CHMOD) $(PERM_RWX) $@
 288         $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
 289 };
 290
 291     # Old mechanism - still available:
 292     push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
 293         $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
 294 MAKE_FRAG
 295
 296     push @m, "\n", $self->dir_target('$(INST_ARCHAUTODIR)');
 297     join('', @m);
 298 }
 299
 300
 301 =item dynamic_lib (o)
 302
 303 Complicated stuff for Win32 that I don't understand. :(
 304
 305 =cut
 306
 307 sub dynamic_lib {
 308     my($self, %attribs) = @_;
 309     return '' unless $self->needs_linking(); #might be because of a subdir
 310
 311     return '' unless $self->has_link_code;
 312
 313     my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
 314     my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
 315     my($ldfrom) = '$(LDFROM)';
 316     my(@m);
 317
 318 # one thing for GCC/Mingw32:
 319 # we try to overcome non-relocateable-DLL problems by generating
 320 #    a (hopefully unique) image-base from the dll's name
 321 # -- BKS, 10-19-1999
 322     if ($GCC) {
 323         my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT};
 324         $dllname =~ /(....)(.{0,4})/;
 325         my $baseaddr = unpack("n", $1 ^ $2);
 326         $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr);
 327     }
 328
 329     push(@m,'
 330 # This section creates the dynamically loadable $(INST_DYNAMIC)
 331 # from $(OBJECT) and possibly $(MYEXTLIB).
 332 OTHERLDFLAGS = '.$otherldflags.'
 333 INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
 334
 335 $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DIRFILESEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
 336 ');
 337     if ($GCC) {
 338       push(@m,
 339        q{       dlltool --def $(EXPORT_LIST) --output-exp dll.exp
 340         $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
 341         dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
 342         $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp });
 343     } elsif ($BORLAND) {
 344       push(@m,
 345        q{       $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,}
 346        .($DMAKE ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) }
 347                  .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)}
 348                 : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) }
 349                  .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))})
 350        .q{,$(RESFILES)});
 351     } else {    # VC
 352       push(@m,
 353        q{       $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
 354       .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)});
 355     }
 356     push @m, '
 357         $(CHMOD) $(PERM_RWX) $@
 358 ';
 359
 360     push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
 361     join('',@m);
 362 }
 363
 364 =item clean
 365
 366 Clean out some extra dll.{base,exp} files which might be generated by
 367 gcc.  Otherwise, take out all *.pdb files.
 368
 369 =cut
 370
 371 sub clean
 372 {
 373     my ($self) = shift;
 374     my $s = $self->SUPER::clean(@_);
 375     my $clean = $GCC ? 'dll.base dll.exp' : '*.pdb';
 376     $s .= <<END;
 377 clean ::
 378         -\$(RM_F) $clean
 379
 380 END
 381     return $s;
 382 }
 383
 384 =item init_linker
 385
 386 =cut
 387
 388 sub init_linker {
 389     my $self = shift;
 390
 391     $self->{PERL_ARCHIVE}       = "\$(PERL_INC)\\$Config{libperl}";
 392     $self->{PERL_ARCHIVE_AFTER} = '';
 393     $self->{EXPORT_LIST}        = '$(BASEEXT).def';
 394 }
 395
 396
 397 =item perl_script
 398
 399 Checks for the perl program under several common perl extensions.
 400
 401 =cut
 402
 403 sub perl_script {
 404     my($self,$file) = @_;
 405     return $file if -r $file && -f _;
 406     return "$file.pl"  if -r "$file.pl" && -f _;
 407     return "$file.plx" if -r "$file.plx" && -f _;
 408     return "$file.bat" if -r "$file.bat" && -f _;
 409     return;
 410 }
 411
 412
 413 =item xs_o (o)
 414
 415 This target is stubbed out.  Not sure why.
 416
 417 =cut
 418
 419 sub xs_o {
 420     return ''
 421 }
 422
 423
 424 =item pasthru (o)
 425
 426 All we send is -nologo to nmake to prevent it from printing its damned
 427 banner.
 428
 429 =cut
 430
 431 sub pasthru {
 432     my($self) = shift;
 433     my $pasthru = $self->SUPER::pasthru();
 434     $pasthru =~ s/PASTHRU\s*=\s*/PASTHRU = -nologo / if $NMAKE;
 435     return $pasthru;
 436  }
 437
 438
 439 =item oneliner (o)
 440
 441 These are based on what command.com does on Win98.  They may be wrong
 442 for other Windows shells, I don't know.
 443
 444 =cut
 445
 446 sub oneliner {
 447     my($self, $cmd, $switches) = @_;
 448     $switches = [] unless defined $switches;
 449
 450     # Strip leading and trailing newlines
 451     $cmd =~ s{^\n+}{};
 452     $cmd =~ s{\n+$}{};
 453
 454     $cmd = $self->quote_literal($cmd);
 455     $cmd = $self->escape_newlines($cmd);
 456
 457     $switches = join ' ', @$switches;
 458
 459     return qq{\$(PERLRUN) $switches -e $cmd};
 460 }
 461
 462
 463 sub quote_literal {
 464     my($self, $text) = @_;
 465
 466     # I don't know if this is correct, but it seems to work on
 467     # Win98's command.com
 468     $text =~ s{"}{\\"}g;
 469
 470     # dmake eats '{' inside double quotes and leaves alone { outside double
 471     # quotes; however it transforms {{ into { either inside and outside double
 472     # quotes.  It also translates }} into }.  The escaping below is not
 473     # 100% correct.
 474     if( $DMAKE ) {
 475         $text =~ s/{/{{/g;
 476         $text =~ s/}}/}}}/g;
 477     }
 478
 479     return qq{"$text"};
 480 }
 481
 482
 483 sub escape_newlines {
 484     my($self, $text) = @_;
 485
 486     # Escape newlines
 487     $text =~ s{\n}{\\\n}g;
 488
 489     return $text;
 490 }
 491
 492
 493 =item max_exec_len
 494
 495 Using 31K, a safe number gotten from Windows 2000.
 496
 497 =cut
 498
 499 sub max_exec_len {
 500     my $self = shift;
 501
 502     return $self->{_MAX_EXEC_LEN} ||= 31 * 1024;
 503 }
 504
 505
 506 =item os_flavor
 507
 508 Windows is Win32.
 509
 510 =cut
 511
 512 sub os_flavor {
 513     return('Win32');
 514 }
 515
 516
 517 1;
 518 __END__
 519
 520 =back
 521
 522 =cut
 523
 524