From: John E. Malmberg Date: Fri, 28 Sep 2007 08:55:27 +0000 (-0500) Subject: [patch@31988] Revised Module::Build fixes for VMS. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d1bd4ef0a107c19b597b3c5d49a9b6836c36909f;p=p5sagit%2Fp5-mst-13.2.git [patch@31988] Revised Module::Build fixes for VMS. From: "John E. Malmberg" Message-id: <46FD07CF.5040504@qsl.net> p4raw-id: //depot/perl@31995 --- diff --git a/lib/Module/Build/Base.pm b/lib/Module/Build/Base.pm index b2cdb30..3462505 100644 --- a/lib/Module/Build/Base.pm +++ b/lib/Module/Build/Base.pm @@ -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; + } } } diff --git a/lib/Module/Build/Platform/VMS.pm b/lib/Module/Build/Platform/VMS.pm index 7485127..31408ed 100644 --- a/lib/Module/Build/Platform/VMS.pm +++ b/lib/Module/Build/Platform/VMS.pm @@ -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; } diff --git a/lib/Module/Build/t/install.t b/lib/Module/Build/t/install.t index 281454d..bfb8f47 100644 --- a/lib/Module/Build/t/install.t +++ b/lib/Module/Build/t/install.t @@ -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 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 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 { diff --git a/lib/Module/Build/t/manifypods.t b/lib/Module/Build/t/manifypods.t index 422c602..cf8aa50 100644 --- a/lib/Module/Build/t/manifypods.t +++ b/lib/Module/Build/t/manifypods.t @@ -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"; } diff --git a/lib/Module/Build/t/metadata.t b/lib/Module/Build/t/metadata.t index 4166092..0d13e85 100644 --- a/lib/Module/Build/t/metadata.t +++ b/lib/Module/Build/t/metadata.t @@ -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' }}); diff --git a/lib/Module/Build/t/runthrough.t b/lib/Module/Build/t/runthrough.t index c2cfe86..a1756dd 100644 --- a/lib/Module/Build/t/runthrough.t +++ b/lib/Module/Build/t/runthrough.t @@ -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"; + } } {