summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
committerKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
commitb56b320b5e2515160073fa1b469514002688fe11 (patch)
tree965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm
parentd26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff)
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm523
1 files changed, 0 insertions, 523 deletions
diff --git a/Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm b/Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm
deleted file mode 100644
index 5b06baa5f87..00000000000
--- a/Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm
+++ /dev/null
@@ -1,523 +0,0 @@
-package Module::Build::Platform::VMS;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Base;
-use Config;
-
-use vars qw(@ISA);
-@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
- && UNIVERSAL::isa($args[0], '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__