[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.31_04';
$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 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 _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 '') {
            $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);

        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);
}

=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);
  }
}

=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);
66e531b6	5	$VERSION = '0.31_04';
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
86bddcbf	191	=item oneliner
	192
	193	Override to ensure that we do not quote the command.
	194
	195	=cut
	196
	197	sub oneliner {
	198	my $self = shift;
	199	my $oneliner = $self->SUPER::oneliner(@_);
	200
	201	$oneliner =~ s/^\"\S+\"//;
	202
	203	return "MCR $^X $oneliner";
	204	}
	205
77e96e88	206	=item _infer_xs_spec
	207
	208	Inherit the standard version but tweak the library file name to be
	209	something Dynaloader can find.
	210
	211	=cut
	212
	213	sub _infer_xs_spec {
	214	my $self = shift;
	215	my $file = shift;
	216
	217	my $spec = $self->SUPER::_infer_xs_spec($file);
	218
	219	# Need to create with the same name as DynaLoader will load with.
	220	if (defined &DynaLoader::mod2fname) {
f82d2ab4	221	my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
	222	$file =~ tr/:/_/;
	223	$file = DynaLoader::mod2fname([$file]);
d9103e67	224	$$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
77e96e88	225	}
	226
	227	return $spec;
	228	}
	229
d9103e67	230	=item rscan_dir
	231
	232	Inherit the standard version but remove dots at end of name. This may not be
	233	necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
	234
	235	=cut
	236
	237	sub rscan_dir {
	238	my ($self, $dir, $pattern) = @_;
	239
	240	my $result = $self->SUPER::rscan_dir( $dir, $pattern );
	241
	242	for my $file (@$result) { $file =~ s/\.$//; }
	243	return $result;
	244	}
	245
f82d2ab4	246	=item dist_dir
	247
	248	Inherit the standard version but replace embedded dots with underscores because
	249	a dot is the directory delimiter on VMS.
	250
	251	=cut
	252
	253	sub dist_dir {
	254	my $self = shift;
	255
	256	my $dist_dir = $self->SUPER::dist_dir;
	257	$dist_dir =~ s/\./_/g;
	258	return $dist_dir;
	259	}
	260
	261	=item man3page_name
	262
	263	Inherit the standard version but chop the extra manpage delimiter off the front if
	264	there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
	265
	266	=cut
	267
	268	sub man3page_name {
	269	my $self = shift;
	270
	271	my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0	272	my $sep = $self->manpage_separator;
d1bd4ef0	273	$mpname =~ s/^$sep//;
f82d2ab4	274	return $mpname;
	275	}
	276
01f3e2c1	277	=item expand_test_dir
f82d2ab4	278
01f3e2c1	279	Inherit the standard version but relativize the paths as the native glob() doesn't
01f3e2c1	280	do that for us.
f82d2ab4	281
01f3e2c1	282	=cut
	283
	284	sub expand_test_dir {
	285	my ($self, $dir) = @_;
	286
	287	my @reldirs = $self->SUPER::expand_test_dir( $dir );
	288
	289	for my $eachdir (@reldirs) {
	290	my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
	291	my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
	292	$eachdir = File::Spec->catfile( $reldir, $f );
	293	}
	294	return @reldirs;
f82d2ab4	295	}
d9103e67	296
3776488a	297	=item _detildefy
	298
	299	The home-grown glob() does not currently handle tildes, so provide limited support
	300	here. Expect only UNIX format file specifications for now.
	301
	302	=cut
	303
	304	sub _detildefy {
	305	my ($self, $arg) = @_;
	306
	307	# Apparently double ~ are not translated.
	308	return $arg if ($arg =~ /^~~/);
	309
	310	# Apparently ~ followed by whitespace are not translated.
	311	return $arg if ($arg =~ /^~ /);
	312
	313	if ($arg =~ /^~/) {
	314	my $spec = $arg;
	315
	316	# Remove the tilde
	317	$spec =~ s/^~//;
	318
	319	# Remove any slash folloing the tilde if present.
	320	$spec =~ s#^/##;
	321
	322	# break up the paths for the merge
	323	my $home = VMS::Filespec::unixify($ENV{HOME});
	324
	325	# Trivial case of just ~ by it self
	326	if ($spec eq '') {
86bddcbf	327	$home =~ s#/$##;
3776488a	328	return $home;
	329	}
	330
	331	my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
	332	if ($hdir eq '') {
	333	# Someone has tampered with $ENV{HOME}
	334	# So hfile is probably the directory since this should be
	335	# a path.
	336	$hdir = $hfile;
	337	}
	338
	339	my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
	340
	341	my @hdirs = File::Spec::Unix->splitdir($hdir);
	342	my @dirs = File::Spec::Unix->splitdir($dir);
	343
	344	my $newdirs;
	345
	346	# Two cases of tilde handling
	347	if ($arg =~ m#^~/#) {
	348
	349	# Simple case, just merge together
	350	$newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
	351
	352	} else {
	353
	354	# Complex case, need to add an updir - No delimiters
	355	my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
	356
	357	$newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
	358
	359	}
	360
	361	# Now put the two cases back together
	362	$arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
	363
	364	} else {
	365	return $arg;
	366	}
	367
	368	}
	369
fca1d8b3	370	=item find_perl_interpreter
fca1d8b3	371
7a827510	372	On VMS, $^X returns the fully qualified absolute path including version
	373	number. It's logically impossible to improve on it for getting the perl
	374	we're currently running, and attempting to manipulate it is usually
	375	lossy.
fca1d8b3	376
	377	=cut
	378
	379	sub find_perl_interpreter { return $^X; }
	380
738349a8	381	=item localize_file_path
	382
	383	Convert the file path to the local syntax
	384
	385	=cut
	386
	387	sub localize_file_path {
	388	my ($self, $path) = @_;
	389	$path =~ s/\.\z//;
	390	return VMS::Filespec::vmsify($path);
	391	}
	392
	393	=item localize_dir_path
	394
	395	Convert the directory path to the local syntax
	396
	397	=cut
	398
	399	sub localize_dir_path {
	400	my ($self, $path) = @_;
	401	return VMS::Filespec::vmspath($path);
	402	}
	403
86bddcbf	404	=item ACTION_clean
	405
	406	The home-grown glob() expands a bit too aggressively when given a bare name,
	407	so default in a zero-length extension.
	408
	409	=cut
	410
	411	sub ACTION_clean {
	412	my ($self) = @_;
	413	foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
	414	$self->delete_filetree($item);
	415	}
	416	}
	417
bb4e9162	418	=back
	419
	420	=head1 AUTHOR
	421
f82d2ab4	422	Michael G Schwern <schwern@pobox.com>
	423	Ken Williams <kwilliams@cpan.org>
	424	Craig A. Berry <craigberry@mac.com>
bb4e9162	425
	426	=head1 SEE ALSO
	427
	428	perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
	429
	430	=cut
	431
	432	1;
	433	__END__