[p5sagit/p5-mst-13.2.git] / lib / Module / Build / Platform / VMS.pm

package Module::Build::Platform::VMS;

use strict;
use vars qw($VERSION);
$VERSION = '0.31012';
$VERSION = eval $VERSION;
use Module::Build::Base;

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 _prefixify {
    my($self, $path, $sprefix, $type) = @_;
    my $rprefix = $self->prefix;

    $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 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_info("@cmd\n");
  my $cmd = shift @cmd;
  my $args = $self->_quote_args(@cmd);
  return !system("$cmd $args");
}

=item _infer_xs_spec

Inherit the standard version but tweak the library file name to be 
something Dynaloader can find.

=cut

sub _infer_xs_spec {
  my $self = shift;
  my $file = shift;

  my $spec = $self->SUPER::_infer_xs_spec($file);

  # Need to create with the same name as DynaLoader will load with.
  if (defined &DynaLoader::mod2fname) {
    my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
    $file =~ tr/:/_/;
    $file = DynaLoader::mod2fname([$file]);
    $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
  }

  return $spec;
}

=item rscan_dir

Inherit the standard version but remove dots at end of name.  This may not be 
necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.

=cut

sub rscan_dir {
  my ($self, $dir, $pattern) = @_;

  my $result = $self->SUPER::rscan_dir( $dir, $pattern );

  for my $file (@$result) { $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;
  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 folloing the tilde if present.
        $spec =~ s#^/##;

        # break up the paths for the merge
        my $home = VMS::Filespec::unixify($ENV{HOME});

        # Trivial case of just ~ by it self
        if ($spec eq '') {
            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);

        my $newdirs;

        # Two cases of tilde handling
        if ($arg =~ m#^~/#) {

            # Simple case, just merge together
            $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);

        } else {

            # Complex case, need to add an updir - No delimiters
            my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);

            $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);

        }
        
        # Now put the two cases back together
        $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);

    } else {
        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 $^X; }

=item localize_file_path

Convert the file path to the local syntax

=cut

sub localize_file_path {
  my ($self, $path) = @_;
  $path =~ s/\.\z//;
  return VMS::Filespec::vmsify($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);
}

=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__
Commit	Line	Data
bb4e9162	1	package Module::Build::Platform::VMS;
	2
	3	use strict;
7a827510	4	use vars qw($VERSION);
15cb7b9d	5	$VERSION = '0.31012';
7a827510	6	$VERSION = eval $VERSION;
bb4e9162	7	use Module::Build::Base;
	8
	9	use vars qw(@ISA);
	10	@ISA = qw(Module::Build::Base);
	11
	12
	13
	14	=head1 NAME
	15
	16	Module::Build::Platform::VMS - Builder class for VMS platforms
	17
	18	=head1 DESCRIPTION
	19
	20	This module inherits from C<Module::Build::Base> and alters a few
	21	minor details of its functionality. Please see L<Module::Build> for
	22	the general docs.
	23
	24	=head2 Overridden Methods
	25
	26	=over 4
	27
77e96e88	28	=item _set_defaults
bb4e9162	29
	30	Change $self->{build_script} to 'Build.com' so @Build works.
	31
	32	=cut
	33
77e96e88	34	sub _set_defaults {
	35	my $self = shift;
	36	$self->SUPER::_set_defaults(@_);
bb4e9162	37
bb4e9162	38	$self->{properties}{build_script} = 'Build.com';
bb4e9162	39	}
	40
	41
	42	=item cull_args
	43
	44	'@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
	45	people to write '@Build "foo"' we'll dispatch case-insensitively.
	46
	47	=cut
	48
	49	sub cull_args {
	50	my $self = shift;
	51	my($action, $args) = $self->SUPER::cull_args(@_);
	52	my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
	53
	54	die "Ambiguous action '$action'. Could be one of @possible_actions"
	55	if @possible_actions > 1;
	56
	57	return ($possible_actions[0], $args);
	58	}
	59
	60
	61	=item manpage_separator
	62
	63	Use '__' instead of '::'.
	64
	65	=cut
	66
	67	sub manpage_separator {
	68	return '__';
	69	}
	70
	71
	72	=item prefixify
	73
	74	Prefixify taking into account VMS' filepath syntax.
	75
	76	=cut
	77
	78	# Translated from ExtUtils::MM_VMS::prefixify()
	79	sub _prefixify {
	80	my($self, $path, $sprefix, $type) = @_;
	81	my $rprefix = $self->prefix;
	82
	83	$self->log_verbose(" prefixify $path from $sprefix to $rprefix\n");
	84
	85	# Translate $(PERLPREFIX) to a real path.
bb4e9162	86	$rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
	87	$sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
	88
	89	$self->log_verbose(" rprefix translated to $rprefix\n".
	90	" sprefix translated to $sprefix\n");
	91
	92	if( length $path == 0 ) {
	93	$self->log_verbose(" no path to prefixify.\n")
	94	}
	95	elsif( !File::Spec->file_name_is_absolute($path) ) {
	96	$self->log_verbose(" path is relative, not prefixifying.\n");
	97	}
	98	elsif( $sprefix eq $rprefix ) {
	99	$self->log_verbose(" no new prefix.\n");
	100	}
	101	else {
	102	my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
77e96e88	103	my $vms_prefix = $self->config('vms_prefix');
bb4e9162	104	if( $path_vol eq $vms_prefix.':' ) {
	105	$self->log_verbose(" $vms_prefix: seen\n");
	106
	107	$path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
	108	$path = $self->_catprefix($rprefix, $path_dirs);
	109	}
	110	else {
	111	$self->log_verbose(" cannot prefixify.\n");
	112	return $self->prefix_relpaths($self->installdirs, $type);
	113	}
	114	}
	115
	116	$self->log_verbose(" now $path\n");
	117
	118	return $path;
	119	}
	120
77e96e88	121	=item _quote_args
	122
	123	Command-line arguments (but not the command itself) must be quoted
	124	to ensure case preservation.
	125
	126	=cut
bb4e9162	127
a314697d	128	sub _quote_args {
a314697d	129	# Returns a string that can become [part of] a command line with
77e96e88	130	# proper quoting so that the subprocess sees this same list of args,
	131	# or if we get a single arg that is an array reference, quote the
	132	# elements of it and return the reference.
a314697d	133	my ($self, @args) = @_;
77e96e88	134	my $got_arrayref = (scalar(@args) == 1
	135	&& UNIVERSAL::isa($args[0], 'ARRAY'))
	136	? 1
	137	: 0;
	138
738349a8	139	# Do not quote qualifiers that begin with '/'.
	140	map { if (!/^\//) {
	141	$_ =~ s/\"/""/g; # escape C<"> by doubling
	142	$_ = q(").$_.q(");
	143	}
	144	}
	145	($got_arrayref ? @{$args[0]}
	146	: @args
	147	);
77e96e88	148
	149	return $got_arrayref ? $args[0]
	150	: join(' ', @args);
a314697d	151	}
a314697d	152
77e96e88	153	=item have_forkpipe
	154
	155	There is no native fork(), so some constructs depending on it are not
	156	available.
	157
	158	=cut
	159
dc8021d3	160	sub have_forkpipe { 0 }
a314697d	161
77e96e88	162	=item _backticks
	163
	164	Override to ensure that we quote the arguments but not the command.
	165
	166	=cut
	167
	168	sub _backticks {
	169	# The command must not be quoted but the arguments to it must be.
	170	my ($self, @cmd) = @_;
	171	my $cmd = shift @cmd;
	172	my $args = $self->_quote_args(@cmd);
	173	return `$cmd $args`;
	174	}
	175
	176	=item do_system
	177
	178	Override to ensure that we quote the arguments but not the command.
	179
	180	=cut
	181
	182	sub do_system {
	183	# The command must not be quoted but the arguments to it must be.
	184	my ($self, @cmd) = @_;
	185	$self->log_info("@cmd\n");
	186	my $cmd = shift @cmd;
	187	my $args = $self->_quote_args(@cmd);
	188	return !system("$cmd $args");
	189	}
	190
	191	=item _infer_xs_spec
	192
	193	Inherit the standard version but tweak the library file name to be
	194	something Dynaloader can find.
	195
	196	=cut
	197
	198	sub _infer_xs_spec {
	199	my $self = shift;
	200	my $file = shift;
	201
	202	my $spec = $self->SUPER::_infer_xs_spec($file);
	203
	204	# Need to create with the same name as DynaLoader will load with.
	205	if (defined &DynaLoader::mod2fname) {
f82d2ab4	206	my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
	207	$file =~ tr/:/_/;
	208	$file = DynaLoader::mod2fname([$file]);
d9103e67	209	$$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
77e96e88	210	}
	211
	212	return $spec;
	213	}
	214
d9103e67	215	=item rscan_dir
	216
	217	Inherit the standard version but remove dots at end of name. This may not be
	218	necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
	219
	220	=cut
	221
	222	sub rscan_dir {
	223	my ($self, $dir, $pattern) = @_;
	224
	225	my $result = $self->SUPER::rscan_dir( $dir, $pattern );
	226
	227	for my $file (@$result) { $file =~ s/\.$//; }
	228	return $result;
	229	}
	230
f82d2ab4	231	=item dist_dir
	232
	233	Inherit the standard version but replace embedded dots with underscores because
	234	a dot is the directory delimiter on VMS.
	235
	236	=cut
	237
	238	sub dist_dir {
	239	my $self = shift;
	240
	241	my $dist_dir = $self->SUPER::dist_dir;
	242	$dist_dir =~ s/\./_/g;
	243	return $dist_dir;
	244	}
	245
	246	=item man3page_name
	247
	248	Inherit the standard version but chop the extra manpage delimiter off the front if
	249	there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
	250
	251	=cut
	252
	253	sub man3page_name {
	254	my $self = shift;
	255
	256	my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0	257	my $sep = $self->manpage_separator;
d1bd4ef0	258	$mpname =~ s/^$sep//;
f82d2ab4	259	return $mpname;
	260	}
	261
01f3e2c1	262	=item expand_test_dir
f82d2ab4	263
01f3e2c1	264	Inherit the standard version but relativize the paths as the native glob() doesn't
01f3e2c1	265	do that for us.
f82d2ab4	266
01f3e2c1	267	=cut
	268
	269	sub expand_test_dir {
	270	my ($self, $dir) = @_;
	271
	272	my @reldirs = $self->SUPER::expand_test_dir( $dir );
	273
	274	for my $eachdir (@reldirs) {
	275	my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
	276	my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
	277	$eachdir = File::Spec->catfile( $reldir, $f );
	278	}
	279	return @reldirs;
f82d2ab4	280	}
d9103e67	281
3776488a	282	=item _detildefy
	283
	284	The home-grown glob() does not currently handle tildes, so provide limited support
	285	here. Expect only UNIX format file specifications for now.
	286
	287	=cut
	288
	289	sub _detildefy {
	290	my ($self, $arg) = @_;
	291
	292	# Apparently double ~ are not translated.
	293	return $arg if ($arg =~ /^~~/);
	294
	295	# Apparently ~ followed by whitespace are not translated.
	296	return $arg if ($arg =~ /^~ /);
	297
	298	if ($arg =~ /^~/) {
	299	my $spec = $arg;
	300
	301	# Remove the tilde
	302	$spec =~ s/^~//;
	303
	304	# Remove any slash folloing the tilde if present.
	305	$spec =~ s#^/##;
	306
	307	# break up the paths for the merge
	308	my $home = VMS::Filespec::unixify($ENV{HOME});
	309
	310	# Trivial case of just ~ by it self
	311	if ($spec eq '') {
	312	return $home;
	313	}
	314
	315	my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
	316	if ($hdir eq '') {
	317	# Someone has tampered with $ENV{HOME}
	318	# So hfile is probably the directory since this should be
	319	# a path.
	320	$hdir = $hfile;
	321	}
	322
	323	my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
	324
	325	my @hdirs = File::Spec::Unix->splitdir($hdir);
	326	my @dirs = File::Spec::Unix->splitdir($dir);
	327
	328	my $newdirs;
	329
	330	# Two cases of tilde handling
	331	if ($arg =~ m#^~/#) {
	332
	333	# Simple case, just merge together
	334	$newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
	335
	336	} else {
	337
	338	# Complex case, need to add an updir - No delimiters
	339	my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
	340
	341	$newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
	342
	343	}
	344
	345	# Now put the two cases back together
346	$arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
347
348	} else {
349	return $arg;
350	}
351
352	}
353
fca1d8b3	354	=item find_perl_interpreter
fca1d8b3	355
7a827510	356	On VMS, $^X returns the fully qualified absolute path including version
	357	number. It's logically impossible to improve on it for getting the perl
	358	we're currently running, and attempting to manipulate it is usually
	359	lossy.
fca1d8b3	360
	361	=cut
	362
	363	sub find_perl_interpreter { return $^X; }
	364
738349a8	365	=item localize_file_path
	366
	367	Convert the file path to the local syntax
	368
	369	=cut
	370
	371	sub localize_file_path {
	372	my ($self, $path) = @_;
	373	$path =~ s/\.\z//;
	374	return VMS::Filespec::vmsify($path);
	375	}
	376
	377	=item localize_dir_path
	378
	379	Convert the directory path to the local syntax
	380
	381	=cut
	382
	383	sub localize_dir_path {
	384	my ($self, $path) = @_;
	385	return VMS::Filespec::vmspath($path);
	386	}
	387
bb4e9162	388	=back
	389
	390	=head1 AUTHOR
	391
f82d2ab4	392	Michael G Schwern <schwern@pobox.com>
	393	Ken Williams <kwilliams@cpan.org>
	394	Craig A. Berry <craigberry@mac.com>
bb4e9162	395
	396	=head1 SEE ALSO
	397
	398	perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
	399
	400	=cut
	401
	402	1;
	403	__END__