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