| Subject: | [PATCH] VMS update |
The attached patch builds on something John Malmberg posted to p5p, but his was against
blead and this is against M::B trunk at revision 11420. This also goes further with a few things,
such as getting ext.t to pass.
| Subject: | mb_vms_20080614.patch |
--- lib/Module/Build.pm;-0 Fri May 30 18:45:02 2008
+++ lib/Module/Build.pm Sun Jun 1 16:36:23 2008
@@ -99,9 +99,7 @@ if (grep {-e File::Spec->catfile($_, qw(
sub os_type { $OSTYPES{$^O} }
-sub is_vmsish {
- return ((os_type() || '') eq 'VMS' && $Config::Config{make} =~ /MM[K|S]/i)
-}
+sub is_vmsish { return ((os_type() || '') eq 'VMS') }
sub is_windowsish { return ((os_type() || '') eq 'Windows') }
sub is_unixish { return ((os_type() || '') eq 'Unix') }
--- lib/Module/Build/Compat.pm;-0 Fri May 30 18:45:02 2008
+++ lib/Module/Build/Compat.pm Thu Jun 5 13:40:45 2008
@@ -181,18 +181,7 @@ sub makefile_to_build_args {
die "Malformed argument '$arg'");
# Do tilde-expansion if it looks like a tilde prefixed path
- if ($val =~ /^~/) {
- if ($^O ne 'VMS') {
- ( $val ) = glob( $val );
- } else {
- # TODO Home grown glob for Perl/VMS can not handle ~ yet.
- # Can not use is_vmsish because this is for all instances
- # of perl on VMS, not just when MMS/MMK is being used.
-
- my $class = 'Module::Build';
- ( $val ) = $class->_detildefy($val);
- }
- }
+ ( $val ) = Module::Build->_detildefy( $val ) if $val =~ /^~/;
if (exists $makefile_to_build{$key}) {
my $trans = $makefile_to_build{$key};
@@ -249,13 +238,12 @@ sub fake_makefile {
my $perl = $class->find_perl_interpreter;
# VMS MMS/MMK need to use MCR to run the Perl image.
- $perl = 'MCR ' . $perl if $class->is_vmsish;
+ $perl = 'MCR ' . $perl if $self->_is_vms_mms;
my $noop = ($class->is_windowsish ? 'rem>nul' :
- $class->is_vmsish ? 'Continue' :
+ $self->_is_vms_mms ? 'Continue' :
'true');
- # VMS has different file type.
my $filetype = $class->is_vmsish ? '.COM' : '';
my $Build = 'Build' . $filetype . ' --makefile_env_macros 1';
@@ -265,7 +253,7 @@ all : force_do_it
$perl $Build
realclean : force_do_it
$perl $Build realclean
- $perl -e 1 -e while -e unlink -e shift $args{makefile}
+ $perl -e 1 -e while -e unlink -e q=$args{makefile}=
force_do_it :
@ $noop
@@ -279,10 +267,17 @@ $action : force_do_it
EOF
}
- # MMS/MMK on VMS do not support .EXPORT
-
- $maketext .= "\n.EXPORT : " . join(' ', keys %makefile_to_build) . "\n\n"
- unless $class->is_vmsish;
+ if ($self->_is_vms_mms) {
+ # Roll our own .EXPORT as MMS/MMK don't honor that directive.
+ $maketext .= "\n.FIRST\n\t\@ $noop\n";
+ for my $macro (keys %makefile_to_build) {
+ $maketext .= ".IFDEF $macro\n\tDEFINE $macro \"\$($macro)\"\n.ENDIF\n";
+ }
+ $maketext .= "\n";
+ }
+ else {
+ $maketext .= "\n.EXPORT : " . join(' ', keys %makefile_to_build) . "\n\n";
+ }
return $maketext;
}
@@ -314,7 +309,7 @@ sub write_makefile {
$in{build_class} = 'Module::Build';
}
my $class = $in{build_class};
- $in{makefile} ||= $class->is_vmsish ? 'Descrip.MMS' : 'Makefile';
+ $in{makefile} ||= $pack->_is_vms_mms ? 'Descrip.MMS' : 'Makefile';
open MAKE, "> $in{makefile}" or die "Cannot write $in{makefile}: $!";
print MAKE $pack->fake_prereqs;
@@ -322,6 +317,10 @@ sub write_makefile {
close MAKE;
}
+sub _is_vms_mms {
+ return Module::Build->is_vmsish && ($Config{make} =~ m/MM[SK]/i);
+}
+
1;
__END__
--- lib/Module/Build/Platform/VMS.pm;-0 Fri May 30 19:07:54 2008
+++ lib/Module/Build/Platform/VMS.pm Sat Jun 14 16:45:01 2008
@@ -136,12 +136,15 @@ sub _quote_args {
? 1
: 0;
- # Do not quote qualifiers that begin with '/' or already
- # quoted arguments.
- map { $_ = q(").$_.q(") if !/^[\"|\/]/ && length($_) > 0 }
- ($got_arrayref ? @{$args[0]}
- : @args
- );
+ # 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);
--- t/compat.t;-0 Fri May 30 18:45:01 2008
+++ t/compat.t Sat May 31 17:45:03 2008
@@ -23,6 +23,8 @@ if ( $Config{make} && $^O ne 'VMS' ? fin
plan skip_all => "Don't know how to invoke 'make'";
}
+my $is_vms_mms = ($^O eq 'VMS') && ($Config{make} =~ /MM[SK]/i);
+
use_ok 'Module::Build';
ensure_blib('Module::Build');
@@ -51,8 +53,7 @@ my @make = $Config{make} eq 'nmake' ? ('
my $makefile = 'Makefile';
# VMS MMK/MMS by convention use Descrip.MMS
-
-if ($^O eq 'VMS' && $Config::Config{make} =~ /MM[K|S]/i) {
+if ($is_vms_mms) {
$makefile = 'Descrip.MMS';
}
@@ -187,27 +188,14 @@ ok $mb, "Module::Build->new_from_context
my $make_macro = 'TEST_VERBOSE=0';
# VMS MMK/MMS macros use different syntax.
- # and this is not really a MMK/MMS macro, but one expected
- # to be inherited by the child process running Perl.
- my $old_test_verbose = $ENV{TEST_VERBOSE};
- if ($^O eq 'VMS' && $Config::Config{make} =~ /MM[K|S]/i) {
- $make_macro = '';
- $ENV{TEST_VERBOSE} = 0;
+ if ($is_vms_mms) {
+ $make_macro = '/macro=("' . $make_macro . '")';
}
$output = stdout_of( sub {
$ran_ok = $mb->do_system(@make, 'test', $make_macro)
} );
- # Clean up on VMS
- if ($^O eq 'VMS' && $Config::Config{make} =~ /MM[K|S]/i) {
- if (defined $old_test_verbose) {
- $ENV{TEST_VERBOSE} = $old_test_verbose;
- } else {
- delete $ENV{TEST_VERBOSE};
- }
- }
-
ok $ran_ok, "make test without verbose ran ok";
$output =~ s/^/# /gm; # Don't confuse our own test output
like $output,
@@ -215,11 +203,15 @@ ok $mb, "Module::Build->new_from_context
'Should be non-verbose';
(my $libdir2 = $libdir) =~ s/libdir/lbiidr/;
+ my @make_args = ('INSTALLDIRS=vendor', "INSTALLVENDORLIB=$libdir2");
+
+ if ($is_vms_mms) { # VMS MMK/MMS macros use different syntax.
+ $make_args[0] = '/macro=("' . join('","',@make_args) . '")';
+ pop @make_args while scalar(@make_args) > 1;
+ }
($output) = stdout_stderr_of(
sub {
- $ran_ok = $mb->do_system(@make, 'fakeinstall',
- 'INSTALLDIRS=vendor',
- "INSTALLVENDORLIB=$libdir2");
+ $ran_ok = $mb->do_system(@make, 'fakeinstall', @make_args);
}
);
--- t/tilde.t;-0 Fri May 30 18:45:01 2008
+++ t/tilde.t Sat May 31 10:00:41 2008
@@ -38,6 +38,13 @@ my $p = 'install_base';
SKIP: {
my $home = $ENV{HOME} ? $ENV{HOME} : undef;
+
+ if ($^O eq 'VMS') {
+ # Convert the path to UNIX format, trim off the trailing slash
+ $home = VMS::Filespec::unixify($home);
+ $home =~ s#/$##;
+ }
+
unless (defined $home) {
my @info = eval { getpwuid $> };
skip "No home directory for tilde-expansion tests", 14 if $@;
@@ -85,7 +92,16 @@ SKIP: {
skip "No home directory for tilde-expansion tests", 1 if $@;
my ($me, $home) = @info[0,7];
- is( run_sample( $p => "~$me/foo")->$p(), "$home/foo" );
+ my $expected = "$home/foo";
+
+ if ($^O eq 'VMS') {
+ # Convert the path to UNIX format and trim off the trailing slash
+ $home = VMS::Filespec::unixify($home);
+ $home =~ s#/$##;
+ $expected = $home . '/../[^/]+' . '/foo';
+ }
+
+ like( run_sample( $p => "~$me/foo")->$p(), qr($expected)i );
}