diff options
author | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
commit | b56b320b5e2515160073fa1b469514002688fe11 (patch) | |
tree | 965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/lib/Module/Build/Platform/VMS.pm | |
parent | d26c206452d2e285c3bbf949f34011e4a55fd8f9 (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.pm | 523 |
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__ |