1package ExtUtils::MM_VMS; 2 3use strict; 4 5use ExtUtils::MakeMaker::Config; 6require Exporter; 7 8BEGIN { 9 # so we can compile the thing on non-VMS platforms. 10 if( $^O eq 'VMS' ) { 11 require VMS::Filespec; 12 VMS::Filespec->import; 13 } 14} 15 16use File::Basename; 17 18# $Revision can't be on the same line or SVN/K gets confused 19use vars qw($Revision 20 $VERSION @ISA); 21$VERSION = '5.73'; 22 23require ExtUtils::MM_Any; 24require ExtUtils::MM_Unix; 25@ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); 26 27use ExtUtils::MakeMaker qw($Verbose neatvalue); 28$Revision = $ExtUtils::MakeMaker::Revision; 29 30 31=head1 NAME 32 33ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker 34 35=head1 SYNOPSIS 36 37 Do not use this directly. 38 Instead, use ExtUtils::MM and it will figure out which MM_* 39 class to use for you. 40 41=head1 DESCRIPTION 42 43See ExtUtils::MM_Unix for a documentation of the methods provided 44there. This package overrides the implementation of these methods, not 45the semantics. 46 47=head2 Methods always loaded 48 49=over 4 50 51=item wraplist 52 53Converts a list into a string wrapped at approximately 80 columns. 54 55=cut 56 57sub wraplist { 58 my($self) = shift; 59 my($line,$hlen) = ('',0); 60 61 foreach my $word (@_) { 62 # Perl bug -- seems to occasionally insert extra elements when 63 # traversing array (scalar(@array) doesn't show them, but 64 # foreach(@array) does) (5.00307) 65 next unless $word =~ /\w/; 66 $line .= ' ' if length($line); 67 if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } 68 $line .= $word; 69 $hlen += length($word) + 2; 70 } 71 $line; 72} 73 74 75# This isn't really an override. It's just here because ExtUtils::MM_VMS 76# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext() 77# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just 78# mimic inheritance here and hand off to ExtUtils::Liblist::Kid. 79# XXX This hackery will die soon. --Schwern 80sub ext { 81 require ExtUtils::Liblist::Kid; 82 goto &ExtUtils::Liblist::Kid::ext; 83} 84 85=back 86 87=head2 Methods 88 89Those methods which override default MM_Unix methods are marked 90"(override)", while methods unique to MM_VMS are marked "(specific)". 91For overridden methods, documentation is limited to an explanation 92of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix 93documentation for more details. 94 95=over 4 96 97=item guess_name (override) 98 99Try to determine name of extension being built. We begin with the name 100of the current directory. Since VMS filenames are case-insensitive, 101however, we look for a F<.pm> file whose name matches that of the current 102directory (presumably the 'main' F<.pm> file for this extension), and try 103to find a C<package> statement from which to obtain the Mixed::Case 104package name. 105 106=cut 107 108sub guess_name { 109 my($self) = @_; 110 my($defname,$defpm,@pm,%xs,$pm); 111 local *PM; 112 113 $defname = basename(fileify($ENV{'DEFAULT'})); 114 $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version 115 $defpm = $defname; 116 # Fallback in case for some reason a user has copied the files for an 117 # extension into a working directory whose name doesn't reflect the 118 # extension's name. We'll use the name of a unique .pm file, or the 119 # first .pm file with a matching .xs file. 120 if (not -e "${defpm}.pm") { 121 @pm = map { s/.pm$//; $_ } glob('*.pm'); 122 if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } 123 elsif (@pm) { 124 %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); 125 if (keys %xs) { 126 foreach $pm (@pm) { 127 $defpm = $pm, last if exists $xs{$pm}; 128 } 129 } 130 } 131 } 132 if (open(PM,"${defpm}.pm")){ 133 while (<PM>) { 134 if (/^\s*package\s+([^;]+)/i) { 135 $defname = $1; 136 last; 137 } 138 } 139 print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t", 140 "defaulting package name to $defname\n" 141 if eof(PM); 142 close PM; 143 } 144 else { 145 print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t", 146 "defaulting package name to $defname\n"; 147 } 148 $defname =~ s#[\d.\-_]+$##; 149 $defname; 150} 151 152=item find_perl (override) 153 154Use VMS file specification syntax and CLI commands to find and 155invoke Perl images. 156 157=cut 158 159sub find_perl { 160 my($self, $ver, $names, $dirs, $trace) = @_; 161 my($name,$dir,$vmsfile,@sdirs,@snames,@cand); 162 my($rslt); 163 my($inabs) = 0; 164 local *TCF; 165 166 if( $self->{PERL_CORE} ) { 167 # Check in relative directories first, so we pick up the current 168 # version of Perl if we're running MakeMaker as part of the main build. 169 @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); 170 my($absb) = $self->file_name_is_absolute($b); 171 if ($absa && $absb) { return $a cmp $b } 172 else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); } 173 } @$dirs; 174 # Check miniperl before perl, and check names likely to contain 175 # version numbers before "generic" names, so we pick up an 176 # executable that's less likely to be from an old installation. 177 @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename 178 my($bb) = $b =~ m!([^:>\]/]+)$!; 179 my($ahasdir) = (length($a) - length($ba) > 0); 180 my($bhasdir) = (length($b) - length($bb) > 0); 181 if ($ahasdir and not $bhasdir) { return 1; } 182 elsif ($bhasdir and not $ahasdir) { return -1; } 183 else { $bb =~ /\d/ <=> $ba =~ /\d/ 184 or substr($ba,0,1) cmp substr($bb,0,1) 185 or length($bb) <=> length($ba) } } @$names; 186 } 187 else { 188 @sdirs = @$dirs; 189 @snames = @$names; 190 } 191 192 # Image names containing Perl version use '_' instead of '.' under VMS 193 foreach $name (@snames) { $name =~ s/\.(\d+)$/_$1/; } 194 if ($trace >= 2){ 195 print "Looking for perl $ver by these names:\n"; 196 print "\t@snames,\n"; 197 print "in these dirs:\n"; 198 print "\t@sdirs\n"; 199 } 200 foreach $dir (@sdirs){ 201 next unless defined $dir; # $self->{PERL_SRC} may be undefined 202 $inabs++ if $self->file_name_is_absolute($dir); 203 if ($inabs == 1) { 204 # We've covered relative dirs; everything else is an absolute 205 # dir (probably an installed location). First, we'll try potential 206 # command names, to see whether we can avoid a long MCR expression. 207 foreach $name (@snames) { push(@cand,$name) if $name =~ /^[\w\-\$]+$/; } 208 $inabs++; # Should happen above in next $dir, but just in case . . . 209 } 210 foreach $name (@snames){ 211 if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); } 212 else { push(@cand,$self->fixpath($name,0)); } 213 } 214 } 215 foreach $name (@cand) { 216 print "Checking $name\n" if ($trace >= 2); 217 # If it looks like a potential command, try it without the MCR 218 if ($name =~ /^[\w\-\$]+$/) { 219 open(TCF,">temp_mmvms.com") || die('unable to open temp file'); 220 print TCF "\$ set message/nofacil/nosever/noident/notext\n"; 221 print TCF "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n"; 222 close TCF; 223 $rslt = `\@temp_mmvms.com` ; 224 unlink('temp_mmvms.com'); 225 if ($rslt =~ /VER_OK/) { 226 print "Using PERL=$name\n" if $trace; 227 return $name; 228 } 229 } 230 next unless $vmsfile = $self->maybe_command($name); 231 $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well 232 print "Executing $vmsfile\n" if ($trace >= 2); 233 open(TCF,">temp_mmvms.com") || die('unable to open temp file'); 234 print TCF "\$ set message/nofacil/nosever/noident/notext\n"; 235 print TCF "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n"; 236 close TCF; 237 $rslt = `\@temp_mmvms.com`; 238 unlink('temp_mmvms.com'); 239 if ($rslt =~ /VER_OK/) { 240 print "Using PERL=MCR $vmsfile\n" if $trace; 241 return "MCR $vmsfile"; 242 } 243 } 244 print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; 245 0; # false and not empty 246} 247 248=item maybe_command (override) 249 250Follows VMS naming conventions for executable files. 251If the name passed in doesn't exactly match an executable file, 252appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> 253to check for DCL procedure. If this fails, checks directories in DCL$PATH 254and finally F<Sys$System:> for an executable file having the name specified, 255with or without the F<.Exe>-equivalent suffix. 256 257=cut 258 259sub maybe_command { 260 my($self,$file) = @_; 261 return $file if -x $file && ! -d _; 262 my(@dirs) = (''); 263 my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); 264 my($dir,$ext); 265 if ($file !~ m![/:>\]]!) { 266 for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { 267 $dir = $ENV{"DCL\$PATH;$i"}; 268 $dir .= ':' unless $dir =~ m%[\]:]$%; 269 push(@dirs,$dir); 270 } 271 push(@dirs,'Sys$System:'); 272 foreach $dir (@dirs) { 273 my $sysfile = "$dir$file"; 274 foreach $ext (@exts) { 275 return $file if -x "$sysfile$ext" && ! -d _; 276 } 277 } 278 } 279 return 0; 280} 281 282 283=item pasthru (override) 284 285VMS has $(MMSQUALIFIERS) which is a listing of all the original command line 286options. This is used in every invokation of make in the VMS Makefile so 287PASTHRU should not be necessary. Using PASTHRU tends to blow commands past 288the 256 character limit. 289 290=cut 291 292sub pasthru { 293 return "PASTHRU=\n"; 294} 295 296 297=item pm_to_blib (override) 298 299VMS wants a dot in every file so we can't have one called 'pm_to_blib', 300it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when 301you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'. 302 303So in VMS its pm_to_blib.ts. 304 305=cut 306 307sub pm_to_blib { 308 my $self = shift; 309 310 my $make = $self->SUPER::pm_to_blib; 311 312 $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m; 313 $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts}; 314 315 $make = <<'MAKE' . $make; 316# Dummy target to match Unix target name; we use pm_to_blib.ts as 317# timestamp file to avoid repeated invocations under VMS 318pm_to_blib : pm_to_blib.ts 319 $(NOECHO) $(NOOP) 320 321MAKE 322 323 return $make; 324} 325 326 327=item perl_script (override) 328 329If name passed in doesn't specify a readable file, appends F<.com> or 330F<.pl> and tries again, since it's customary to have file types on all files 331under VMS. 332 333=cut 334 335sub perl_script { 336 my($self,$file) = @_; 337 return $file if -r $file && ! -d _; 338 return "$file.com" if -r "$file.com"; 339 return "$file.pl" if -r "$file.pl"; 340 return ''; 341} 342 343 344=item replace_manpage_separator 345 346Use as separator a character which is legal in a VMS-syntax file name. 347 348=cut 349 350sub replace_manpage_separator { 351 my($self,$man) = @_; 352 $man = unixify($man); 353 $man =~ s#/+#__#g; 354 $man; 355} 356 357=item init_DEST 358 359(override) Because of the difficulty concatenating VMS filepaths we 360must pre-expand the DEST* variables. 361 362=cut 363 364sub init_DEST { 365 my $self = shift; 366 367 $self->SUPER::init_DEST; 368 369 # Expand DEST variables. 370 foreach my $var ($self->installvars) { 371 my $destvar = 'DESTINSTALL'.$var; 372 $self->{$destvar} = File::Spec->eliminate_macros($self->{$destvar}); 373 } 374} 375 376 377=item init_DIRFILESEP 378 379No seperator between a directory path and a filename on VMS. 380 381=cut 382 383sub init_DIRFILESEP { 384 my($self) = shift; 385 386 $self->{DIRFILESEP} = ''; 387 return 1; 388} 389 390 391=item init_main (override) 392 393 394=cut 395 396sub init_main { 397 my($self) = shift; 398 399 $self->SUPER::init_main; 400 401 $self->{DEFINE} ||= ''; 402 if ($self->{DEFINE} ne '') { 403 my(@terms) = split(/\s+/,$self->{DEFINE}); 404 my(@defs,@udefs); 405 foreach my $def (@terms) { 406 next unless $def; 407 my $targ = \@defs; 408 if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition 409 $targ = \@udefs if $1 eq 'U'; 410 $def =~ s/='(.*)'$/=$1/; # then remove shell-protection '' 411 $def =~ s/^'(.*)'$/$1/; # from entire term or argument 412 } 413 if ($def =~ /=/) { 414 $def =~ s/"/""/g; # Protect existing " from DCL 415 $def = qq["$def"]; # and quote to prevent parsing of = 416 } 417 push @$targ, $def; 418 } 419 420 $self->{DEFINE} = ''; 421 if (@defs) { 422 $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')'; 423 } 424 if (@udefs) { 425 $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')'; 426 } 427 } 428} 429 430=item init_others (override) 431 432Provide VMS-specific forms of various utility commands, then hand 433off to the default MM_Unix method. 434 435DEV_NULL should probably be overriden with something. 436 437Also changes EQUALIZE_TIMESTAMP to set revision date of target file to 438one second later than source file, since MMK interprets precisely 439equal revision dates for a source and target file as a sign that the 440target needs to be updated. 441 442=cut 443 444sub init_others { 445 my($self) = @_; 446 447 $self->{NOOP} = 'Continue'; 448 $self->{NOECHO} ||= '@ '; 449 450 $self->{MAKEFILE} ||= 'Descrip.MMS'; 451 $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE}; 452 $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS'; 453 $self->{MAKEFILE_OLD} ||= '$(FIRST_MAKEFILE)_old'; 454 455 $self->{MACROSTART} ||= '/Macro=('; 456 $self->{MACROEND} ||= ')'; 457 $self->{USEMAKEFILE} ||= '/Descrip='; 458 459 $self->{ECHO} ||= '$(ABSPERLRUN) -le "print qq{@ARGV}"'; 460 $self->{ECHO_N} ||= '$(ABSPERLRUN) -e "print qq{@ARGV}"'; 461 $self->{TOUCH} ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e touch'; 462 $self->{CHMOD} ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e chmod'; 463 $self->{RM_F} ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e rm_f'; 464 $self->{RM_RF} ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e rm_rf'; 465 $self->{TEST_F} ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e test_f'; 466 $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"'; 467 468 $self->{MOD_INSTALL} ||= 469 $self->oneliner(<<'CODE', ['-MExtUtils::Install']); 470install({split(' ',<STDIN>)}, '$(VERBINST)', 0, '$(UNINST)'); 471CODE 472 473 $self->{SHELL} ||= 'Posix'; 474 475 $self->SUPER::init_others; 476 477 # So we can copy files into directories with less fuss 478 $self->{CP} = '$(ABSPERLRUN) "-MExtUtils::Command" -e cp'; 479 $self->{MV} = '$(ABSPERLRUN) "-MExtUtils::Command" -e mv'; 480 481 $self->{UMASK_NULL} = '! '; 482 483 # Redirection on VMS goes before the command, not after as on Unix. 484 # $(DEV_NULL) is used once and its not worth going nuts over making 485 # it work. However, Unix's DEV_NULL is quite wrong for VMS. 486 $self->{DEV_NULL} = ''; 487 488 if ($self->{OBJECT} =~ /\s/) { 489 $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; 490 $self->{OBJECT} = $self->wraplist( 491 map $self->fixpath($_,0), split /,?\s+/, $self->{OBJECT} 492 ); 493 } 494 495 $self->{LDFROM} = $self->wraplist( 496 map $self->fixpath($_,0), split /,?\s+/, $self->{LDFROM} 497 ); 498} 499 500 501=item init_platform (override) 502 503Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION. 504 505MM_VMS_REVISION is for backwards compatibility before MM_VMS had a 506$VERSION. 507 508=cut 509 510sub init_platform { 511 my($self) = shift; 512 513 $self->{MM_VMS_REVISION} = $Revision; 514 $self->{MM_VMS_VERSION} = $VERSION; 515 $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS') 516 if $self->{PERL_SRC}; 517} 518 519 520=item platform_constants 521 522=cut 523 524sub platform_constants { 525 my($self) = shift; 526 my $make_frag = ''; 527 528 foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION)) 529 { 530 next unless defined $self->{$macro}; 531 $make_frag .= "$macro = $self->{$macro}\n"; 532 } 533 534 return $make_frag; 535} 536 537 538=item init_VERSION (override) 539 540Override the *DEFINE_VERSION macros with VMS semantics. Translate the 541MAKEMAKER filepath to VMS style. 542 543=cut 544 545sub init_VERSION { 546 my $self = shift; 547 548 $self->SUPER::init_VERSION; 549 550 $self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""'; 551 $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""'; 552 $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'}); 553} 554 555 556=item constants (override) 557 558Fixes up numerous file and directory macros to insure VMS syntax 559regardless of input syntax. Also makes lists of files 560comma-separated. 561 562=cut 563 564sub constants { 565 my($self) = @_; 566 567 # Be kind about case for pollution 568 for (@ARGV) { $_ = uc($_) if /POLLUTE/i; } 569 570 # Cleanup paths for directories in MMS macros. 571 foreach my $macro ( qw [ 572 INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB 573 PERL_LIB PERL_ARCHLIB 574 PERL_INC PERL_SRC ], 575 (map { 'INSTALL'.$_ } $self->installvars) 576 ) 577 { 578 next unless defined $self->{$macro}; 579 next if $macro =~ /MAN/ && $self->{$macro} eq 'none'; 580 $self->{$macro} = $self->fixpath($self->{$macro},1); 581 } 582 583 # Cleanup paths for files in MMS macros. 584 foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD 585 MAKE_APERL_FILE MYEXTLIB] ) 586 { 587 next unless defined $self->{$macro}; 588 $self->{$macro} = $self->fixpath($self->{$macro},0); 589 } 590 591 # Fixup files for MMS macros 592 # XXX is this list complete? 593 for my $macro (qw/ 594 FULLEXT VERSION_FROM OBJECT LDFROM 595 / ) { 596 next unless defined $self->{$macro}; 597 $self->{$macro} = $self->fixpath($self->{$macro},0); 598 } 599 600 601 for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) { 602 # Where is the space coming from? --jhi 603 next unless $self ne " " && defined $self->{$macro}; 604 my %tmp = (); 605 for my $key (keys %{$self->{$macro}}) { 606 $tmp{$self->fixpath($key,0)} = 607 $self->fixpath($self->{$macro}{$key},0); 608 } 609 $self->{$macro} = \%tmp; 610 } 611 612 for my $macro (qw/ C O_FILES H /) { 613 next unless defined $self->{$macro}; 614 my @tmp = (); 615 for my $val (@{$self->{$macro}}) { 616 push(@tmp,$self->fixpath($val,0)); 617 } 618 $self->{$macro} = \@tmp; 619 } 620 621 # mms/k does not define a $(MAKE) macro. 622 $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)'; 623 624 return $self->SUPER::constants; 625} 626 627 628=item special_targets 629 630Clear the default .SUFFIXES and put in our own list. 631 632=cut 633 634sub special_targets { 635 my $self = shift; 636 637 my $make_frag .= <<'MAKE_FRAG'; 638.SUFFIXES : 639.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs 640 641MAKE_FRAG 642 643 return $make_frag; 644} 645 646=item cflags (override) 647 648Bypass shell script and produce qualifiers for CC directly (but warn 649user if a shell script for this extension exists). Fold multiple 650/Defines into one, since some C compilers pay attention to only one 651instance of this qualifier on the command line. 652 653=cut 654 655sub cflags { 656 my($self,$libperl) = @_; 657 my($quals) = $self->{CCFLAGS} || $Config{'ccflags'}; 658 my($definestr,$undefstr,$flagoptstr) = ('','',''); 659 my($incstr) = '/Include=($(PERL_INC)'; 660 my($name,$sys,@m); 661 662 ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; 663 print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}. 664 " required to modify CC command for $self->{'BASEEXT'}\n" 665 if ($Config{$name}); 666 667 if ($quals =~ / -[DIUOg]/) { 668 while ($quals =~ / -([Og])(\d*)\b/) { 669 my($type,$lvl) = ($1,$2); 670 $quals =~ s/ -$type$lvl\b\s*//; 671 if ($type eq 'g') { $flagoptstr = '/NoOptimize'; } 672 else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); } 673 } 674 while ($quals =~ / -([DIU])(\S+)/) { 675 my($type,$def) = ($1,$2); 676 $quals =~ s/ -$type$def\s*//; 677 $def =~ s/"/""/g; 678 if ($type eq 'D') { $definestr .= qq["$def",]; } 679 elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } 680 else { $undefstr .= qq["$def",]; } 681 } 682 } 683 if (length $quals and $quals !~ m!/!) { 684 warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n"; 685 $quals = ''; 686 } 687 $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE}; 688 if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; } 689 if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; } 690 # Deal with $self->{DEFINE} here since some C compilers pay attention 691 # to only one /Define clause on command line, so we have to 692 # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} 693 # ($self->{DEFINE} has already been VMSified in constants() above) 694 if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; } 695 for my $type (qw(Def Undef)) { 696 my(@terms); 697 while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) { 698 my $term = $1; 699 $term =~ s:^\((.+)\)$:$1:; 700 push @terms, $term; 701 } 702 if ($type eq 'Def') { 703 push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ]; 704 } 705 if (@terms) { 706 $quals =~ s:/${type}i?n?e?=[^/]+::ig; 707 $quals .= "/${type}ine=(" . join(',',@terms) . ')'; 708 } 709 } 710 711 $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb"; 712 713 # Likewise with $self->{INC} and /Include 714 if ($self->{'INC'}) { 715 my(@includes) = split(/\s+/,$self->{INC}); 716 foreach (@includes) { 717 s/^-I//; 718 $incstr .= ','.$self->fixpath($_,1); 719 } 720 } 721 $quals .= "$incstr)"; 722# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g; 723 $self->{CCFLAGS} = $quals; 724 725 $self->{PERLTYPE} ||= ''; 726 727 $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'}; 728 if ($self->{OPTIMIZE} !~ m!/!) { 729 if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } 730 elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) { 731 $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : ''); 732 } 733 else { 734 warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE}; 735 $self->{OPTIMIZE} = '/Optimize'; 736 } 737 } 738 739 return $self->{CFLAGS} = qq{ 740CCFLAGS = $self->{CCFLAGS} 741OPTIMIZE = $self->{OPTIMIZE} 742PERLTYPE = $self->{PERLTYPE} 743}; 744} 745 746=item const_cccmd (override) 747 748Adds directives to point C preprocessor to the right place when 749handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC 750command line a bit differently than MM_Unix method. 751 752=cut 753 754sub const_cccmd { 755 my($self,$libperl) = @_; 756 my(@m); 757 758 return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; 759 return '' unless $self->needs_linking(); 760 if ($Config{'vms_cc_type'} eq 'gcc') { 761 push @m,' 762.FIRST 763 ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]'; 764 } 765 elsif ($Config{'vms_cc_type'} eq 'vaxc') { 766 push @m,' 767.FIRST 768 ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library 769 ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include'; 770 } 771 else { 772 push @m,' 773.FIRST 774 ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ', 775 ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),' 776 ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include'; 777 } 778 779 push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n"); 780 781 $self->{CONST_CCCMD} = join('',@m); 782} 783 784 785=item tools_other (override) 786 787Throw in some dubious extra macros for Makefile args. 788 789Also keep around the old $(SAY) macro in case somebody's using it. 790 791=cut 792 793sub tools_other { 794 my($self) = @_; 795 796 # XXX Are these necessary? Does anyone override them? They're longer 797 # than just typing the literal string. 798 my $extra_tools = <<'EXTRA_TOOLS'; 799 800# Just in case anyone is using the old macro. 801USEMACROS = $(MACROSTART) 802SAY = $(ECHO) 803 804EXTRA_TOOLS 805 806 return $self->SUPER::tools_other . $extra_tools; 807} 808 809=item init_dist (override) 810 811VMSish defaults for some values. 812 813 macro description default 814 815 ZIPFLAGS flags to pass to ZIP -Vu 816 817 COMPRESS compression command to gzip 818 use for tarfiles 819 SUFFIX suffix to put on -gz 820 compressed files 821 822 SHAR shar command to use vms_share 823 824 DIST_DEFAULT default target to use to tardist 825 create a distribution 826 827 DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM) 828 VERSION for the name 829 830=cut 831 832sub init_dist { 833 my($self) = @_; 834 $self->{ZIPFLAGS} ||= '-Vu'; 835 $self->{COMPRESS} ||= 'gzip'; 836 $self->{SUFFIX} ||= '-gz'; 837 $self->{SHAR} ||= 'vms_share'; 838 $self->{DIST_DEFAULT} ||= 'zipdist'; 839 840 $self->SUPER::init_dist; 841 842 $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}"; 843} 844 845=item c_o (override) 846 847Use VMS syntax on command line. In particular, $(DEFINE) and 848$(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros. 849 850=cut 851 852sub c_o { 853 my($self) = @_; 854 return '' unless $self->needs_linking(); 855 ' 856.c$(OBJ_EXT) : 857 $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c 858 859.cpp$(OBJ_EXT) : 860 $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp 861 862.cxx$(OBJ_EXT) : 863 $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx 864 865'; 866} 867 868=item xs_c (override) 869 870Use MM[SK] macros. 871 872=cut 873 874sub xs_c { 875 my($self) = @_; 876 return '' unless $self->needs_linking(); 877 ' 878.xs.c : 879 $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET) 880'; 881} 882 883=item xs_o (override) 884 885Use MM[SK] macros, and VMS command line for C compiler. 886 887=cut 888 889sub xs_o { # many makes are too dumb to use xs_c then c_o 890 my($self) = @_; 891 return '' unless $self->needs_linking(); 892 ' 893.xs$(OBJ_EXT) : 894 $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c 895 $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c 896'; 897} 898 899 900=item dlsyms (override) 901 902Create VMS linker options files specifying universal symbols for this 903extension's shareable image, and listing other shareable images or 904libraries to which it should be linked. 905 906=cut 907 908sub dlsyms { 909 my($self,%attribs) = @_; 910 911 return '' unless $self->needs_linking(); 912 913 my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; 914 my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; 915 my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; 916 my(@m); 917 918 unless ($self->{SKIPHASH}{'dynamic'}) { 919 push(@m,' 920dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt 921 $(NOECHO) $(NOOP) 922'); 923 } 924 925 push(@m,' 926static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt 927 $(NOECHO) $(NOOP) 928') unless $self->{SKIPHASH}{'static'}; 929 930 push @m,' 931$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt 932 $(CP) $(MMS$SOURCE) $(MMS$TARGET) 933 934$(BASEEXT).opt : Makefile.PL 935 $(PERLRUN) -e "use ExtUtils::Mksymlists;" - 936 ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ], 937 neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars), 938 q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n]; 939 940 push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include='; 941 if ($self->{OBJECT} =~ /\bBASEEXT\b/ or 942 $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) { 943 push @m, ($Config{d_vms_case_sensitive_symbols} 944 ? uc($self->{BASEEXT}) :'$(BASEEXT)'); 945 } 946 else { # We don't have a "main" object file, so pull 'em all in 947 # Upcase module names if linker is being case-sensitive 948 my($upcase) = $Config{d_vms_case_sensitive_symbols}; 949 my(@omods) = map { s/\.[^.]*$//; # Trim off file type 950 s[\$\(\w+_EXT\)][]; # even as a macro 951 s/.*[:>\/\]]//; # Trim off dir spec 952 $upcase ? uc($_) : $_; 953 } split ' ', $self->eliminate_macros($self->{OBJECT}); 954 my($tmp,@lines,$elt) = ''; 955 $tmp = shift @omods; 956 foreach $elt (@omods) { 957 $tmp .= ",$elt"; 958 if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; } 959 } 960 push @lines, $tmp; 961 push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')'; 962 } 963 push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n"; 964 965 if (length $self->{LDLOADLIBS}) { 966 my($lib); my($line) = ''; 967 foreach $lib (split ' ', $self->{LDLOADLIBS}) { 968 $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs 969 if (length($line) + length($lib) > 160) { 970 push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n"; 971 $line = $lib . '\n'; 972 } 973 else { $line .= $lib . '\n'; } 974 } 975 push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line; 976 } 977 978 join('',@m); 979 980} 981 982=item dynamic_lib (override) 983 984Use VMS Link command. 985 986=cut 987 988sub dynamic_lib { 989 my($self, %attribs) = @_; 990 return '' unless $self->needs_linking(); #might be because of a subdir 991 992 return '' unless $self->has_link_code(); 993 994 my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; 995 my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; 996 my $shr = $Config{'dbgprefix'} . 'PerlShr'; 997 my(@m); 998 push @m," 999 1000OTHERLDFLAGS = $otherldflags 1001INST_DYNAMIC_DEP = $inst_dynamic_dep 1002 1003"; 1004 push @m, ' 1005$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) 1006 If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' 1007 Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option 1008'; 1009 1010 join('',@m); 1011} 1012 1013 1014=item static_lib (override) 1015 1016Use VMS commands to manipulate object library. 1017 1018=cut 1019 1020sub static_lib { 1021 my($self) = @_; 1022 return '' unless $self->needs_linking(); 1023 1024 return ' 1025$(INST_STATIC) : 1026 $(NOECHO) $(NOOP) 1027' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}); 1028 1029 my(@m,$lib); 1030 push @m,' 1031# Rely on suffix rule for update action 1032$(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists 1033 1034$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) 1035'; 1036 # If this extension has its own library (eg SDBM_File) 1037 # then copy that to $(INST_STATIC) and add $(OBJECT) into it. 1038 push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; 1039 1040 push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n"); 1041 1042 # if there was a library to copy, then we can't use MMS$SOURCE_LIST, 1043 # 'cause it's a library and you can't stick them in other libraries. 1044 # In that case, we use $OBJECT instead and hope for the best 1045 if ($self->{MYEXTLIB}) { 1046 push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n"); 1047 } else { 1048 push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); 1049 } 1050 1051 push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n"; 1052 foreach $lib (split ' ', $self->{EXTRALIBS}) { 1053 push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); 1054 } 1055 join('',@m); 1056} 1057 1058 1059=item extra_clean_files 1060 1061Clean up some OS specific files. Plus the temp file used to shorten 1062a lot of commands. 1063 1064=cut 1065 1066sub extra_clean_files { 1067 return qw( 1068 *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso 1069 .MM_Tmp 1070 ); 1071} 1072 1073 1074=item zipfile_target 1075 1076=item tarfile_target 1077 1078=item shdist_target 1079 1080Syntax for invoking shar, tar and zip differs from that for Unix. 1081 1082=cut 1083 1084sub zipfile_target { 1085 my($self) = shift; 1086 1087 return <<'MAKE_FRAG'; 1088$(DISTVNAME).zip : distdir 1089 $(PREOP) 1090 $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; 1091 $(RM_RF) $(DISTVNAME) 1092 $(POSTOP) 1093MAKE_FRAG 1094} 1095 1096sub tarfile_target { 1097 my($self) = shift; 1098 1099 return <<'MAKE_FRAG'; 1100$(DISTVNAME).tar$(SUFFIX) : distdir 1101 $(PREOP) 1102 $(TO_UNIX) 1103 $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...] 1104 $(RM_RF) $(DISTVNAME) 1105 $(COMPRESS) $(DISTVNAME).tar 1106 $(POSTOP) 1107MAKE_FRAG 1108} 1109 1110sub shdist_target { 1111 my($self) = shift; 1112 1113 return <<'MAKE_FRAG'; 1114shdist : distdir 1115 $(PREOP) 1116 $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share 1117 $(RM_RF) $(DISTVNAME) 1118 $(POSTOP) 1119MAKE_FRAG 1120} 1121 1122 1123# --- Test and Installation Sections --- 1124 1125=item install (override) 1126 1127Work around DCL's 255 character limit several times,and use 1128VMS-style command line quoting in a few cases. 1129 1130=cut 1131 1132sub install { 1133 my($self, %attribs) = @_; 1134 my(@m); 1135 1136 push @m, q[ 1137install :: all pure_install doc_install 1138 $(NOECHO) $(NOOP) 1139 1140install_perl :: all pure_perl_install doc_perl_install 1141 $(NOECHO) $(NOOP) 1142 1143install_site :: all pure_site_install doc_site_install 1144 $(NOECHO) $(NOOP) 1145 1146pure_install :: pure_$(INSTALLDIRS)_install 1147 $(NOECHO) $(NOOP) 1148 1149doc_install :: doc_$(INSTALLDIRS)_install 1150 $(NOECHO) $(NOOP) 1151 1152pure__install : pure_site_install 1153 $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" 1154 1155doc__install : doc_site_install 1156 $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" 1157 1158# This hack brought to you by DCL's 255-character command line limit 1159pure_perl_install :: 1160 $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp 1161 $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp 1162 $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp 1163 $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp 1164 $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp 1165 $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp 1166 $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp 1167 $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) " >>.MM_tmp 1168 $(NOECHO) $(MOD_INSTALL) <.MM_tmp 1169 $(NOECHO) $(RM_F) .MM_tmp 1170 $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ 1171 1172# Likewise 1173pure_site_install :: 1174 $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp 1175 $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp 1176 $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp 1177 $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp 1178 $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp 1179 $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp 1180 $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) " >>.MM_tmp 1181 $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) " >>.MM_tmp 1182 $(NOECHO) $(MOD_INSTALL) <.MM_tmp 1183 $(NOECHO) $(RM_F) .MM_tmp 1184 $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[ 1185 1186pure_vendor_install :: 1187 $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp 1188 $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp 1189 $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp 1190 $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp 1191 $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp 1192 $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp 1193 $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) " >>.MM_tmp 1194 $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) " >>.MM_tmp 1195 $(NOECHO) $(MOD_INSTALL) <.MM_tmp 1196 $(NOECHO) $(RM_F) .MM_tmp 1197 1198# Ditto 1199doc_perl_install :: 1200 $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" 1201 $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) 1202 $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp 1203 $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp 1204 $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ 1205 $(NOECHO) $(RM_F) .MM_tmp 1206 1207# And again 1208doc_site_install :: 1209 $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" 1210 $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) 1211 $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp 1212 $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp 1213 $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ 1214 $(NOECHO) $(RM_F) .MM_tmp 1215 1216doc_vendor_install :: 1217 $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" 1218 $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) 1219 $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp 1220 $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp 1221 $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ 1222 $(NOECHO) $(RM_F) .MM_tmp 1223 1224]; 1225 1226 push @m, q[ 1227uninstall :: uninstall_from_$(INSTALLDIRS)dirs 1228 $(NOECHO) $(NOOP) 1229 1230uninstall_from_perldirs :: 1231 $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[ 1232 $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes." 1233 $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove" 1234 $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience." 1235 1236uninstall_from_sitedirs :: 1237 $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ 1238 $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes." 1239 $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove" 1240 $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience." 1241]; 1242 1243 join('',@m); 1244} 1245 1246=item perldepend (override) 1247 1248Use VMS-style syntax for files; it's cheaper to just do it directly here 1249than to have the MM_Unix method call C<catfile> repeatedly. Also, if 1250we have to rebuild Config.pm, use MM[SK] to do it. 1251 1252=cut 1253 1254sub perldepend { 1255 my($self) = @_; 1256 my(@m); 1257 1258 push @m, ' 1259$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h 1260$(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)cc_runtime.h, $(PERL_INC)config.h 1261$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h 1262$(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)form.h 1263$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h 1264$(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h 1265$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h 1266$(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h 1267$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlio.h 1268$(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlvars.h 1269$(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h 1270$(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h 1271$(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h 1272$(OBJECT) : $(PERL_INC)thrdvar.h, $(PERL_INC)thread.h 1273$(OBJECT) : $(PERL_INC)util.h, $(PERL_INC)vmsish.h 1274 1275' if $self->{OBJECT}; 1276 1277 if ($self->{PERL_SRC}) { 1278 my(@macros); 1279 my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)'; 1280 push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP'; 1281 push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc'; 1282 push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc'; 1283 push(@macros,'SOCKET=1') if $Config{'d_has_sockets'}; 1284 push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!; 1285 $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros; 1286 push(@m,q[ 1287# Check for unpropagated config.sh changes. Should never happen. 1288# We do NOT just update config.h because that is not sufficient. 1289# An out of date config.h is not fatal but complains loudly! 1290$(PERL_INC)config.h : $(PERL_SRC)config.sh 1291 $(NOOP) 1292 1293$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh 1294 $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl" 1295 olddef = F$Environment("Default") 1296 Set Default $(PERL_SRC) 1297 $(MMS)],$mmsquals,); 1298 if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { 1299 my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); 1300 $target =~ s/\Q$prefix/[/; 1301 push(@m," $target"); 1302 } 1303 else { push(@m,' $(MMS$TARGET)'); } 1304 push(@m,q[ 1305 Set Default 'olddef' 1306]); 1307 } 1308 1309 push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") 1310 if %{$self->{XS}}; 1311 1312 join('',@m); 1313} 1314 1315 1316=item makeaperl (override) 1317 1318Undertake to build a new set of Perl images using VMS commands. Since 1319VMS does dynamic loading, it's not necessary to statically link each 1320extension into the Perl image, so this isn't the normal build path. 1321Consequently, it hasn't really been tested, and may well be incomplete. 1322 1323=cut 1324 1325use vars qw(%olbs); 1326 1327sub makeaperl { 1328 my($self, %attribs) = @_; 1329 my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) = 1330 @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; 1331 my(@m); 1332 push @m, " 1333# --- MakeMaker makeaperl section --- 1334MAP_TARGET = $target 1335"; 1336 return join '', @m if $self->{PARENT}; 1337 1338 my($dir) = join ":", @{$self->{DIR}}; 1339 1340 unless ($self->{MAKEAPERL}) { 1341 push @m, q{ 1342$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) 1343 $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" 1344 $(NOECHO) $(PERLRUNINST) \ 1345 Makefile.PL DIR=}, $dir, q{ \ 1346 FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ 1347 MAKEAPERL=1 NORECURS=1 }; 1348 1349 push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{ 1350 1351$(MAP_TARGET) :: $(MAKE_APERL_FILE) 1352 $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET) 1353}; 1354 push @m, "\n"; 1355 1356 return join '', @m; 1357 } 1358 1359 1360 my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); 1361 local($_); 1362 1363 # The front matter of the linkcommand... 1364 $linkcmd = join ' ', $Config{'ld'}, 1365 grep($_, @Config{qw(large split ldflags ccdlflags)}); 1366 $linkcmd =~ s/\s+/ /g; 1367 1368 # Which *.olb files could we make use of... 1369 local(%olbs); # XXX can this be lexical? 1370 $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)"; 1371 require File::Find; 1372 File::Find::find(sub { 1373 return unless m/\Q$self->{LIB_EXT}\E$/; 1374 return if m/^libperl/; 1375 1376 if( exists $self->{INCLUDE_EXT} ){ 1377 my $found = 0; 1378 my $incl; 1379 my $xx; 1380 1381 ($xx = $File::Find::name) =~ s,.*?/auto/,,; 1382 $xx =~ s,/?$_,,; 1383 $xx =~ s,/,::,g; 1384 1385 # Throw away anything not explicitly marked for inclusion. 1386 # DynaLoader is implied. 1387 foreach $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ 1388 if( $xx eq $incl ){ 1389 $found++; 1390 last; 1391 } 1392 } 1393 return unless $found; 1394 } 1395 elsif( exists $self->{EXCLUDE_EXT} ){ 1396 my $excl; 1397 my $xx; 1398 1399 ($xx = $File::Find::name) =~ s,.*?/auto/,,; 1400 $xx =~ s,/?$_,,; 1401 $xx =~ s,/,::,g; 1402 1403 # Throw away anything explicitly marked for exclusion 1404 foreach $excl (@{$self->{EXCLUDE_EXT}}){ 1405 return if( $xx eq $excl ); 1406 } 1407 } 1408 1409 $olbs{$ENV{DEFAULT}} = $_; 1410 }, grep( -d $_, @{$searchdirs || []})); 1411 1412 # We trust that what has been handed in as argument will be buildable 1413 $static = [] unless $static; 1414 @olbs{@{$static}} = (1) x @{$static}; 1415 1416 $extra = [] unless $extra && ref $extra eq 'ARRAY'; 1417 # Sort the object libraries in inverse order of 1418 # filespec length to try to insure that dependent extensions 1419 # will appear before their parents, so the linker will 1420 # search the parent library to resolve references. 1421 # (e.g. Intuit::DWIM will precede Intuit, so unresolved 1422 # references from [.intuit.dwim]dwim.obj can be found 1423 # in [.intuit]intuit.olb). 1424 for (sort { length($a) <=> length($b) } keys %olbs) { 1425 next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; 1426 my($dir) = $self->fixpath($_,1); 1427 my($extralibs) = $dir . "extralibs.ld"; 1428 my($extopt) = $dir . $olbs{$_}; 1429 $extopt =~ s/$self->{LIB_EXT}$/.opt/; 1430 push @optlibs, "$dir$olbs{$_}"; 1431 # Get external libraries this extension will need 1432 if (-f $extralibs ) { 1433 my %seenthis; 1434 open LIST,$extralibs or warn $!,next; 1435 while (<LIST>) { 1436 chomp; 1437 # Include a library in the link only once, unless it's mentioned 1438 # multiple times within a single extension's options file, in which 1439 # case we assume the builder needed to search it again later in the 1440 # link. 1441 my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); 1442 $libseen{$_}++; $seenthis{$_}++; 1443 next if $skip; 1444 push @$extra,$_; 1445 } 1446 close LIST; 1447 } 1448 # Get full name of extension for ExtUtils::Miniperl 1449 if (-f $extopt) { 1450 open OPT,$extopt or die $!; 1451 while (<OPT>) { 1452 next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; 1453 my $pkg = $1; 1454 $pkg =~ s#__*#::#g; 1455 push @staticpkgs,$pkg; 1456 } 1457 } 1458 } 1459 # Place all of the external libraries after all of the Perl extension 1460 # libraries in the final link, in order to maximize the opportunity 1461 # for XS code from multiple extensions to resolve symbols against the 1462 # same external library while only including that library once. 1463 push @optlibs, @$extra; 1464 1465 $target = "Perl$Config{'exe_ext'}" unless $target; 1466 my $shrtarget; 1467 ($shrtarget,$targdir) = fileparse($target); 1468 $shrtarget =~ s/^([^.]*)/$1Shr/; 1469 $shrtarget = $targdir . $shrtarget; 1470 $target = "Perlshr.$Config{'dlext'}" unless $target; 1471 $tmpdir = "[]" unless $tmpdir; 1472 $tmpdir = $self->fixpath($tmpdir,1); 1473 if (@optlibs) { $extralist = join(' ',@optlibs); } 1474 else { $extralist = ''; } 1475 # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr) 1476 # that's what we're building here). 1477 push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2]; 1478 if ($libperl) { 1479 unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { 1480 print STDOUT "Warning: $libperl not found\n"; 1481 undef $libperl; 1482 } 1483 } 1484 unless ($libperl) { 1485 if (defined $self->{PERL_SRC}) { 1486 $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}"); 1487 } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) { 1488 } else { 1489 print STDOUT "Warning: $libperl not found 1490 If you're going to build a static perl binary, make sure perl is installed 1491 otherwise ignore this warning\n"; 1492 } 1493 } 1494 $libperldir = $self->fixpath((fileparse($libperl))[1],1); 1495 1496 push @m, ' 1497# Fill in the target you want to produce if it\'s not perl 1498MAP_TARGET = ',$self->fixpath($target,0),' 1499MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," 1500MAP_LINKCMD = $linkcmd 1501MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," 1502MAP_EXTRA = $extralist 1503MAP_LIBPERL = ",$self->fixpath($libperl,0),' 1504'; 1505 1506 1507 push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n"; 1508 foreach (@optlibs) { 1509 push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; 1510 } 1511 push @m,"\n${tmpdir}PerlShr.Opt :\n\t"; 1512 push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; 1513 1514 push @m,' 1515$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' 1516 $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' 1517$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",' 1518 $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option 1519 $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say" 1520 $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" 1521 $(NOECHO) $(ECHO) "To remove the intermediate files, say 1522 $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean" 1523'; 1524 push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n"; 1525 push @m, "# More from the 255-char line length limit\n"; 1526 foreach (@staticpkgs) { 1527 push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n]; 1528 } 1529 1530 push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir; 1531 $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET) 1532 $(NOECHO) $(RM_F) %sWritemain.tmp 1533MAKE_FRAG 1534 1535 push @m, q[ 1536# Still more from the 255-char line length limit 1537doc_inst_perl : 1538 $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) 1539 $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp 1540 $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp 1541 $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp 1542 $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp 1543 $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[ 1544 $(NOECHO) $(RM_F) .MM_tmp 1545]; 1546 1547 push @m, " 1548inst_perl : pure_inst_perl doc_inst_perl 1549 \$(NOECHO) \$(NOOP) 1550 1551pure_inst_perl : \$(MAP_TARGET) 1552 $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1)," 1553 $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1)," 1554 1555clean :: map_clean 1556 \$(NOECHO) \$(NOOP) 1557 1558map_clean : 1559 \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE) 1560 \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET) 1561"; 1562 1563 join '', @m; 1564} 1565 1566# --- Output postprocessing section --- 1567 1568=item nicetext (override) 1569 1570Insure that colons marking targets are preceded by space, in order 1571to distinguish the target delimiter from a colon appearing as 1572part of a filespec. 1573 1574=cut 1575 1576sub nicetext { 1577 my($self,$text) = @_; 1578 return $text if $text =~ m/^\w+\s*=/; # leave macro defs alone 1579 $text =~ s/([^\s:])(:+\s)/$1 $2/gs; 1580 $text; 1581} 1582 1583=item prefixify (override) 1584 1585prefixifying on VMS is simple. Each should simply be: 1586 1587 perl_root:[some.dir] 1588 1589which can just be converted to: 1590 1591 volume:[your.prefix.some.dir] 1592 1593otherwise you get the default layout. 1594 1595In effect, your search prefix is ignored and $Config{vms_prefix} is 1596used instead. 1597 1598=cut 1599 1600sub prefixify { 1601 my($self, $var, $sprefix, $rprefix, $default) = @_; 1602 1603 # Translate $(PERLPREFIX) to a real path. 1604 $rprefix = $self->eliminate_macros($rprefix); 1605 $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix; 1606 $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix; 1607 1608 $default = VMS::Filespec::vmsify($default) 1609 unless $default =~ /\[.*\]/; 1610 1611 (my $var_no_install = $var) =~ s/^install//; 1612 my $path = $self->{uc $var} || 1613 $ExtUtils::MM_Unix::Config_Override{lc $var} || 1614 $Config{lc $var} || $Config{lc $var_no_install}; 1615 1616 if( !$path ) { 1617 print STDERR " no Config found for $var.\n" if $Verbose >= 2; 1618 $path = $self->_prefixify_default($rprefix, $default); 1619 } 1620 elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) { 1621 # do nothing if there's no prefix or if its relative 1622 } 1623 elsif( $sprefix eq $rprefix ) { 1624 print STDERR " no new prefix.\n" if $Verbose >= 2; 1625 } 1626 else { 1627 1628 print STDERR " prefixify $var => $path\n" if $Verbose >= 2; 1629 print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2; 1630 1631 my($path_vol, $path_dirs) = $self->splitpath( $path ); 1632 if( $path_vol eq $Config{vms_prefix}.':' ) { 1633 print STDERR " $Config{vms_prefix}: seen\n" if $Verbose >= 2; 1634 1635 $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; 1636 $path = $self->_catprefix($rprefix, $path_dirs); 1637 } 1638 else { 1639 $path = $self->_prefixify_default($rprefix, $default); 1640 } 1641 } 1642 1643 print " now $path\n" if $Verbose >= 2; 1644 return $self->{uc $var} = $path; 1645} 1646 1647 1648sub _prefixify_default { 1649 my($self, $rprefix, $default) = @_; 1650 1651 print STDERR " cannot prefix, using default.\n" if $Verbose >= 2; 1652 1653 if( !$default ) { 1654 print STDERR "No default!\n" if $Verbose >= 1; 1655 return; 1656 } 1657 if( !$rprefix ) { 1658 print STDERR "No replacement prefix!\n" if $Verbose >= 1; 1659 return ''; 1660 } 1661 1662 return $self->_catprefix($rprefix, $default); 1663} 1664 1665sub _catprefix { 1666 my($self, $rprefix, $default) = @_; 1667 1668 my($rvol, $rdirs) = $self->splitpath($rprefix); 1669 if( $rvol ) { 1670 return $self->catpath($rvol, 1671 $self->catdir($rdirs, $default), 1672 '' 1673 ) 1674 } 1675 else { 1676 return $self->catdir($rdirs, $default); 1677 } 1678} 1679 1680 1681=item cd 1682 1683=cut 1684 1685sub cd { 1686 my($self, $dir, @cmds) = @_; 1687 1688 $dir = vmspath($dir); 1689 1690 my $cmd = join "\n\t", map "$_", @cmds; 1691 1692 # No leading tab makes it look right when embedded 1693 my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd; 1694startdir = F$Environment("Default") 1695 Set Default %s 1696 %s 1697 Set Default 'startdir' 1698MAKE_FRAG 1699 1700 # No trailing newline makes this easier to embed 1701 chomp $make_frag; 1702 1703 return $make_frag; 1704} 1705 1706 1707=item oneliner 1708 1709=cut 1710 1711sub oneliner { 1712 my($self, $cmd, $switches) = @_; 1713 $switches = [] unless defined $switches; 1714 1715 # Strip leading and trailing newlines 1716 $cmd =~ s{^\n+}{}; 1717 $cmd =~ s{\n+$}{}; 1718 1719 $cmd = $self->quote_literal($cmd); 1720 $cmd = $self->escape_newlines($cmd); 1721 1722 # Switches must be quoted else they will be lowercased. 1723 $switches = join ' ', map { qq{"$_"} } @$switches; 1724 1725 return qq{\$(ABSPERLRUN) $switches -e $cmd}; 1726} 1727 1728 1729=item B<echo> 1730 1731perl trips up on "<foo>" thinking it's an input redirect. So we use the 1732native Write command instead. Besides, its faster. 1733 1734=cut 1735 1736sub echo { 1737 my($self, $text, $file, $appending) = @_; 1738 $appending ||= 0; 1739 1740 my $opencmd = $appending ? 'Open/Append' : 'Open/Write'; 1741 1742 my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file "); 1743 push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_) } 1744 split /\n/, $text; 1745 push @cmds, '$(NOECHO) Close MMECHOFILE'; 1746 return @cmds; 1747} 1748 1749 1750=item quote_literal 1751 1752=cut 1753 1754sub quote_literal { 1755 my($self, $text) = @_; 1756 1757 # I believe this is all we should need. 1758 $text =~ s{"}{""}g; 1759 1760 return qq{"$text"}; 1761} 1762 1763=item escape_newlines 1764 1765=cut 1766 1767sub escape_newlines { 1768 my($self, $text) = @_; 1769 1770 $text =~ s{\n}{-\n}g; 1771 1772 return $text; 1773} 1774 1775=item max_exec_len 1776 1777256 characters. 1778 1779=cut 1780 1781sub max_exec_len { 1782 my $self = shift; 1783 1784 return $self->{_MAX_EXEC_LEN} ||= 256; 1785} 1786 1787=item init_linker 1788 1789=cut 1790 1791sub init_linker { 1792 my $self = shift; 1793 $self->{EXPORT_LIST} ||= '$(BASEEXT).opt'; 1794 1795 my $shr = $Config{dbgprefix} . 'PERLSHR'; 1796 if ($self->{PERL_SRC}) { 1797 $self->{PERL_ARCHIVE} ||= 1798 $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}"); 1799 } 1800 else { 1801 $self->{PERL_ARCHIVE} ||= 1802 $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"; 1803 } 1804 1805 $self->{PERL_ARCHIVE_AFTER} ||= ''; 1806} 1807 1808=item eliminate_macros 1809 1810Expands MM[KS]/Make macros in a text string, using the contents of 1811identically named elements of C<%$self>, and returns the result 1812as a file specification in Unix syntax. 1813 1814NOTE: This is the canonical version of the method. The version in 1815File::Spec::VMS is deprecated. 1816 1817=cut 1818 1819sub eliminate_macros { 1820 my($self,$path) = @_; 1821 return '' unless $path; 1822 $self = {} unless ref $self; 1823 1824 if ($path =~ /\s/) { 1825 return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; 1826 } 1827 1828 my($npath) = unixify($path); 1829 # sometimes unixify will return a string with an off-by-one trailing null 1830 $npath =~ s{\0$}{}; 1831 1832 my($complex) = 0; 1833 my($head,$macro,$tail); 1834 1835 # perform m##g in scalar context so it acts as an iterator 1836 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 1837 if (defined $self->{$2}) { 1838 ($head,$macro,$tail) = ($1,$2,$3); 1839 if (ref $self->{$macro}) { 1840 if (ref $self->{$macro} eq 'ARRAY') { 1841 $macro = join ' ', @{$self->{$macro}}; 1842 } 1843 else { 1844 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), 1845 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; 1846 $macro = "\cB$macro\cB"; 1847 $complex = 1; 1848 } 1849 } 1850 else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } 1851 $npath = "$head$macro$tail"; 1852 } 1853 } 1854 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } 1855 $npath; 1856} 1857 1858=item fixpath 1859 1860 my $path = $mm->fixpath($path); 1861 my $path = $mm->fixpath($path, $is_dir); 1862 1863Catchall routine to clean up problem MM[SK]/Make macros. Expands macros 1864in any directory specification, in order to avoid juxtaposing two 1865VMS-syntax directories when MM[SK] is run. Also expands expressions which 1866are all macro, so that we can tell how long the expansion is, and avoid 1867overrunning DCL's command buffer when MM[KS] is running. 1868 1869fixpath() checks to see whether the result matches the name of a 1870directory in the current default directory and returns a directory or 1871file specification accordingly. C<$is_dir> can be set to true to 1872force fixpath() to consider the path to be a directory or false to force 1873it to be a file. 1874 1875NOTE: This is the canonical version of the method. The version in 1876File::Spec::VMS is deprecated. 1877 1878=cut 1879 1880sub fixpath { 1881 my($self,$path,$force_path) = @_; 1882 return '' unless $path; 1883 $self = bless {} unless ref $self; 1884 my($fixedpath,$prefix,$name); 1885 1886 if ($path =~ /[ \t]/) { 1887 return join ' ', 1888 map { $self->fixpath($_,$force_path) } 1889 split /[ \t]+/, $path; 1890 } 1891 1892 if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 1893 if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { 1894 $fixedpath = vmspath($self->eliminate_macros($path)); 1895 } 1896 else { 1897 $fixedpath = vmsify($self->eliminate_macros($path)); 1898 } 1899 } 1900 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { 1901 my($vmspre) = $self->eliminate_macros("\$($prefix)"); 1902 # is it a dir or just a name? 1903 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; 1904 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; 1905 $fixedpath = vmspath($fixedpath) if $force_path; 1906 } 1907 else { 1908 $fixedpath = $path; 1909 $fixedpath = vmspath($fixedpath) if $force_path; 1910 } 1911 # No hints, so we try to guess 1912 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { 1913 $fixedpath = vmspath($fixedpath) if -d $fixedpath; 1914 } 1915 1916 # Trim off root dirname if it's had other dirs inserted in front of it. 1917 $fixedpath =~ s/\.000000([\]>])/$1/; 1918 # Special case for VMS absolute directory specs: these will have had device 1919 # prepended during trip through Unix syntax in eliminate_macros(), since 1920 # Unix syntax has no way to express "absolute from the top of this device's 1921 # directory tree". 1922 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } 1923 1924 return $fixedpath; 1925} 1926 1927 1928=item os_flavor 1929 1930VMS is VMS. 1931 1932=cut 1933 1934sub os_flavor { 1935 return('VMS'); 1936} 1937 1938=back 1939 1940 1941=head1 AUTHOR 1942 1943Original author Charles Bailey F<bailey@newman.upenn.edu> 1944 1945Maintained by Michael G Schwern F<schwern@pobox.com> 1946 1947See L<ExtUtils::MakeMaker> for patching and contact information. 1948 1949 1950=cut 1951 19521; 1953 1954