File Coverage

File:lib/Parrot/Install.pm
Coverage:87.3%

linestmtbrancondsubcode
1package Parrot::Install;
2# Copyright (C) 2001-2009, Parrot Foundation.
3
3
3
3
3
use strict;
4
3
3
3
3
use warnings;
5
3
3
3
3
use File::Basename qw(dirname);
6
3
3
3
3
use File::Copy;
7
3
3
3
3
use File::Path qw( mkpath );
8
3
3
3
3
use File::Spec;
9
3
3
3
3
use base qw( Exporter );
10our @EXPORT_OK = qw(
11    lines_to_files
12    create_directories
13    install_files
14);
15
16#################### DOCUMENTATION ####################
17
18 - 59
=head1 NAME

Parrot::Install - Functionality for installation programs

=head1 SYNOPSIS

    use Parrot::Install qw(
        install_files
        create_directories
        lines_to_files
    );

=head1 DESCRIPTION

This module exports on demand only three subroutines used in the Parrot
installation programs F<tools/dev/install_files.pl> and
F<tools/dev/install_dev_files.pl>.  The subroutines are tested by tests found
in F<t/tools/install/>.

=head1 SUBROUTINES

=head2 C<lines_to_files()>

B<Purpose:> Suck in the lines from the mentioned manifests, and turn them into
file locations.

B<Arguments:> List of five scalars.

    ($files, $directories) =
        lines_to_files(
            \%metatransforms,
            \@transformorder,
            \@manifests,
            \%options,
            $parrotdir,
        );

B<Return Value:> List of three scalars.

B<Comment:>

=cut
60
61sub lines_to_files {
62
6
6
    my ($metatransforms, $transformorder, $manifests_ref,
63        $options_ref, $parrotdir) = @_;
64
6
    my @files;
65
6
    my %directories;
66
6
    my($tkey, $thash);
67
6
    my $filehash;
68
69    # We'll report multiple occurrences of the same file
70
6
    my(%seen);
71
72    # Check $manifests_ref
73
6
100
    ref($manifests_ref) eq 'ARRAY'
74        or die "Manifests must be listed in an array reference: $!";
75
5
5
100
    @{ $manifests_ref } > 0 or die "No manifests specified";
76
77    # Check $transformorder
78
4
100
    ref($transformorder) eq 'ARRAY'
79        or die "Transform order should be an array of keys\n";
80
81
3
3
    @ARGV = @{ $manifests_ref };
82
3
    LINE: while ( my $entry = <> ) {
83
45
        chomp $entry;
84
85
45
        $entry =~ s/\#.*//; # Ignore comments
86
45
100
        next if $entry =~ /^\s*$/; # Skip blank lines
87
88
17
        my ( $src, $meta, $dest ) = split( /\s+/, $entry );
89
17
100
        $dest = $src unless $dest;
90
91
17
100
        if ( $seen{$src}++ ) {
92
2
            print STDERR "$ARGV:$.: Duplicate entry $src\n";
93        }
94
95        # Parse out metadata
96
17
100
        die "Malformed line in MANIFEST: $entry" if not defined $meta;
97
16
        my $generated = $meta =~ s/^\*//;
98
16
        my ($package) = $meta =~ /^\[(.*?)\]/;
99
16
        $meta =~ s/^\[(.*?)\]//;
100
16
100
        next unless $package; # Skip if this file belongs to no package
101
102
15
50
        my $plist = defined ( $options_ref->{packages})
103            ? $options_ref->{packages}
104            : '.*';
105
15
100
        next unless $package =~ /$plist/;
106
107
11
        my %metadata;
108
11
        @metadata{ split( /,/, $meta ) } = ();
109
11
11
        $metadata{$_} = 1 for ( keys %metadata ); # Laziness
110
111
11
        $filehash = {
112            Source => $src,
113            Dest => $dest,
114            DestDirs => [],
115        };
116
117        FIXFILE: {
118            # Have to catch this case early for some unknown reason
119
11
11
50
            if ( $entry =~ /^runtime/ ) {
120
0
                $filehash->{Dest} =~ s/^runtime\/parrot\///;
121
0
                $filehash->{Dest} = File::Spec->catdir(
122                    $options_ref->{libdir}, $parrotdir, $filehash->{Dest}
123                );
124
0
                last FIXFILE;
125            }
126
11
            foreach my $tkey (@$transformorder) {
127
16
                $thash = $metatransforms->{$tkey};
128
16
5
50
100
                unless($thash->{ismeta} ? $metadata{$tkey} : $entry =~ /$tkey/) { next; }
129
11
11
                $filehash = &{ $thash->{transform} }($filehash);
130
11
100
                ref($filehash) eq 'HASH' or die "Error: transform didn't return a hash for key '$tkey'\n";
131
10
                $filehash->{Dest} = File::Spec->catdir(
132                    $options_ref->{$thash->{optiondir} . 'dir'},
133
10
                    @{ $filehash->{DestDirs} },
134                    $filehash->{Dest}
135                );
136
10
                last FIXFILE;
137            }
138
0
            die "Unknown install location in MANIFEST for file '$entry'\n";
139        }
140
141
10
50
        if(! $filehash->{Installable}) {
142
10
50
            $filehash->{Dest} = File::Spec->catdir( $options_ref->{buildprefix}, $filehash->{Dest} )
143                if $options_ref->{buildprefix};
144        }
145
146
10
        $directories{ dirname($filehash->{Dest}) } = 1;
147
10
        push( @files, $filehash );
148    }
149    continue {
150
43
100
        close ARGV if eof; # Reset line numbering for each input file
151    }
152
153
1
7
50
    (grep { ! ref } @files) and die "lines_to_files from Parrot::Install created a bad hash!\n";
154
1
    return(\@files, \%directories);
155}
156
157 - 172
=head2 C<create_directories()>

B<Purpose:> Creates the directories passed in.

B<Arguments:>  Two scalar arguments.

    create_directories(
        $destination_directory,
        $directories_hash_ref,
    );

B<Return Value:>  True value.

B<Comment:>

=cut
173
174sub create_directories {
175
9
9
    my ( $destdir, $directories ) = @_;
176
177
9
18
18
9
    my @dirs_to_create = grep { ! -d } map { $destdir . $_ } sort keys %{$directories};
178
179
9
    my $print_the_dirs = 0;
180
9
    my $mode = oct('0777');
181
182    # We must use the legacy interface to support File::Path versions before 2.01.
183
9
    my @dirs_created = mkpath( \@dirs_to_create, $print_the_dirs, $mode );
184
185
9
    return 1;
186}
187
188 - 205
=head2 C<install_files()>

B<Purpose:> Install the mentioned files into the appropriate locations.

    install_files(
        $destination_directory,
        $dry_run_option,
        $list_of_files_and_executables,
    );

B<Arguments:>  Takes two scalar arguments, followed by a reference to a
list consisting of hashes.

B<Return Value:>  True value.

B<Comment:>

=cut
206
207sub install_files {
208
7
7
    my($destdir, $dryrun, $files) = @_;
209
7
    my($src, $dest, $mode);
210
211
7
100
    ref($files) eq 'ARRAY' or die "Error: parameter \$files must be an array\n";
212
6
    print("Installing ...\n");
213
6
    foreach my $el ( @$files ) {
214
9
100
        unless(ref($el) eq 'HASH') {
215
1
            my($ref) = ref($el);
216
1
            warn "Bad reference passed in \$files (want a HASH, got a '$ref')\n";
217
1
            next;
218        }
219
8
16
        ( $src, $dest ) = map { $el->{$_} } qw(Source Dest);
220
8
        $dest = $destdir . $dest;
221
8
100
        if ( $dryrun ) {
222
1
            print "$src -> $dest\n";
223
1
            next;
224        }
225        else {
226
7
100
            next unless -e $src;
227
6
100
100
            next if $^O eq 'cygwin' and -e "$src.exe"; # stat works, copy not
228
5
            eval {
229
5
50
                if (-l $src) { # a link should be created
230                    # check if the system supports symbolic linking
231
3
3
3
3
                    use Config;
232
0
0
0
                    if ($Config{d_symlink} && $Config{d_readlink}) {
233                        # copy as symbolic link
234
0
                        symlink(readlink($src), $dest);
235                        # by success take next file, else the file will be
236                        # copied with the command after the eval block of
237                        # this loop
238
0
0
                        if (-e $dest) {
239
0
                            print "$dest\n";
240
0
                            next;
241                        }
242                    }
243                }
244            };
245
5
50
            copy( $src, $dest ) or die "Error: couldn't copy $src to $dest: $!\n";
246
5
            print "$dest\n";
247        }
248
5
        $mode = ( stat($src) )[2];
249
5
        chmod $mode, $dest;
250    }
251
6
    return 1;
252}
253
2541;
255
256# Local Variables:
257# mode: cperl
258# cperl-indent-level: 4
259# fill-column: 100
260# End:
261# vim: expandtab shiftwidth=4: