summaryrefslogtreecommitdiff
path: root/lib/Module/Build/Platform/VMS.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Module/Build/Platform/VMS.pm')
-rw-r--r--lib/Module/Build/Platform/VMS.pm522
1 files changed, 522 insertions, 0 deletions
diff --git a/lib/Module/Build/Platform/VMS.pm b/lib/Module/Build/Platform/VMS.pm
new file mode 100644
index 0000000..ebe8c6c
--- /dev/null
+++ b/lib/Module/Build/Platform/VMS.pm
@@ -0,0 +1,522 @@
+package Module::Build::Platform::VMS;
+
+use strict;
+use warnings;
+our $VERSION = '0.4214';
+$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__
View Lorry Controller Status