[svn:parrot] r38062 - in branches/install_tools: lib/Parrot t/tools/install tools/dev

jkeenan at svn.parrot.org jkeenan at svn.parrot.org
Sat Apr 11 12:47:20 UTC 2009


Author: jkeenan
Date: Sat Apr 11 12:47:18 2009
New Revision: 38062
URL: https://trac.parrot.org/parrot/changeset/38062

Log:
Applying patch submitted by wayland in
https://trac.parrot.org/parrot/ticket/426.

Modified:
   branches/install_tools/lib/Parrot/Install.pm
   branches/install_tools/t/tools/install/02-install_files.t
   branches/install_tools/t/tools/install/03-lines_to_files.t
   branches/install_tools/tools/dev/install_dev_files.pl
   branches/install_tools/tools/dev/install_files.pl

Modified: branches/install_tools/lib/Parrot/Install.pm
==============================================================================
--- branches/install_tools/lib/Parrot/Install.pm	Sat Apr 11 09:44:38 2009	(r38061)
+++ branches/install_tools/lib/Parrot/Install.pm	Sat Apr 11 12:47:18 2009	(r38062)
@@ -4,6 +4,7 @@
 use warnings;
 use File::Basename qw(dirname);
 use File::Copy;
+use File::Path; # mkpath
 use File::Spec;
 use base qw( Exporter );
 our @EXPORT_OK = qw(
@@ -42,10 +43,10 @@
 
 B<Arguments:> List of five scalars.
 
-    ($files, $installable_exe, $directories) =
+    ($files, $directories) =
         lines_to_files(
             \%metatransforms,
-            \%othertransforms,
+            \@transformorder,
             \@manifests,
             \%options,
             $parrotdir,
@@ -58,18 +59,25 @@
 =cut
 
 sub lines_to_files {
-    my ($metatransforms, $othertransforms, $manifests_ref, 
+    my ($metatransforms, $transformorder, $manifests_ref, 
         $options_ref, $parrotdir) = @_;
     my @files;
-    my @installable_exe;
     my %directories;
+    my($tkey, $thash);
+    my $filehash;
 
     # We'll report multiple occurrences of the same file
     my(%seen);
 
+    # Check $manifests_ref
     ref($manifests_ref) eq 'ARRAY'
         or die "Manifests must be listed in an array reference: $!";
     @{ $manifests_ref } > 0 or die "No manifests specified";
+
+    # Check $transformorder
+    ref($transformorder) eq 'ARRAY'
+        or die "Transform order should be an array of keys\n";
+
     @ARGV = @{ $manifests_ref };
     LINE: while ( my $entry = <> ) {
         chomp $entry;
@@ -100,56 +108,50 @@
         @metadata{ split( /,/, $meta ) } = ();
         $metadata{$entry} = 1 for ( keys %metadata );          # Laziness
 
+        $filehash = {
+            Source => $src,
+            Dest => $dest,
+            DestDirs => [],
+        };
+
         FIXFILE: {
             # Have to catch this case early for some unknown reason
             if ( $entry =~ /^runtime/ ) {
-                $dest =~ s/^runtime\/parrot\///;
-                $dest = File::Spec->catdir(
+                $filehash->{Dest} =~ s/^runtime\/parrot\///;
+                $filehash->{Dest} = File::Spec->catdir(
                     $options_ref->{libdir}, $parrotdir, $dest
                 );
                 last FIXFILE;
             }
-            foreach my $tkey (keys %$metatransforms) {
-                if ( $metadata{$tkey} ) {
-                    my $copy = $dest; # only needed for installable
-                    $dest = File::Spec->catdir(
-                        $options_ref->{$metatransforms->{$tkey}->{optiondir} . 'dir'},
-                        &{ $metatransforms->{$tkey}->{transform} }($dest)
-                    );
-                    if ( $metatransforms->{$tkey}->{isbin}
-                            and
-                        $copy =~ /^installable/
-                    ) {
-                        push @installable_exe, [ $src, $dest ];
-                        next LINE;
-                    }
-                    last FIXFILE;
-                }
-            }
-
-            foreach my $tkey (keys %$othertransforms) {
-                if ( $entry =~ /$tkey/ ) {
-                    $dest = File::Spec->catdir(
-                        $options_ref->{$othertransforms->{$tkey}->{optiondir} . 'dir'},
-                        &{ $othertransforms->{$tkey}->{transform} }($dest)
-                    );
-                    last FIXFILE;
-                }
+            foreach my $tkey (@$transformorder) {
+                $thash = $metatransforms->{$tkey};
+                unless($thash->{ismeta} ? $metadata{$tkey} : $entry =~ /$tkey/) { next; }
+                $filehash = &{ $thash->{transform} }($filehash);
+                ref($filehash) eq 'HASH' or die "Error: transform didn't return a hash for key '$tkey'\n";
+                $filehash->{Dest} = File::Spec->catdir(
+                    $options_ref->{$thash->{optiondir} . 'dir'},
+                    @{ $filehash->{DestDirs} }, 
+                    $filehash->{Dest}
+                );
+                last FIXFILE;
             }
-            die "Unknown install location in MANIFEST for file '$entry': ";
+            die "Unknown install location in MANIFEST for file '$entry'\n";
         }
 
-        $dest = File::Spec->catdir( $options_ref->{buildprefix}, $dest )
-            if $options_ref->{buildprefix};
+        if(! $filehash->{Installable}) {
+            $filehash->{Dest} = File::Spec->catdir( $options_ref->{buildprefix}, $filehash->{Dest} )
+                if $options_ref->{buildprefix};
+        }
 
-        $directories{ dirname($dest) } = 1;
-        push( @files, [ $src => $dest ] );
+        $directories{ dirname($filehash->{Dest}) } = 1;
+        push( @files, $filehash );
     }
     continue {
         close ARGV if eof;    # Reset line numbering for each input file
     }
 
-    return(\@files, \@installable_exe, \%directories);
+    (grep { ! ref } @files) and die "lines_to_files from Parrot::Install created a bad hash!\n";
+    return(\@files, \%directories);
 }
 
 =head2 C<create_directories()>
@@ -172,21 +174,9 @@
 sub create_directories {
     my($destdir, $directories) = @_;
 
-    for my $dir ( map { $destdir . $_ } keys %$directories ) {
-        unless ( -d $dir ) {
-            my @dirs_needed;
-
-            # Make full path to the directory $dir
-            while ( ! -d $dir ) {    # Scan up to nearest existing ancestor
-                unshift @dirs_needed, $dir;
-                $dir = dirname($dir);
-            }
-            foreach my $d ( @dirs_needed ) {
-                mkdir( $d, 0777 ) or die "mkdir $d: $!";
-            }
-        }
-    }
-    return 1;
+    mkpath([
+        grep { ! -d } map { $destdir . $_ } keys %$directories
+    ],0,0777);
 }
 
 =head2 C<install_files()>
@@ -196,11 +186,11 @@
     install_files(
         $destination_directory,
         $dry_run_option,
-        @list_of_files_and_executables,
+        $list_of_files_and_executables,
     );
 
-B<Arguments:>  Takes two scalar arguments, followed by a list consisting of
-2-element, C<source => destination> array references.
+B<Arguments:>  Takes two scalar arguments, followed by a reference to a 
+list consisting of hashes.  
 
 B<Return Value:>  True value.
 
@@ -209,14 +199,20 @@
 =cut
 
 sub install_files {
-    my($destdir, $dryrun, @files) = @_;
+    my($destdir, $dryrun, $files) = @_;
     my($src, $dest, $mode);
 
+    ref($files) eq 'ARRAY' or die "Error: parameter \$files must be an array\n";
     print("Installing ...\n");
-    foreach my $el ( @files ) {
-        next unless ref($el) eq 'ARRAY';
-        ( $src, $dest ) = @{ $el };
+    foreach my $el ( @$files ) {
+        unless(ref($el) eq 'HASH') {
+            my($ref) = ref($el);
+            warn "Bad reference passed in \$files (want a HASH, got a '$ref')\n";
+            next;
+        }
+        ( $src, $dest ) = map { $el->{$_} } qw(Source Dest);
         $dest = $destdir . $dest;
+        print "Installing $src to $dest\n";
         if ( $dryrun ) {
             print "$src -> $dest\n";
             next;
@@ -224,7 +220,7 @@
         else {
             next unless -e $src;
             next if $^O eq 'cygwin' and -e "$src.exe"; # stat works, copy not
-            copy( $src, $dest ) or die "copy $src to $dest: $!";
+            copy( $src, $dest ) or die "Error: couldn't copy $src to $dest: $!\n";
             print "$dest\n";
         }
         $mode = ( stat($src) )[2];

Modified: branches/install_tools/t/tools/install/02-install_files.t
==============================================================================
--- branches/install_tools/t/tools/install/02-install_files.t	Sat Apr 11 09:44:38 2009	(r38061)
+++ branches/install_tools/t/tools/install/02-install_files.t	Sat Apr 11 12:47:18 2009	(r38062)
@@ -6,7 +6,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 17;
+use Test::More tests => 18;
 use Carp;
 use Cwd;
 use File::Copy;
@@ -29,39 +29,89 @@
     my @dirs = qw(foo/bar foo/bar/baz);
     create_directories($tdir, { map { $_ => 1 } @dirs });
 
-    my @files = ( [ "$testsourcedir/README", "$dirs[0]/README"] );
+    {
+        my ( $stdout, $stderr, $rv );
+    
+        eval {
+            capture(
+                sub { $rv = install_files($tdir, 1); },
+                \$stdout,
+                \$stderr,
+            );
+        };
+        like($@, qr/Error: parameter \$files must be an array/s, "Catches non-ARRAY \$files");
+    }
+}
+
+{
+    my $tdir = tempdir( CLEANUP => 1 );
+    $tdir .= '/';
+
+    my @dirs = qw(foo/bar foo/bar/baz);
+    create_directories($tdir, { map { $_ => 1 } @dirs });
+
+    # Case where element in @files is not a hash ref
+    my $files_ref = [ q[] ];
 
     {
         my ( $stdout, $stderr, $rv );
         capture(
-            sub { $rv = install_files($tdir, 1, @files); },
+            sub { $rv = install_files($tdir, 0, $files_ref); },
+            \$stdout,
+            \$stderr,
+        );
+        like($stderr, qr/Bad reference passed in \$files/, "Catches non-HASH files");
+    
+        like( $stdout, qr/Installing \.\.\./, 
+            'Got expected installation message' );
+    }
+}
+
+{
+    my $tdir = tempdir( CLEANUP => 1 );
+    $tdir .= '/';
+
+    my @dirs = qw(foo/bar foo/bar/baz);
+    create_directories($tdir, { map { $_ => 1 } @dirs });
+
+    my $files_ref = [ {
+        Source => "$testsourcedir/README",
+        Dest => "$dirs[0]/README",
+    } ];
+
+    {
+        my ( $stdout, $stderr, $rv );
+
+        capture(
+            sub { $rv = install_files($tdir, 1, $files_ref); },
             \$stdout,
             \$stderr,
         );
         ok( $rv, 'install_files() completed successfully in dry-run case' );
     
         my $files_created = 0;
-        foreach my $el (@files) {
-            $files_created++ if -f "$tdir$el->[1]";
+        foreach my $el (@$files_ref) {
+            $files_created++ if -f $tdir . $el->{Dest};
         }
         is( $files_created, 0, 'Dry run, so no files created' );
 
         like( $stdout, qr/Installing.*README.*README/s,
             'Got expected installation message' );
+        $stdout =~ qr/Installing.*README.*README/s or print "Warning was: $stderr";
     }
 
     {
         my ( $stdout, $stderr, $rv );
         capture(
-            sub { $rv = install_files($tdir, 0, @files); },
+            sub { $rv = install_files($tdir, 0, $files_ref); },
             \$stdout,
             \$stderr,
         );
         ok( $rv, 'install_files() completed successfully in production case' );
     
         my $files_created = 0;
-        foreach my $el (@files) {
-            $files_created++ if -f "$tdir$el->[1]";
+        foreach my $el (@$files_ref) {
+            $files_created++ if -f "$tdir$el->{Dest}";
         }
         is( $files_created, 1, 'Production, so 1 file created' );
 
@@ -84,23 +134,29 @@
         copy "$testsourcedir/$f", "$tdir/$f"
             or die "Unable to copy $f prior to testing: $!";
     }
-    my @files = (
-        [ "$tdir/README", "$dirs[0]/README" ],
-        [ "$tdir/phony", "$dirs[0]/phony" ],
-    );
+    my $files_ref = [
+        {
+            Source => "$tdir/README",
+            Dest => "$dirs[0]/README",
+        },
+        {
+            Source => "$tdir/phony",
+            Dest => "$dirs[0]/phony",
+        },
+    ];
 
     {
         my ( $stdout, $stderr, $rv );
         capture(
-            sub { $rv = install_files($tdir, 0, @files); },
+            sub { $rv = install_files($tdir, 0, $files_ref); },
             \$stdout,
             \$stderr,
         );
         ok( $rv, 'install_files() completed successfully in mock-Cygwin case' );
     
         my $files_created = 0;
-        foreach my $el (@files) {
-            $files_created++ if -f "$tdir$el->[1]";
+        foreach my $el (@$files_ref) {
+            $files_created++ if -f "$tdir$el->{Dest}";
         }
         is( $files_created, 2, 'Production, so 2 files created' );
 
@@ -124,24 +180,33 @@
         copy "$testsourcedir/$f", "$tdir/$f"
             or die "Unable to copy $f prior to testing: $!";
     }
-    my @files = (
-        [ "$tdir/README", "$dirs[0]/README" ],
-        [ "$tdir/phony", "$dirs[0]/phony" ],
-        [ "$tdir/phony.exe", "$dirs[0]/phony.exe" ],
-    );
+    my $files_ref = [
+        {
+            Source => "$tdir/README",
+            Dest => "$dirs[0]/README"
+        },
+        {
+            Source => "$tdir/phony",
+            Dest => "$dirs[0]/phony"
+        },
+        {
+            Source => "$tdir/phony.exe",
+            Dest => "$dirs[0]/phony.exe"
+        },
+    ];
 
     {
         my ( $stdout, $stderr, $rv );
         capture(
-            sub { $rv = install_files($tdir, 0, @files); },
+            sub { $rv = install_files($tdir, 0, $files_ref); },
             \$stdout,
             \$stderr,
         );
         ok( $rv, 'install_files() completed successfully in mock-Cygwin case' );
     
         my $files_created = 0;
-        foreach my $el (@files) {
-            $files_created++ if -f "$tdir$el->[1]";
+        foreach my $el (@$files_ref) {
+            $files_created++ if -f "$tdir$el->{Dest}";
         }
         is( $files_created, 2,
             'Production, so 2 files created; 1 file passed over' );
@@ -159,38 +224,19 @@
     my @dirs = qw(foo/bar foo/bar/baz);
     create_directories($tdir, { map { $_ => 1 } @dirs });
 
-    # Case where element in @files is not an array ref
-    my @files = ( q{} );
-
-    {
-        my ( $stdout, $stderr, $rv );
-        capture(
-            sub { $rv = install_files($tdir, 0, @files); },
-            \$stdout,
-            \$stderr,
-        );
-        ok( $rv, 'install_files() handled invalid argument as expected' );
-    
-        like( $stdout, qr/Installing \.\.\./, 
-            'Got expected installation message' );
-    }
-}
-
-{
-    my $tdir = tempdir( CLEANUP => 1 );
-    $tdir .= '/';
-
-    my @dirs = qw(foo/bar foo/bar/baz);
-    create_directories($tdir, { map { $_ => 1 } @dirs });
-
     # Case where element in @files does not hold existent file
     my $nonexistent = q{ajdpfadksjfjvjkvds} . $$;
-    my @files = ( [ $nonexistent, "$dirs[0]/$nonexistent"] );
+    my $files_ref = [
+        {
+            Source => $nonexistent,
+            Dest => "$dirs[0]/$nonexistent",
+        }
+    ];
 
     {
         my ( $stdout, $stderr, $rv );
         capture(
-            sub { $rv = install_files($tdir, 0, @files); },
+            sub { $rv = install_files($tdir, 0, $files_ref); },
             \$stdout,
             \$stderr,
         );

Modified: branches/install_tools/t/tools/install/03-lines_to_files.t
==============================================================================
--- branches/install_tools/t/tools/install/03-lines_to_files.t	Sat Apr 11 09:44:38 2009	(r38061)
+++ branches/install_tools/t/tools/install/03-lines_to_files.t	Sat Apr 11 12:47:18 2009	(r38062)
@@ -6,7 +6,7 @@
 use strict;
 use warnings;
 
-use Test::More tests =>  6;
+use Test::More tests =>  8;
 use Carp;
 use Cwd;
 use File::Copy;
@@ -24,19 +24,39 @@
 my $testsourcedir = qq{$cwd/t/tools/install/testlib};
 
 my $parrotdir = q{};;
+
+# Double-check these to see if they make sense now
 my %metatransforms = (
     doc => {
         optiondir => 'doc',
         transform => sub {
             my($dest) = @_;
-            $dest =~ s/^docs\/resources/resources/; # resources go in the top level of docs
-            $dest =~ s/^docs/pod/; # other docs are actually raw Pod
+            # resources go in the top level of docs
+            $dest =~ s/^docs\/resources/resources/;
+            # other docs are actually raw Pod
+            $dest =~ s/^docs/pod/;
             $parrotdir, $dest;
         },
     },
+    '.*' => {
+        optiondir => 'foo',
+        transform => sub {
+            return($_[0]);
+        }
+    }
 );
+my(@transformorder) = ('doc', '.*');
 
-my %othertransforms = (
+my %badmetatransforms = (
+    doc => {
+        optiondir => 'doc',
+        transform => sub {
+            my($dest) = @_;
+            $dest =~ s/^docs\/resources/resources/; # resources go in the top level of docs
+            $dest =~ s/^docs/pod/; # other docs are actually raw Pod
+            $parrotdir, $dest;
+        },
+    },
     '.*' => {
         optiondir => 'foo',
         transform => sub {
@@ -50,13 +70,13 @@
     packages => 'main',
 );
 
-my ($files_ref, $installable_exe_ref, $directories_ref);
+my ($files_ref, $directories_ref, %badtransformorder);
 
 eval {
-    ($files_ref, $installable_exe_ref, $directories_ref) =
+    ($files_ref, $directories_ref) =
         lines_to_files(
             \%metatransforms,
-            \%othertransforms,
+            \@transformorder,
             {},
             \%options,
             $parrotdir,
@@ -67,10 +87,10 @@
 );
 
 eval {
-    ($files_ref, $installable_exe_ref, $directories_ref) =
+    ($files_ref, $directories_ref) =
         lines_to_files(
             \%metatransforms,
-            \%othertransforms,
+            \@transformorder,
             [],
             \%options,
             $parrotdir,
@@ -80,6 +100,20 @@
     "Correctly detected lack of manifest files"
 );
 
+eval {
+    ($files_ref, $directories_ref) =
+        lines_to_files(
+            \%metatransforms,
+            \%badtransformorder,
+            [ qw( MANIFEST MANIFEST.generated ) ],
+            \%options,
+            $parrotdir,
+        );
+};
+like($@, qr/Transform order should be an array of keys/,
+    "Correctly detected incorrect type for transform order"
+);
+
 {
     my $tdir = tempdir( CLEANUP => 1 );
     chdir $tdir or die "Unable to change to testing directory: $!";
@@ -89,23 +123,40 @@
         or die "Unable to copy file to tempdir for testing:  $!";
 
     my ($stdout, $stderr);
-    capture(
-        sub {
-            ($files_ref, $installable_exe_ref, $directories_ref) =
-                lines_to_files(
-                    \%metatransforms,
-                    \%othertransforms,
-                    [ qw( MANIFEST MANIFEST.generated ) ],
-                    \%options,
-                    $parrotdir,
-                );
-        },
-        \$stdout,
-        \$stderr,
+    eval {
+        ($files_ref, $directories_ref) =
+            lines_to_files(
+                \%badmetatransforms,
+                \@transformorder,
+                [ qw( MANIFEST MANIFEST.generated ) ],
+                \%options,
+                $parrotdir,
+            );
+    };
+    like($@, qr/transform didn't return a hash for key/,
+        "Correctly detected transform with a bad return value"
     );
+    eval {
+        capture(
+            sub {
+                ($files_ref, $directories_ref) =
+                    lines_to_files(
+                        \%metatransforms,
+                        \@transformorder,
+                        [ qw( MANIFEST MANIFEST.generated ) ],
+                        \%options,
+                        $parrotdir,
+                    );
+            },
+            \$stdout,
+            \$stderr,
+        );
+    };
+# Is there a way we can skip these two tests as failed and continue?
+    $@ and die "Error encountered while testing for duplicates: $@ ##";
     like($stderr, qr/MANIFEST\.generated:\d+:\s+Duplicate entry/,
         "Detected duplicate entries in one or more manifest files" );
-    is( scalar @{ $installable_exe_ref }, 0,
+    is( scalar(grep { $_->{Installable} } @$files_ref), 0,
         "No installable executables in this test" );
 
     chdir $cwd or die "Unable to return to starting directory: $!";
@@ -119,10 +170,10 @@
         or die "Unable to copy file to tempdir for testing:  $!";
 
     eval {
-        ($files_ref, $installable_exe_ref, $directories_ref) =
+        ($files_ref, $directories_ref) =
             lines_to_files(
                 \%metatransforms,
-                \%othertransforms,
+                \@transformorder,
                 [ $defective_man ],
                 \%options,
                 $parrotdir,
@@ -178,9 +229,13 @@
 
 
 
+## In the code below:
+## - othertransforms needs to be merged into metatransforms
+## - transformorder needs to be added
+## - $installable_exe needs to be removed
 
 #{
-#    my($metatransforms, $othertransforms, $manifests, $options, $parrotdir,
+#    my($metatransforms, $transformorder, $manifests, $options, $parrotdir,
 #        $files, $installable_exe, $directories);
 #
 #    # First lines_to_files test
@@ -190,7 +245,7 @@
 #
 #    # Second lines_to_files test
 ##    eval { lines_to_files(
-##        $metatransforms, $othertransforms, 
+##        $metatransforms, $transformorder, 
 ##        [qw(MANIFEST MANIFEST.generated)], 
 ##        $options, $parrotdir
 ##    ); };

Modified: branches/install_tools/tools/dev/install_dev_files.pl
==============================================================================
--- branches/install_tools/tools/dev/install_dev_files.pl	Sat Apr 11 09:44:38 2009	(r38061)
+++ branches/install_tools/tools/dev/install_dev_files.pl	Sat Apr 11 12:47:18 2009	(r38062)
@@ -1,4 +1,4 @@
-#! perl -Ilib
+#! perl
 ################################################################################
 # Copyright (C) 2001-2009, Parrot Foundation.
 # $Id$
@@ -96,74 +96,87 @@
 my $parrotdir = $options{versiondir};
 
 # Set up transforms on filenames
+my(@transformorder) = (qw(lib share include src doc), '^(tools|VERSION)', '^compilers');
 my(%metatransforms) = (
     lib => {
+        ismeta => 1,
         optiondir => 'lib',
         transform => sub {
-            my($dest) = @_;
-            $parrotdir, "tools", $dest;
+            my($filehash) = @_;
+            $filehash->{DestDirs} = [$parrotdir, "tools"];
+            return($filehash);
         },
     },
     share => {
+        ismeta => 1,
         optiondir => 'data',
         transform => sub {
-            my($dest) = @_;
-            $parrotdir, basename($dest);
+            my($filehash) = @_;
+            $filehash->{Dest} = basename($filehash->{Dest});
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
     include => {
+        ismeta => 1,
         optiondir => 'include',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^src//; # strip off leading src/ dir
-            $dest =~ s/^include//;
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{Dest} =~ s/^src//; # strip off leading src/ dir
+            $filehash->{Dest} =~ s/^include//;
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
     src => {
+        ismeta => 1,
         optiondir => 'src',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^src//; # strip off leading src/ dir
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{Dest} =~ s/^src//; # strip off leading src/ dir
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
     doc => {
+        ismeta => 1,
         optiondir => 'doc',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^docs/pod/; # other docs are actually raw Pod
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{Dest} =~ s/^docs/pod/; # other docs are actually raw Pod
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
-);
-
-my(%othertransforms) = (
     '^(tools|VERSION)' => {
         optiondir => 'lib',
         transform => sub {
-            my($dest) = @_;
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
     '^compilers' => {
         optiondir => 'lib',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^compilers/languages/;
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{Dest} =~ s/^compilers/languages/;
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
 );
 
-my($files, $installable_exe, $directories) = Parrot::Install::lines_to_files(
-    \%metatransforms, \%othertransforms, \@manifests, \%options, $parrotdir
+my($filehashes, $directories) = lines_to_files(
+    \%metatransforms, \@transformorder, \@manifests, \%options, $parrotdir
 );
 
 unless ( $options{'dry-run'} ) {
-    Parrot::Install::create_directories($options{destdir}, $directories);
+    create_directories($options{destdir}, $directories);
 }
-Parrot::Install::install_files($options{destdir}, $options{'dry-run'}, @$files, @$installable_exe);
+install_files($options{destdir}, $options{'dry-run'}, $filehashes);
+
+print "Finished install_dev_files.pl\n";
 
 # Local Variables:
 #   mode: cperl

Modified: branches/install_tools/tools/dev/install_files.pl
==============================================================================
--- branches/install_tools/tools/dev/install_files.pl	Sat Apr 11 09:44:38 2009	(r38061)
+++ branches/install_tools/tools/dev/install_files.pl	Sat Apr 11 12:47:18 2009	(r38062)
@@ -1,6 +1,6 @@
-# perl
+#! perl
 ################################################################################
-# Copyright (C) 2001-2008, Parrot Foundation.
+# Copyright (C) 2001-2009, Parrot Foundation.
 # $Id$
 ################################################################################
 
@@ -148,73 +148,85 @@
 
 my $parrotdir = $options{versiondir};
 
-my %metatransforms = (
+# Set up transforms on filenames
+my(@transformorder) = qw(lib bin include doc pkgconfig ^compilers);
+my(%metatransforms) = (
     lib => {
+        ismeta => 1,
         optiondir => 'lib',
         transform => sub {
-            my($dest) = @_;
-            if ( $dest =~ /^install_/ ) {
-                $dest =~ s/^install_//;     # parrot with different config
-                $parrotdir, 'include', $dest;
+            my($filehash) = @_;
+            local($_) = $filehash->{Dest};
+            if ( /^install_/ ) {
+                s/^install_//;     # parrot with different config
+                $filehash->{DestDirs} = [$parrotdir, 'include'];
+                $filehash->{Dest} = $_;
             }
             else {
                 # don't allow libraries to be installed into subdirs of libdir
-                basename($dest);
+                $filehash->{Dest} = basename($_);
             }
+            return($filehash);
         },
     },
     bin => {
+        ismeta => 1,
         optiondir => 'bin',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^installable_//;     # parrot with different config
-            $dest;
+            my($filehash) = @_;
+            # parrot with different config
+            $filehash->{Installable} = $filehash->{Dest} =~ s/^installable_//;     
+            return($filehash);
         },
         isbin => 1,
     },
     include => {
+        ismeta => 1,
         optiondir => 'include',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^include//;
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{Dest} =~ s/^include//;
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
     doc => {
+        ismeta => 1,
         optiondir => 'doc',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^docs\/resources/resources/; # resources go in the top level of docs
-            $dest =~ s/^docs/pod/; # other docs are actually raw Pod
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{Dest} =~ s#^docs/resources#resources#; # resources go in the top level of docs
+            $filehash->{Dest} =~ s/^docs/pod/; # other docs are actually raw Pod
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
     pkgconfig => {
+        ismeta => 1,
         optiondir => 'lib',
         transform => sub {
-            my($dest) = @_;
+            my($filehash) = @_;
             # For the time being this is hardcoded as being installed under
             # libdir as it is typically done with automake installed packages.
             # If there is a use case to make this configurable we'll add a
             # seperate --pkgconfigdir option.
-            'pkgconfig', $parrotdir, $dest;
+            $filehash->{DestDirs} = ['pkgconfig', $parrotdir];
+            return($filehash);
         },
     },
-);
-
-my %othertransforms = (
     '^compilers' => {
         optiondir => 'lib',
         transform => sub {
-            my($dest) = @_;
-            $dest =~ s/^compilers/languages/;
-            $parrotdir, $dest;
+            my($filehash) = @_;
+            $filehash->{Dest} =~ s/^compilers/languages/;
+            $filehash->{DestDirs} = [$parrotdir];
+            return($filehash);
         },
     },
 );
 
-my($files, $installable_exe, $directories) = lines_to_files(
-    \%metatransforms, \%othertransforms, \@manifests, \%options, $parrotdir
+my($filehashes, $directories) = lines_to_files(
+    \%metatransforms, \@transformorder, \@manifests, \%options, $parrotdir
 );
 
 unless ( $options{'dry-run'} ) {
@@ -222,36 +234,34 @@
 }
 
 # TT #347
-# 1. skip build_dir-only binaries for @installable_exe
-for (@$installable_exe) {
-    my ( $i, $dest ) = @$_;
-    my ($file) = $i =~ /installable_(.+)$/;
+# 1. skip build_dir-only binaries for files marked Installable
+my($filehash, @removes, $removes);
+foreach $filehash (grep { $_->{Installable} } @$filehashes) {
+    my( $src, $dest ) = map { $filehash->{$_} } qw(Source Dest);
+    my ($file) = $src =~ /installable_(.+)$/;
     next unless $file;
-    my @f = map { $_ ? $_->[0] : '' } @$files;
-    if (grep(/^$file$/, @f)) {
-        if (-e $file) {
-            print "skipping $file, using installable_$file instead\n";
-            @$files = map {$_ and $_->[0] !~ /^$file$/ ? $_ : undef} @$files;
-        }
+    if((grep { $_->{Source} =~ /^$file$/ } @$filehashes) and -e $file) {
+        print "skipping $file, using installable_$file instead\n";
+        push @removes, $file;
     }
 }
+$removes = join '|', @removes;
+@$filehashes = grep { $_->{Source} !~ /^($removes)$/ } @$filehashes;
+
 # 2. for every .exe check if there's an installable. Fail if not
-foreach my $f (@$files ) {
-    next unless $_;
-    my ( $f, $dest ) = @$_;
-    my $i;
+my $i;
+foreach $filehash (grep { ! $_->{Installable} } @$filehashes ) {
+    my( $src, $dest ) = map { $filehash->{$_} } qw(Source Dest);
+    next unless $src =~ /\.exe$/;
     # This logic will fail on non-win32 if the generated files are really
     # generated as with rt #40817. We don't have [main]bin here.
-    $i = "installable_$f" if $f =~ /\.exe$/;
-    next unless $i;
-    unless (map {$_->[0] =~ /^$i$/} @$installable_exe) {
+    $i = "installable_$src";
+    unless (map {$_->{Source} =~ /^$i$/} grep { $_->{Installable} } @$filehashes) {
         die "$i is missing in MANIFEST or MANIFEST.generated\n";
     }
 }
 
-install_files(
-    $options{destdir}, $options{'dry-run'}, @$files, @$installable_exe
-);
+install_files($options{destdir}, $options{'dry-run'}, $filehashes);
 
 print "Finished install_files.pl\n";
 


More information about the parrot-commits mailing list