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