—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—

              
package Module::Build::Platform::VMS;
use strict;
use warnings;
our $VERSION = '0.4234';
$VERSION = eval $VERSION;
use Module::Build::Base;
use Config;
our @ISA = qw(Module::Build::Base);
HideShow 20 lines of Pod
=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';
}
HideShow 7 lines of Pod
=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);
}
HideShow 6 lines of Pod
=item manpage_separator
Use '__' instead of '::'.
=cut
sub manpage_separator {
    return '__';
}
HideShow 6 lines of Pod
=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;
}
HideShow 7 lines of Pod
=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);
}
HideShow 7 lines of Pod
=item have_forkpipe
There is no native fork(), so some constructs depending on it are not
available.
=cut
sub have_forkpipe { 0 }
HideShow 6 lines of Pod
=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`;
}
HideShow 6 lines of Pod
=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
HideShow 11 lines of Pod
=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;
}
HideShow 6 lines of Pod
=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");
}
HideShow 6 lines of Pod
=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";
}
HideShow 8 lines of Pod
=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;
}
HideShow 7 lines of Pod
=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;
}
HideShow 7 lines of Pod
=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;
}
HideShow 7 lines of Pod
=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;
}
HideShow 7 lines of Pod
=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;
}
HideShow 9 lines of Pod
=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);
}
HideShow 6 lines of Pod
=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;
}
HideShow 6 lines of Pod
=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);
}
HideShow 7 lines of Pod
=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;
}
HideShow 14 lines of Pod
=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__