[patch@31988] Revised Module::Build fixes for VMS.
authorJohn E. Malmberg <wb8tyw@qsl.net>
Fri, 28 Sep 2007 08:55:27 +0000 (03:55 -0500)
committerCraig A. Berry <craigberry@mac.com>
Sat, 29 Sep 2007 04:39:50 +0000 (04:39 +0000)
From: "John E. Malmberg" <wb8tyw@qsl.net>
Message-id: <46FD07CF.5040504@qsl.net>

p4raw-id: //depot/perl@31995

lib/Module/Build/Base.pm
lib/Module/Build/Platform/VMS.pm
lib/Module/Build/t/install.t
lib/Module/Build/t/manifypods.t
lib/Module/Build/t/metadata.t
lib/Module/Build/t/runthrough.t

index b2cdb30..3462505 100644 (file)
@@ -2184,7 +2184,8 @@ sub ACTION_testcover {
   # See whether any of the *.pm files have changed since last time
   # testcover was run.  If so, start over.
   if (-e 'cover_db') {
-    my $pm_files = $self->rscan_dir(File::Spec->catdir($self->blib, 'lib'), qr{\.pm$} );
+    my $pm_files = $self->rscan_dir
+        (File::Spec->catdir($self->blib, 'lib'), file_qr('\.pm$') );
     my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});
     
     $self->do_system(qw(cover -delete))
@@ -2246,7 +2247,7 @@ sub process_support_files {
   
   push @{$p->{include_dirs}}, $p->{c_source};
   
-  my $files = $self->rscan_dir($p->{c_source}, qr{\.c(pp)?$});
+  my $files = $self->rscan_dir($p->{c_source}, qr('\.c(pp)?$'));
   foreach my $file (@$files) {
     push @{$p->{objects}}, $self->compile_c($file);
   }
@@ -2318,7 +2319,8 @@ sub find_PL_files {
   }
   
   return unless -d 'lib';
-  return { map {$_, [/^(.*)\.PL$/]} @{ $self->rscan_dir('lib', qr{\.PL$}) } };
+  return { map {$_, [/^(.*)\.PL$/i ]} @{ $self->rscan_dir('lib',
+                                                          file_qr('\.PL$')) } };
 }
 
 sub find_pm_files  { shift->_find_file_by_type('pm',  'lib') }
@@ -2371,7 +2373,7 @@ sub _find_file_by_type {
   return { map {$_, $_}
           map $self->localize_file_path($_),
           grep !/\.\#/,
-          @{ $self->rscan_dir($dir, qr{\.$type$}) } };
+          @{ $self->rscan_dir($dir, file_qr("\\.$type\$")) } };
 }
 
 sub localize_file_path {
@@ -2443,7 +2445,9 @@ sub ACTION_testpod {
     or die "The 'testpod' action requires Test::Pod version 0.95";
 
   my @files = sort keys %{$self->_find_pods($self->libdoc_dirs)},
-                   keys %{$self->_find_pods($self->bindoc_dirs, exclude => [ qr/\.bat$/ ])}
+                   keys %{$self->_find_pods
+                             ($self->bindoc_dirs,
+                              exclude => [ file_qr('\.bat$') ])}
     or die "Couldn't find any POD files to test\n";
 
   { package Module::Build::PodTester;  # Don't want to pollute the main namespace
@@ -2505,7 +2509,7 @@ sub ACTION_manpages {
 
   foreach my $type ( qw(bin lib) ) {
     my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
-                                   exclude => [ qr/\.bat$/ ] );
+                                   exclude => [ file_qr('\.bat$') ] );
     next unless %$files;
 
     my $sub = $self->can("manify_${type}_pods");
@@ -2524,7 +2528,7 @@ sub manify_bin_pods {
   my $self    = shift;
 
   my $files   = $self->_find_pods( $self->{properties}{bindoc_dirs},
-                                   exclude => [ qr/\.bat$/ ] );
+                                   exclude => [ file_qr('\.bat$') ] );
   return unless keys %$files;
 
   my $mandir = File::Spec->catdir( $self->blib, 'bindoc' );
@@ -2607,7 +2611,8 @@ sub ACTION_html {
 
   foreach my $type ( qw(bin lib) ) {
     my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
-                                  exclude => [ qr/\.(?:bat|com|html)$/ ] );
+                                  exclude => 
+                                        [ file_qr('\.(?:bat|com|html)$') ] );
     next unless %$files;
 
     if ( $self->invoked_action eq 'html' ) {
@@ -2634,7 +2639,7 @@ sub htmlify_pods {
   $self->add_to_cleanup('pod2htm*');
 
   my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
-                                exclude => [ qr/\.(?:bat|com|html)$/ ] );
+                                exclude => [ file_qr('\.(?:bat|com|html)$') ] );
   return unless %$pods;  # nothing to do
 
   unless ( -d $htmldir ) {
@@ -2654,7 +2659,7 @@ sub htmlify_pods {
   foreach my $pod ( keys %$pods ) {
 
     my ($name, $path) = File::Basename::fileparse($pods->{$pod},
-                                                 qr{\.(?:pm|plx?|pod)$});
+                                                 file_qr('\.(?:pm|plx?|pod)$'));
     my @dirs = File::Spec->splitdir( File::Spec->canonpath( $path ) );
     pop( @dirs ) if $dirs[-1] eq File::Spec->curdir;
 
@@ -2744,7 +2749,7 @@ sub ACTION_diff {
   delete $installmap->{read};
   delete $installmap->{write};
 
-  my $text_suffix = qr{\.(pm|pod)$};
+  my $text_suffix = file_qr('\.(pm|pod)$');
 
   while (my $localdir = each %$installmap) {
     my @localparts = File::Spec->splitdir($localdir);
@@ -3203,6 +3208,11 @@ sub ACTION_manifest {
   ExtUtils::Manifest::mkmanifest();
 }
 
+# Case insenstive regex for files
+sub file_qr {
+    return File::Spec->case_tolerant ? qr($_[0])i : qr($_[0]);
+}
+
 sub dist_dir {
   my ($self) = @_;
   return "$self->{properties}{dist_name}-$self->{properties}{dist_version}";
@@ -3804,8 +3814,22 @@ sub install_map {
     foreach (keys %map) {
       # Need to remove volume from $map{$_} using splitpath, or else
       # we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
-      my ($volume, $path) = File::Spec->splitpath( $map{$_}, 1 );
-      $map{$_} = File::Spec->catdir($destdir, $path);
+      # VMS will always have the file separate than the path.
+      my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 1 );
+
+      # catdir needs a list of directories, or it will create something
+      # crazy like volume:[Foo.Bar.volume.Baz.Quux]
+      my @dirs = File::Spec->splitdir($path);
+
+      # First merge the directories
+      $path = File::Spec->catdir($destdir, @dirs);
+
+      # Then put the file back on if there is one.
+      if ($file ne '') {
+          $map{$_} = File::Spec->catfile($path, $file)
+      } else {
+          $map{$_} = $path;
+      }
     }
   }
   
index 7485127..31408ed 100644 (file)
@@ -246,7 +246,8 @@ sub man3page_name {
   my $self = shift;
 
   my $mpname = $self->SUPER::man3page_name( shift );
-  $mpname =~ s/^$self->manpage_separator//;
+  my $sep = $self->manpage_separator;
+  $mpname =~ s/^$sep//;
   return $mpname;
 }
 
index 281454d..bfb8f47 100644 (file)
@@ -67,26 +67,27 @@ $mb->add_to_cleanup($destdir);
   eval {$mb->dispatch('install', destdir => $destdir)};
   is $@, '';
   
-  my $libdir = strip_volume( $mb->install_destination('lib') );
-  my $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm';
+  my @libdir = strip_volume( $mb->install_destination('lib') );
+  my $install_to = File::Spec->catfile($destdir, @libdir, $dist->name ) . '.pm';
   file_exists($install_to);
   
-  local @INC = (@INC, File::Spec->catdir($destdir, $libdir));
+  local @INC = (@INC, File::Spec->catdir($destdir, @libdir));
   eval "require @{[$dist->name]}";
   is $@, '';
   
   # Make sure there's a packlist installed
   my $archdir = $mb->install_destination('arch');
-  my ($v, $d) = File::Spec->splitpath($archdir, 1);
-  my $packlist = File::Spec->catdir($destdir, $d, 'auto', $dist->name, '.packlist');
+  my @dirs = strip_volume($archdir);
+  my $packlist = File::Spec->catfile
+                            ($destdir, @dirs, 'auto', $dist->name, '.packlist');
   is -e $packlist, 1, "$packlist should be written";
 }
 
 {
   eval {$mb->dispatch('install', installdirs => 'core', destdir => $destdir)};
   is $@, '';
-  my $libdir = strip_volume( $Config{installprivlib} );
-  my $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm';
+  my @libdir = strip_volume( $Config{installprivlib} );
+  my $install_to = File::Spec->catfile($destdir, @libdir, $dist->name ) . '.pm';
   file_exists($install_to);
 }
 
@@ -94,7 +95,8 @@ $mb->add_to_cleanup($destdir);
   my $libdir = File::Spec->catdir(File::Spec->rootdir, 'foo', 'bar');
   eval {$mb->dispatch('install', install_path => {lib => $libdir}, destdir => $destdir)};
   is $@, '';
-  my $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm';
+  my @dirs = strip_volume($libdir);
+  my $install_to = File::Spec->catfile($destdir, @dirs, $dist->name ) . '.pm';
   file_exists($install_to);
 }
 
@@ -102,7 +104,8 @@ $mb->add_to_cleanup($destdir);
   my $libdir = File::Spec->catdir(File::Spec->rootdir, 'foo', 'base');
   eval {$mb->dispatch('install', install_base => $libdir, destdir => $destdir)};
   is $@, '';
-  my $install_to = File::Spec->catfile($destdir, $libdir, 'lib', 'perl5', $dist->name ) . '.pm';
+  my @dirs = strip_volume($libdir);
+  my $install_to = File::Spec->catfile($destdir, @dirs, 'lib', 'perl5', $dist->name ) . '.pm';
   file_exists($install_to);
 }
 
@@ -115,8 +118,8 @@ $mb->add_to_cleanup($destdir);
   eval {$mb->dispatch('install', destdir => $destdir)};
   is $@, '';
   
-  my $libdir = strip_volume( $mb->install_destination('lib') );
-  local @INC = (@INC, File::Spec->catdir($destdir, $libdir));
+  my @libdir = strip_volume( $mb->install_destination('lib') );
+  local @INC = (@INC, File::Spec->catdir($destdir, @libdir));
   eval "require @{[$dist->name]}::ConfigData";
 
   is $mb->feature('auto_foo'), 1;
@@ -156,13 +159,15 @@ is $@, '';
   eval {$mb->run_perl_script('Build.PL', [], ['--install_path', "lib=$libdir"])};
   is $@, '';
   
-  eval {$mb->run_perl_script('Build', [], ['install', '--destdir', $destdir])};
+  my $cmd = 'Build';
+     $cmd .= ".COM" if $^O eq 'VMS';
+  eval {$mb->run_perl_script($cmd, [], ['install', '--destdir', $destdir])};
   is $@, '';
   my $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm';
   file_exists($install_to);
 
   my $basedir = File::Spec->catdir('', 'bar');
-  eval {$mb->run_perl_script('Build', [], ['install', '--destdir', $destdir,
+  eval {$mb->run_perl_script($cmd, [], ['install', '--destdir', $destdir,
                                              '--install_base', $basedir])};
   is $@, '';
   
@@ -204,6 +209,15 @@ Simple Man <simple@example.com>
   my $pods = $mb->_find_file_by_type('pod', 'lib');
   is keys %$pods, 1;
   my $expect = $mb->localize_file_path('lib/Simple/Docs.pod');
+
+  # TODO:
+  # True for traditional VMS, but will need to be changed when ODS-5 support
+  # for case preserved filenames is active.
+  # The issue is that the keys to the $pods hash are currently being set to
+  # lowercase on VMS so can not be found in exact case.
+
+  $expect = lc($expect) if $^O eq 'VMS';
+
   is $pods->{$expect}, $expect;
   
   my $pms = $mb->_find_file_by_type('awefawef', 'lib');
@@ -225,7 +239,8 @@ Simple Man <simple@example.com>
 sub strip_volume {
   my $dir = shift;
   (undef, $dir) = File::Spec->splitpath( $dir, 1 );
-  return $dir;
+  my @dirs = File::Spec->splitdir($dir);
+  return @dirs;
 }
 
 sub file_exists {
index 422c602..cf8aa50 100644 (file)
@@ -102,6 +102,11 @@ my %distro = (
 
 %distro = map {$mb->localize_file_path($_), $distro{$_}} keys %distro;
 
+my $lib_path = $mb->localize_dir_path('lib');
+
+# Remove trailing directory delimiter on VMS for compares
+$lib_path =~ s/\]// if $^O eq 'VMS';
+
 $mb->dispatch('build');
 
 eval {$mb->dispatch('docs')};
@@ -123,7 +128,8 @@ $mb->dispatch('install');
 
 while (my ($from, $v) = each %distro) {
   next unless $v;
-  my $to = File::Spec->catfile($destdir, 'man', $man{($from =~ /^lib/ ? 'dir3' : 'dir1')}, $v);
+  my $to = File::Spec->catfile
+     ($destdir, 'man', $man{($from =~ /^\Q$lib_path\E/ ? 'dir3' : 'dir1')}, $v);
   ok -e $to, "Created $to manpage";
 }
 
index 4166092..0d13e85 100644 (file)
@@ -30,6 +30,20 @@ my \$builder = Module::Build->new(
 ---
 $dist->regen;
 
+my $simple_file = 'lib/Simple.pm';
+my $simple2_file = 'lib/Simple2.pm';
+
+   #TODO:
+   # Traditional VMS will return the file in in lower case, and is_deeply
+   # does exact case comparisons.
+   # When ODS-5 support is active for preserved case file names, this will
+   # need to be changed.
+   if ($^O eq 'VMS') {
+       $simple_file = lc($simple_file);
+       $simple2_file = lc($simple2_file);
+   }
+
+
 chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!";
 
 use Module::Build;
@@ -87,7 +101,7 @@ $VERSION = '1.23';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => {file => 'lib/Simple.pm',
+         {'Simple' => {file => $simple_file,
                        version => '1.23'}});
 
 $dist->change_file( 'lib/Simple.pm', <<'---' );
@@ -96,7 +110,7 @@ package Simple;
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => {file => 'lib/Simple.pm'}});
+         {'Simple' => {file => $simple_file}});
 
 # File with no corresponding package (w/ or w/o version)
 # Simple.pm => Foo::Bar v1.23
@@ -108,7 +122,7 @@ $VERSION = '1.23';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Foo::Bar' => { file => 'lib/Simple.pm',
+         {'Foo::Bar' => { file => $simple_file,
                           version => '1.23' }});
 
 $dist->change_file( 'lib/Simple.pm', <<'---' );
@@ -117,7 +131,7 @@ package Foo::Bar;
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Foo::Bar' => { file => 'lib/Simple.pm'}});
+         {'Foo::Bar' => { file => $simple_file}});
 
 
 # Single file with multiple differing packages (w/ or w/o version)
@@ -133,9 +147,9 @@ $VERSION = '1.23';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple'   => { file => 'lib/Simple.pm',
+         {'Simple'   => { file => $simple_file,
                           version => '1.23' },
-          'Foo::Bar' => { file => 'lib/Simple.pm',
+          'Foo::Bar' => { file => $simple_file,
                           version => '1.23' }});
 
 {
@@ -167,9 +181,9 @@ $VERSION = '1.23';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Foo'      => { file => 'lib/Simple.pm',
+         {'Foo'      => { file => $simple_file,
                           version => '1.23' },
-          'Foo::Bar' => { file => 'lib/Simple.pm',
+          'Foo::Bar' => { file => $simple_file,
                           version => '1.23' }});
 
 
@@ -185,7 +199,7 @@ package Simple;
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => { file => 'lib/Simple.pm' }});
+         {'Simple' => { file => $simple_file }});
 
 
 # Single file with same package appearing multiple times, single
@@ -201,7 +215,7 @@ package Simple;
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 
 
@@ -218,7 +232,7 @@ $VERSION = '1.23';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 
 
@@ -237,7 +251,7 @@ my $err = '';
 $err = stderr_of( sub { $mb = new_build() } );
 $err = stderr_of( sub { $provides = $mb->find_dist_packages } );
 is_deeply($provides,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }}); # XXX should be 2.34?
 like( $err, qr/already declared/, '  with conflicting versions reported' );
 
@@ -256,7 +270,7 @@ $dist->regen( clean => 1 );
 $err = stderr_of( sub { $mb = new_build() } );
 $err = stderr_of( sub { $provides = $mb->find_dist_packages } );
 is_deeply($provides,
-         {'Foo' => { file => 'lib/Simple.pm',
+         {'Foo' => { file => $simple_file,
                      version => '1.23' }}); # XXX should be 2.34?
 like( $err, qr/already declared/, '  with conflicting versions reported' );
 
@@ -277,7 +291,7 @@ package Simple;
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => { file => 'lib/Simple.pm' }});
+         {'Simple' => { file => $simple_file }});
 $dist->remove_file( 'lib/Simple2.pm' );
 
 
@@ -295,7 +309,7 @@ package Simple;
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 $dist->remove_file( 'lib/Simple2.pm' );
 
@@ -315,7 +329,7 @@ $VERSION = '1.23';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => { file => 'lib/Simple2.pm',
+         {'Simple' => { file => $simple2_file,
                         version => '1.23' }});
 $dist->remove_file( 'lib/Simple2.pm' );
 
@@ -336,7 +350,7 @@ $dist->regen( clean => 1 );
 $mb = new_build();
 $err = stderr_of( sub { $provides = $mb->find_dist_packages } );
 is_deeply($provides,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 like( $err, qr/Found conflicting versions for package/,
       '  with conflicting versions reported' );
@@ -359,7 +373,7 @@ $dist->regen( clean => 1 );
 $mb = new_build();
 $err = stderr_of( sub { $provides = $mb->find_dist_packages } );
 is_deeply($provides,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 $dist->remove_file( 'lib/Simple2.pm' );
 
@@ -400,7 +414,7 @@ package Foo;
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Foo' => { file => 'lib/Simple.pm',
+         {'Foo' => { file => $simple_file,
                      version => '1.23' }});
 $dist->remove_file( 'lib/Simple2.pm' );
 
@@ -419,7 +433,7 @@ $VERSION = '1.23';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Foo' => { file => 'lib/Simple2.pm',
+         {'Foo' => { file => $simple2_file,
                      version => '1.23' }});
 $dist->remove_file( 'lib/Simple2.pm' );
 
@@ -489,7 +503,7 @@ $err = stderr_of( sub {
 } );
 $err = stderr_of( sub { $provides = $mb->find_dist_packages } );
 is_deeply($provides,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 like( $err, qr/Found conflicting versions for package/,
       '  corresponding package conflicts with multiple alternatives' );
@@ -515,7 +529,7 @@ $err = stderr_of( sub {
 } );
 $err = stderr_of( sub { $provides = $mb->find_dist_packages } );
 is_deeply($provides,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 like( $err, qr/Found conflicting versions for package/,
       '  only one alternative conflicts with corresponding package' );
@@ -539,7 +553,7 @@ $VERSION = '3.45';
 $dist->regen( clean => 1 );
 $mb = new_build();
 is_deeply($mb->find_dist_packages,
-         {'Simple' => { file => 'lib/Simple.pm',
+         {'Simple' => { file => $simple_file,
                         version => '1.23' }});
 
 
index c2cfe86..a1756dd 100644 (file)
@@ -83,7 +83,16 @@ eval {$mb->create_build_script};
 is $@, '';
 ok -e $mb->build_script;
 
-is $mb->dist_dir, 'Simple-0.01';
+my $dist_dir = 'Simple-0.01';
+
+# VMS may or may not need to modify the name, vmsify will do this if
+# the name looks like a UNIX directory.
+if ($^O eq 'VMS') {
+   my @dist_dirs = File::Spec->splitdir(VMS::Filespec::vmsify($dist_dir.'/'));
+   $dist_dir = $dist_dirs[0];
+}
+
+is $mb->dist_dir, $dist_dir;
 
 # The 'cleanup' file doesn't exist yet
 ok grep {$_ eq 'before_script'} $mb->cleanup;
@@ -159,12 +168,15 @@ SKIP: {
   ok $scripts->{script};
   
   # Check that a shebang line is rewritten
-  my $blib_script = File::Spec->catdir( qw( blib script script ) );
+  my $blib_script = File::Spec->catfile( qw( blib script script ) );
   ok -e $blib_script;
   
+  SKIP: {
+    skip("We do not rewrite shebang on VMS", 1) if $^O eq 'VMS';
   my $fh = IO::File->new($blib_script);
   my $first_line = <$fh>;
   isnt $first_line, "#!perl -w\n", "should rewrite the shebang line";
+  }
 }
 
 {