523 lines
12 KiB
Perl
523 lines
12 KiB
Perl
package Module::Build::Platform::VMS;
|
|
|
|
use strict;
|
|
use warnings;
|
|
our $VERSION = '0.4231';
|
|
$VERSION = eval $VERSION;
|
|
use Module::Build::Base;
|
|
use Config;
|
|
|
|
our @ISA = qw(Module::Build::Base);
|
|
|
|
|
|
|
|
=head1 NAME
|
|
|
|
Module::Build::Platform::VMS - Builder class for VMS platforms
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module inherits from C<Module::Build::Base> and alters a few
|
|
minor details of its functionality. Please see L<Module::Build> for
|
|
the general docs.
|
|
|
|
=head2 Overridden Methods
|
|
|
|
=over 4
|
|
|
|
=item _set_defaults
|
|
|
|
Change $self->{build_script} to 'Build.com' so @Build works.
|
|
|
|
=cut
|
|
|
|
sub _set_defaults {
|
|
my $self = shift;
|
|
$self->SUPER::_set_defaults(@_);
|
|
|
|
$self->{properties}{build_script} = 'Build.com';
|
|
}
|
|
|
|
|
|
=item cull_args
|
|
|
|
'@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
|
|
people to write '@Build "foo"' we'll dispatch case-insensitively.
|
|
|
|
=cut
|
|
|
|
sub cull_args {
|
|
my $self = shift;
|
|
my($action, $args) = $self->SUPER::cull_args(@_);
|
|
my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
|
|
|
|
die "Ambiguous action '$action'. Could be one of @possible_actions"
|
|
if @possible_actions > 1;
|
|
|
|
return ($possible_actions[0], $args);
|
|
}
|
|
|
|
|
|
=item manpage_separator
|
|
|
|
Use '__' instead of '::'.
|
|
|
|
=cut
|
|
|
|
sub manpage_separator {
|
|
return '__';
|
|
}
|
|
|
|
|
|
=item prefixify
|
|
|
|
Prefixify taking into account VMS' filepath syntax.
|
|
|
|
=cut
|
|
|
|
# Translated from ExtUtils::MM_VMS::prefixify()
|
|
|
|
sub _catprefix {
|
|
my($self, $rprefix, $default) = @_;
|
|
|
|
my($rvol, $rdirs) = File::Spec->splitpath($rprefix);
|
|
if( $rvol ) {
|
|
return File::Spec->catpath($rvol,
|
|
File::Spec->catdir($rdirs, $default),
|
|
''
|
|
)
|
|
}
|
|
else {
|
|
return File::Spec->catdir($rdirs, $default);
|
|
}
|
|
}
|
|
|
|
|
|
sub _prefixify {
|
|
my($self, $path, $sprefix, $type) = @_;
|
|
my $rprefix = $self->prefix;
|
|
|
|
return '' unless defined $path;
|
|
|
|
$self->log_verbose(" prefixify $path from $sprefix to $rprefix\n");
|
|
|
|
# Translate $(PERLPREFIX) to a real path.
|
|
$rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
|
|
$sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
|
|
|
|
$self->log_verbose(" rprefix translated to $rprefix\n".
|
|
" sprefix translated to $sprefix\n");
|
|
|
|
if( length($path) == 0 ) {
|
|
$self->log_verbose(" no path to prefixify.\n")
|
|
}
|
|
elsif( !File::Spec->file_name_is_absolute($path) ) {
|
|
$self->log_verbose(" path is relative, not prefixifying.\n");
|
|
}
|
|
elsif( $sprefix eq $rprefix ) {
|
|
$self->log_verbose(" no new prefix.\n");
|
|
}
|
|
else {
|
|
my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
|
|
my $vms_prefix = $self->config('vms_prefix');
|
|
if( $path_vol eq $vms_prefix.':' ) {
|
|
$self->log_verbose(" $vms_prefix: seen\n");
|
|
|
|
$path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
|
|
$path = $self->_catprefix($rprefix, $path_dirs);
|
|
}
|
|
else {
|
|
$self->log_verbose(" cannot prefixify.\n");
|
|
return $self->prefix_relpaths($self->installdirs, $type);
|
|
}
|
|
}
|
|
|
|
$self->log_verbose(" now $path\n");
|
|
|
|
return $path;
|
|
}
|
|
|
|
=item _quote_args
|
|
|
|
Command-line arguments (but not the command itself) must be quoted
|
|
to ensure case preservation.
|
|
|
|
=cut
|
|
|
|
sub _quote_args {
|
|
# Returns a string that can become [part of] a command line with
|
|
# proper quoting so that the subprocess sees this same list of args,
|
|
# or if we get a single arg that is an array reference, quote the
|
|
# elements of it and return the reference.
|
|
my ($self, @args) = @_;
|
|
my $got_arrayref = (scalar(@args) == 1
|
|
&& ref $args[0] eq 'ARRAY')
|
|
? 1
|
|
: 0;
|
|
|
|
# Do not quote qualifiers that begin with '/'.
|
|
map { if (!/^\//) {
|
|
$_ =~ s/\"/""/g; # escape C<"> by doubling
|
|
$_ = q(").$_.q(");
|
|
}
|
|
}
|
|
($got_arrayref ? @{$args[0]}
|
|
: @args
|
|
);
|
|
|
|
return $got_arrayref ? $args[0]
|
|
: join(' ', @args);
|
|
}
|
|
|
|
=item have_forkpipe
|
|
|
|
There is no native fork(), so some constructs depending on it are not
|
|
available.
|
|
|
|
=cut
|
|
|
|
sub have_forkpipe { 0 }
|
|
|
|
=item _backticks
|
|
|
|
Override to ensure that we quote the arguments but not the command.
|
|
|
|
=cut
|
|
|
|
sub _backticks {
|
|
# The command must not be quoted but the arguments to it must be.
|
|
my ($self, @cmd) = @_;
|
|
my $cmd = shift @cmd;
|
|
my $args = $self->_quote_args(@cmd);
|
|
return `$cmd $args`;
|
|
}
|
|
|
|
=item find_command
|
|
|
|
Local an executable program
|
|
|
|
=cut
|
|
|
|
sub find_command {
|
|
my ($self, $command) = @_;
|
|
|
|
# a lot of VMS executables have a symbol defined
|
|
# check those first
|
|
if ( $^O eq 'VMS' ) {
|
|
require VMS::DCLsym;
|
|
my $syms = VMS::DCLsym->new;
|
|
return $command if scalar $syms->getsym( uc $command );
|
|
}
|
|
|
|
$self->SUPER::find_command($command);
|
|
}
|
|
|
|
# _maybe_command copied from ExtUtils::MM_VMS::maybe_command
|
|
|
|
=item _maybe_command (override)
|
|
|
|
Follows VMS naming conventions for executable files.
|
|
If the name passed in doesn't exactly match an executable file,
|
|
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
|
|
to check for DCL procedure. If this fails, checks directories in DCL$PATH
|
|
and finally F<Sys$System:> for an executable file having the name specified,
|
|
with or without the F<.Exe>-equivalent suffix.
|
|
|
|
=cut
|
|
|
|
sub _maybe_command {
|
|
my($self,$file) = @_;
|
|
return $file if -x $file && ! -d _;
|
|
my(@dirs) = ('');
|
|
my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
|
|
|
|
if ($file !~ m![/:>\]]!) {
|
|
for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
|
|
my $dir = $ENV{"DCL\$PATH;$i"};
|
|
$dir .= ':' unless $dir =~ m%[\]:]$%;
|
|
push(@dirs,$dir);
|
|
}
|
|
push(@dirs,'Sys$System:');
|
|
foreach my $dir (@dirs) {
|
|
my $sysfile = "$dir$file";
|
|
foreach my $ext (@exts) {
|
|
return $file if -x "$sysfile$ext" && ! -d _;
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
=item do_system
|
|
|
|
Override to ensure that we quote the arguments but not the command.
|
|
|
|
=cut
|
|
|
|
sub do_system {
|
|
# The command must not be quoted but the arguments to it must be.
|
|
my ($self, @cmd) = @_;
|
|
$self->log_verbose("@cmd\n");
|
|
my $cmd = shift @cmd;
|
|
my $args = $self->_quote_args(@cmd);
|
|
return !system("$cmd $args");
|
|
}
|
|
|
|
=item oneliner
|
|
|
|
Override to ensure that we do not quote the command.
|
|
|
|
=cut
|
|
|
|
sub oneliner {
|
|
my $self = shift;
|
|
my $oneliner = $self->SUPER::oneliner(@_);
|
|
|
|
$oneliner =~ s/^\"\S+\"//;
|
|
|
|
return "MCR $^X $oneliner";
|
|
}
|
|
|
|
=item rscan_dir
|
|
|
|
Inherit the standard version but remove dots at end of name.
|
|
If the extended character set is in effect, do not remove dots from filenames
|
|
with Unix path delimiters.
|
|
|
|
=cut
|
|
|
|
sub rscan_dir {
|
|
my ($self, $dir, $pattern) = @_;
|
|
|
|
my $result = $self->SUPER::rscan_dir( $dir, $pattern );
|
|
|
|
for my $file (@$result) {
|
|
if (!_efs() && ($file =~ m#/#)) {
|
|
$file =~ s/\.$//;
|
|
}
|
|
}
|
|
return $result;
|
|
}
|
|
|
|
=item dist_dir
|
|
|
|
Inherit the standard version but replace embedded dots with underscores because
|
|
a dot is the directory delimiter on VMS.
|
|
|
|
=cut
|
|
|
|
sub dist_dir {
|
|
my $self = shift;
|
|
|
|
my $dist_dir = $self->SUPER::dist_dir;
|
|
$dist_dir =~ s/\./_/g unless _efs();
|
|
return $dist_dir;
|
|
}
|
|
|
|
=item man3page_name
|
|
|
|
Inherit the standard version but chop the extra manpage delimiter off the front if
|
|
there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
|
|
|
|
=cut
|
|
|
|
sub man3page_name {
|
|
my $self = shift;
|
|
|
|
my $mpname = $self->SUPER::man3page_name( shift );
|
|
my $sep = $self->manpage_separator;
|
|
$mpname =~ s/^$sep//;
|
|
return $mpname;
|
|
}
|
|
|
|
=item expand_test_dir
|
|
|
|
Inherit the standard version but relativize the paths as the native glob() doesn't
|
|
do that for us.
|
|
|
|
=cut
|
|
|
|
sub expand_test_dir {
|
|
my ($self, $dir) = @_;
|
|
|
|
my @reldirs = $self->SUPER::expand_test_dir( $dir );
|
|
|
|
for my $eachdir (@reldirs) {
|
|
my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
|
|
my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
|
|
$eachdir = File::Spec->catfile( $reldir, $f );
|
|
}
|
|
return @reldirs;
|
|
}
|
|
|
|
=item _detildefy
|
|
|
|
The home-grown glob() does not currently handle tildes, so provide limited support
|
|
here. Expect only UNIX format file specifications for now.
|
|
|
|
=cut
|
|
|
|
sub _detildefy {
|
|
my ($self, $arg) = @_;
|
|
|
|
# Apparently double ~ are not translated.
|
|
return $arg if ($arg =~ /^~~/);
|
|
|
|
# Apparently ~ followed by whitespace are not translated.
|
|
return $arg if ($arg =~ /^~ /);
|
|
|
|
if ($arg =~ /^~/) {
|
|
my $spec = $arg;
|
|
|
|
# Remove the tilde
|
|
$spec =~ s/^~//;
|
|
|
|
# Remove any slash following the tilde if present.
|
|
$spec =~ s#^/##;
|
|
|
|
# break up the paths for the merge
|
|
my $home = VMS::Filespec::unixify($ENV{HOME});
|
|
|
|
# In the default VMS mode, the trailing slash is present.
|
|
# In Unix report mode it is not. The parsing logic assumes that
|
|
# it is present.
|
|
$home .= '/' unless $home =~ m#/$#;
|
|
|
|
# Trivial case of just ~ by it self
|
|
if ($spec eq '') {
|
|
$home =~ s#/$##;
|
|
return $home;
|
|
}
|
|
|
|
my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
|
|
if ($hdir eq '') {
|
|
# Someone has tampered with $ENV{HOME}
|
|
# So hfile is probably the directory since this should be
|
|
# a path.
|
|
$hdir = $hfile;
|
|
}
|
|
|
|
my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
|
|
|
|
my @hdirs = File::Spec::Unix->splitdir($hdir);
|
|
my @dirs = File::Spec::Unix->splitdir($dir);
|
|
|
|
unless ($arg =~ m#^~/#) {
|
|
# There is a home directory after the tilde, but it will already
|
|
# be present in in @hdirs so we need to remove it by from @dirs.
|
|
|
|
shift @dirs;
|
|
}
|
|
my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
|
|
|
|
$arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
|
|
}
|
|
return $arg;
|
|
|
|
}
|
|
|
|
=item find_perl_interpreter
|
|
|
|
On VMS, $^X returns the fully qualified absolute path including version
|
|
number. It's logically impossible to improve on it for getting the perl
|
|
we're currently running, and attempting to manipulate it is usually
|
|
lossy.
|
|
|
|
=cut
|
|
|
|
sub find_perl_interpreter {
|
|
return VMS::Filespec::vmsify($^X);
|
|
}
|
|
|
|
=item localize_file_path
|
|
|
|
Convert the file path to the local syntax
|
|
|
|
=cut
|
|
|
|
sub localize_file_path {
|
|
my ($self, $path) = @_;
|
|
$path = VMS::Filespec::vmsify($path);
|
|
$path =~ s/\.\z//;
|
|
return $path;
|
|
}
|
|
|
|
=item localize_dir_path
|
|
|
|
Convert the directory path to the local syntax
|
|
|
|
=cut
|
|
|
|
sub localize_dir_path {
|
|
my ($self, $path) = @_;
|
|
return VMS::Filespec::vmspath($path);
|
|
}
|
|
|
|
=item ACTION_clean
|
|
|
|
The home-grown glob() expands a bit too aggressively when given a bare name,
|
|
so default in a zero-length extension.
|
|
|
|
=cut
|
|
|
|
sub ACTION_clean {
|
|
my ($self) = @_;
|
|
foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
|
|
$self->delete_filetree($item);
|
|
}
|
|
}
|
|
|
|
|
|
# Need to look up the feature settings. The preferred way is to use the
|
|
# VMS::Feature module, but that may not be available to dual life modules.
|
|
|
|
my $use_feature;
|
|
BEGIN {
|
|
if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
|
|
$use_feature = 1;
|
|
}
|
|
}
|
|
|
|
# Need to look up the UNIX report mode. This may become a dynamic mode
|
|
# in the future.
|
|
sub _unix_rpt {
|
|
my $unix_rpt;
|
|
if ($use_feature) {
|
|
$unix_rpt = VMS::Feature::current("filename_unix_report");
|
|
} else {
|
|
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
|
|
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
|
|
}
|
|
return $unix_rpt;
|
|
}
|
|
|
|
# Need to look up the EFS character set mode. This may become a dynamic
|
|
# mode in the future.
|
|
sub _efs {
|
|
my $efs;
|
|
if ($use_feature) {
|
|
$efs = VMS::Feature::current("efs_charset");
|
|
} else {
|
|
my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
|
|
$efs = $env_efs =~ /^[ET1]/i;
|
|
}
|
|
return $efs;
|
|
}
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Michael G Schwern <schwern@pobox.com>
|
|
Ken Williams <kwilliams@cpan.org>
|
|
Craig A. Berry <craigberry@mac.com>
|
|
|
|
=head1 SEE ALSO
|
|
|
|
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
|
|
|
=cut
|
|
|
|
1;
|
|
__END__
|