[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.2808_01';
$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;

  map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 }
     ($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; }

=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);
	5	$VERSION = '0.2808_01';
	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
	139	map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 }
	140	($got_arrayref ? @{$args[0]}
	141	: @args
	142	);
	143
	144	return $got_arrayref ? $args[0]
	145	: join(' ', @args);
a314697d	146	}
a314697d	147
77e96e88	148	=item have_forkpipe
	149
	150	There is no native fork(), so some constructs depending on it are not
	151	available.
	152
	153	=cut
	154
dc8021d3	155	sub have_forkpipe { 0 }
a314697d	156
77e96e88	157	=item _backticks
	158
	159	Override to ensure that we quote the arguments but not the command.
	160
	161	=cut
	162
	163	sub _backticks {
	164	# The command must not be quoted but the arguments to it must be.
	165	my ($self, @cmd) = @_;
	166	my $cmd = shift @cmd;
	167	my $args = $self->_quote_args(@cmd);
	168	return `$cmd $args`;
	169	}
	170
	171	=item do_system
	172
	173	Override to ensure that we quote the arguments but not the command.
	174
	175	=cut
	176
	177	sub do_system {
	178	# The command must not be quoted but the arguments to it must be.
	179	my ($self, @cmd) = @_;
	180	$self->log_info("@cmd\n");
	181	my $cmd = shift @cmd;
	182	my $args = $self->_quote_args(@cmd);
	183	return !system("$cmd $args");
	184	}
	185
	186	=item _infer_xs_spec
	187
	188	Inherit the standard version but tweak the library file name to be
	189	something Dynaloader can find.
	190
	191	=cut
	192
	193	sub _infer_xs_spec {
	194	my $self = shift;
	195	my $file = shift;
	196
	197	my $spec = $self->SUPER::_infer_xs_spec($file);
	198
	199	# Need to create with the same name as DynaLoader will load with.
	200	if (defined &DynaLoader::mod2fname) {
f82d2ab4	201	my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
	202	$file =~ tr/:/_/;
	203	$file = DynaLoader::mod2fname([$file]);
d9103e67	204	$$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
77e96e88	205	}
	206
	207	return $spec;
	208	}
	209
d9103e67	210	=item rscan_dir
	211
	212	Inherit the standard version but remove dots at end of name. This may not be
	213	necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
	214
	215	=cut
	216
	217	sub rscan_dir {
	218	my ($self, $dir, $pattern) = @_;
	219
	220	my $result = $self->SUPER::rscan_dir( $dir, $pattern );
	221
	222	for my $file (@$result) { $file =~ s/\.$//; }
	223	return $result;
	224	}
	225
f82d2ab4	226	=item dist_dir
	227
	228	Inherit the standard version but replace embedded dots with underscores because
	229	a dot is the directory delimiter on VMS.
	230
	231	=cut
	232
	233	sub dist_dir {
	234	my $self = shift;
	235
	236	my $dist_dir = $self->SUPER::dist_dir;
	237	$dist_dir =~ s/\./_/g;
	238	return $dist_dir;
	239	}
	240
	241	=item man3page_name
	242
	243	Inherit the standard version but chop the extra manpage delimiter off the front if
	244	there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
	245
	246	=cut
	247
	248	sub man3page_name {
	249	my $self = shift;
	250
	251	my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0	252	my $sep = $self->manpage_separator;
d1bd4ef0	253	$mpname =~ s/^$sep//;
f82d2ab4	254	return $mpname;
	255	}
	256
01f3e2c1	257	=item expand_test_dir
f82d2ab4	258
01f3e2c1	259	Inherit the standard version but relativize the paths as the native glob() doesn't
01f3e2c1	260	do that for us.
f82d2ab4	261
01f3e2c1	262	=cut
	263
	264	sub expand_test_dir {
	265	my ($self, $dir) = @_;
	266
	267	my @reldirs = $self->SUPER::expand_test_dir( $dir );
	268
	269	for my $eachdir (@reldirs) {
	270	my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
	271	my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
	272	$eachdir = File::Spec->catfile( $reldir, $f );
	273	}
	274	return @reldirs;
f82d2ab4	275	}
d9103e67	276
3776488a	277	=item _detildefy
	278
	279	The home-grown glob() does not currently handle tildes, so provide limited support
	280	here. Expect only UNIX format file specifications for now.
	281
	282	=cut
	283
	284	sub _detildefy {
	285	my ($self, $arg) = @_;
	286
	287	# Apparently double ~ are not translated.
	288	return $arg if ($arg =~ /^~~/);
	289
	290	# Apparently ~ followed by whitespace are not translated.
	291	return $arg if ($arg =~ /^~ /);
	292
	293	if ($arg =~ /^~/) {
	294	my $spec = $arg;
	295
	296	# Remove the tilde
	297	$spec =~ s/^~//;
	298
	299	# Remove any slash folloing the tilde if present.
	300	$spec =~ s#^/##;
	301
	302	# break up the paths for the merge
	303	my $home = VMS::Filespec::unixify($ENV{HOME});
	304
	305	# Trivial case of just ~ by it self
	306	if ($spec eq '') {
	307	return $home;
	308	}
	309
	310	my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
	311	if ($hdir eq '') {
	312	# Someone has tampered with $ENV{HOME}
	313	# So hfile is probably the directory since this should be
	314	# a path.
	315	$hdir = $hfile;
	316	}
	317
	318	my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
	319
	320	my @hdirs = File::Spec::Unix->splitdir($hdir);
	321	my @dirs = File::Spec::Unix->splitdir($dir);
	322
	323	my $newdirs;
	324
	325	# Two cases of tilde handling
	326	if ($arg =~ m#^~/#) {
	327
	328	# Simple case, just merge together
	329	$newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
	330
	331	} else {
	332
	333	# Complex case, need to add an updir - No delimiters
	334	my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
	335
	336	$newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
	337
	338	}
	339
	340	# Now put the two cases back together
341	$arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
342
343	} else {
344	return $arg;
345	}
346
347	}
348
fca1d8b3	349	=item find_perl_interpreter
fca1d8b3	350
7a827510	351	On VMS, $^X returns the fully qualified absolute path including version
	352	number. It's logically impossible to improve on it for getting the perl
	353	we're currently running, and attempting to manipulate it is usually
	354	lossy.
fca1d8b3	355
	356	=cut
	357
	358	sub find_perl_interpreter { return $^X; }
	359
bb4e9162	360	=back
	361
	362	=head1 AUTHOR
	363
f82d2ab4	364	Michael G Schwern <schwern@pobox.com>
	365	Ken Williams <kwilliams@cpan.org>
	366	Craig A. Berry <craigberry@mac.com>
bb4e9162	367
	368	=head1 SEE ALSO
	369
	370	perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
	371
	372	=cut
	373
	374	1;
	375	__END__