—
—
—
—
—
—
—
—

              
package Perl::Dist::WiX::Role::Asset;
HideShow 23 lines of Pod
=pod
=head1 NAME
Perl::Dist::WiX::Role::Asset - Role for assets.
=head1 VERSION
This document describes Perl::Dist::WiX::Role::Asset version 1.500002.
=head1 SYNOPSIS
        # Since this is a role, it is composed into classes that use it.
        # It is not used independently.
         
=head1 DESCRIPTION
B<Perl::Dist::WiX::Role::Asset> is a role that provides methods,
attributes, and error checking for assets to be installed in a 
L<Perl::Dist::WiX|Perl::Dist::WiX>-based Perl distribution.
=cut
#<<<
use 5.010;
use Moose::Role;
use File::Spec::Functions        qw( rel2abs catdir catfile );
use MooseX::Types::Moose         qw( Str Maybe );
use Params::Util                 qw( _INSTANCE );
use English                      qw( -no_match_vars );
use File::Path              2.08 qw();
use File::List::Object           qw();
use File::ShareDir               qw();
use File::Spec::Unix             qw();
use Perl::Dist::WiX::Exceptions  qw();
use URI                          qw();
use URI::file                    qw();
#>>>
our $VERSION = '1.500002';
HideShow 16 lines of Pod
=head1 ATTRIBUTES
Attributes of this role also become parameters to the new() constructor for 
classes that use this role.
=head2 parent
This is the L<Perl::Dist::WiX|Perl::Dist::WiX> object that uses an asset 
object that uses this role. The Perl::Dist::WiX object handles a number 
of private methods for the asset object.
It is required, and has no default, so an error will be thrown if it is not 
given.
=cut
has parent => (
        is       => 'ro',
        isa      => 'Perl::Dist::WiX',
        reader   => '_get_parent',
        weak_ref => 1,
        handles  => {
                '_get_image_dir',   => 'image_dir',
                '_get_download_dir' => 'download_dir',
                '_get_output_dir'   => 'output_dir',
                '_get_modules_dir'  => 'modules_dir',
                '_get_license_dir'  => 'license_dir',
                '_get_build_dir'    => 'build_dir',
                '_get_cpan'         => 'cpan',
                '_get_bin_perl'     => 'bin_perl',
                '_get_wix_dist_dir' => 'wix_dist_dir',
                '_get_icons'        => '_icons',
                '_get_pv_human'     => 'perl_version_human',
                '_module_fix'       => '_module_fix',
                '_trace_line'       => 'trace_line',
                '_mirror'           => 'mirror_url',
                '_mirror_url'       => 'mirror_url',
                '_run3'             => 'execute_any',
                '_filters'          => '_filters',
                '_add_icon'         => 'add_icon',
                '_add_file'         => 'add_file',
                '_copy'             => 'copy_file',
                '_extract'          => 'extract_archive',
                '_extract_filemap'  => '_extract_filemap',
                '_insert_fragment'  => 'insert_fragment',
                '_patch_file'       => 'patch_file',
                '_patch_perl_file'  => 'patch_perl_file',
                '_pushd'            => 'push_dir',
                '_perl'             => 'execute_perl',
                '_build'            => 'execute_build',
                '_make'             => 'execute_make',
                '_gcc_version'      => 'gcc_version',
                '_relocatable'      => 'relocatable',
                '_force'            => 'force',
                '_forceperl'        => 'forceperl',
                '_use_sqlite'       => '_use_sqlite',
                '_add_to_distributions_installed' =>
                  '_add_to_distributions_installed',
        },
        required => 1,
);
HideShow 9 lines of Pod
=head2 url
This attribute is the location on the Internet of the thing the asset 
installs.
Either the 'url' or 'file' parameters are required.
=cut
has url => (
        is       => 'bare',
        isa      => Str,
        reader   => '_get_url',
        writer   => '_set_url',
        required => 1,
);
HideShow 9 lines of Pod
=head2 file
This attribute is the location of the file the asset installs. This could be 
an archive containing multiple files to install.
Either the 'url' or 'file' parameters are required.
=cut
has file => (
        is       => 'bare',
        isa      => Str,
        reader   => '_get_file',
        required => 1,
);
HideShow 10 lines of Pod
=head2 packlist_location
Some distributions create their packlist in an odd location (one 
not specified by the main module in the distribution.)
This optional parameter specifies the directory the packlist is in as a 
relative directory to C<image_dir()> . "/I<install location>/lib/author".
=cut
has packlist_location => (
        is      => 'ro',
        isa     => Maybe [Str],
        reader  => '_get_packlist_location',
        default => undef,
);
HideShow 12 lines of Pod
=head1 METHODS
=head2 install
This role requires that classes that use it implement an C<install> method
that installs the asset.
It does not provide the method itself, but makes classes that use the role
implement the method based on their needs.
=cut
# An asset knows how to install itself.
requires 'install';
sub BUILDARGS {
        my $class = shift;
        my %args;
        # get the argument hash set up.
        if ( @_ == 1 && 'HASH' eq ref $_[0] ) {
                %args = %{ $_[0] };
        } elsif ( 0 == @_ % 2 ) {
                %args = (@_);
        } else {
                PDWiX->throw(
                        'Parameters incorrect (not a hashref or hash) for ::Asset::*');
        }
        # Validate 'parent' parameter early.
        my $parent = $args{parent};
        if ( not defined _INSTANCE( $args{parent}, 'Perl::Dist::WiX' ) ) {
                PDWiX::Parameter->throw(
                        parameter =>
                          'parent: missing or not a Perl::Dist::WiX instance',
                        where => '::Role::Asset->new',
                );
        }
        if ( not defined $args{url} ) {
                if ( defined $args{share} ) {
                        # Map share to url vis File::ShareDir
                        my ( $dist, $name ) = split /\s+/ms, $args{share};
                        $parent->trace_line( 2, "Finding $name in $dist... " );
                        my $file = rel2abs( File::ShareDir::dist_file( $dist, $name ) );
                        if ( not -f $file ) {
                                PDWiX::File->throw(
                                        file    => $file,
                                        message => 'Did not find file'
                                );
                        }
                        $args{url} = URI::file->new($file)->as_string();
                        $parent->trace_line( 2, " found\n" );
                } elsif ( defined $args{name} ) {
                        PDWiX->throw(q{'name' without 'url' is deprecated});
                        # Map name to URL via the default package path
                        $args{url} = $parent->binary_url( $args{name} );
                }
        } ## end if ( not defined $args...)
        if ( $class ne 'Perl::Dist::WiX::Asset::DistFile' ) {
                # Create the filename from the url
                $args{file} = $args{url};
                $args{file} =~ s{.+/}{}ms;
                if ( not defined $args{file} or not length $args{file} ) {
                        if ( $class ne 'Perl::Dist::WiX::Asset::Website' ) {
                                PDWiX::Parameter->throw(
                                        parameter => 'file',
                                        where     => '::Role::Asset->new'
                                );
                        } else {
                                # file is not used in Websites.
                                $args{file} = q{ };
                        }
                } ## end if ( not defined $args...)
        } ## end if ( $class ne 'Perl::Dist::WiX::Asset::DistFile')
        my %default_args = (
                url    => $args{url},
                file   => $args{file},
                parent => $args{parent},
        );
        delete @args{ 'url', 'file', 'parent' };
        return { ( %default_args, %args ) };
} ## end sub BUILDARGS
sub _search_packlist { ## no critic(ProhibitUnusedPrivateSubroutines)
        my ( $self, $module ) = @_;
        # We don't use the error until later, if needed.
        my $error = <<"EOF";
No .packlist found for $module.
Please set packlist => 0 when calling install_distribution or 
install_module for this module.  If this is in an install_modules 
list, please take it out of the list, creating two lists if need 
be, and create an install_module call for this module with 
packlist => 0.
EOF
        chomp $error;
        # Get all the filenames and directory names required.
        my $image_dir   = $self->_get_image_dir();
        my @module_dirs = split /::/ms, $module;
        my @dirs        = (
                catdir( $image_dir, qw{perl vendor lib auto}, @module_dirs ),
                catdir( $image_dir, qw{perl site   lib auto}, @module_dirs ),
                catdir( $image_dir, qw{perl        lib auto}, @module_dirs ),
        );
        my $packlist_location = $self->_get_packlist_location();
        if ( defined $packlist_location ) {
                push @dirs,
                  (
                        catdir(
                                $image_dir, qw{perl vendor lib auto},
                                $packlist_location
                        ),
                        catdir(
                                $image_dir, qw{perl site   lib auto},
                                $packlist_location
                        ),
                        catdir(
                                $image_dir, qw{perl        lib auto},
                                $packlist_location
                        ),
                  );
        } ## end if ( defined $packlist_location)
        # What file exists, if any?
        my $packlist;
  DIR:
        foreach my $dir (@dirs) {
                $packlist = catfile( $dir, '.packlist' );
                last DIR if -r $packlist;
        }
        my $filelist;
        if ( -r $packlist ) {
                # Load a filelist object from the packlist if one exists.
                $filelist =
                  File::List::Object->new()->load_file($packlist)
                  ->add_file($packlist);
        } else {
                # Read the output from installing the module.
                my $output = catfile( $self->_get_output_dir(), 'debug.out' );
                $self->_trace_line( 3,
                        "Attempting to use debug.out file to make filelist\n" );
                my $fh = IO::File->new( $output, 'r' );
                if ( not defined $fh ) {
                        PDWiX->throw("Error reading output file $output: $OS_ERROR");
                }
                my @output_list = <$fh>;
                $fh->close();
                # Parse the output read in for filenames.
                my @files_list =
                  map { ## no critic 'ProhibitComplexMappings'
                        my $t = $_;
                        chomp $t;
                        ( $t =~ / \A Installing [ ] (.*) \z /msx ) ? ($1) : ();
                  } @output_list;
                # Load the filenames into the filelist object.
                if ( $#files_list == 0 ) {
                        # Throw an error if no files were found.
                        PDWiX->throw($error);
                } else {
                        $self->_trace_line( 4, "Adding files:\n" );
                        $self->_trace_line( 4, q{  } . join "\n  ", @files_list );
                        $filelist = File::List::Object->new()->load_array(@files_list);
                }
        } ## end else [ if ( -r $packlist ) ]
        # Return the filelist processed therough the filters.
        return $filelist->filter( $self->_filters() );
} ## end sub _search_packlist
HideShow 10 lines of Pod
=head2 remove_path
The C<remove_path> method is for the convienence of assets that need it.
It removes the path specified, and can take any object (e.g., a
L<Path::Class::Dir|Path::Class::Dir>) that stringifies to a name of a
directory to remove.
=cut
sub remove_path {
        my $class = shift;
        my $dir   = rel2abs(shift);
        my $err;
        if ( -d "$dir" ) {
                File::Path::remove_tree(
                        "$dir",
                        {   keep_root => 0,
                                error     => \$err,
                        } );
                my $e = $EVAL_ERROR;
                if ($e) {
                        PDWiX::Directory->throw(
                                dir     => $dir,
                                message => "Failed to remove directory, critical error:\n$e"
                        );
                }
                if ( @{$err} ) {
                        my $errors = q{};
                        for my $diag ( @{$err} ) {
                                my ( $file, $message ) = %{$diag};
                                if ( $file eq q{} ) {
                                        $errors .= "General error: $message\n";
                                } else {
                                        $errors .= "Problem removing $file: $message\n";
                                }
                        }
                        PDWiX::Directory->throw(
                                dir     => $dir,
                                message => "Failed to remove directory, errors:\n$errors"
                        );
                } ## end if ( @{$err} )
        } ## end if ( -d "$dir" )
        return;
} ## end sub remove_path
1;
__END__
HideShow 28 lines of Pod
=head1 SUPPORT
Bugs should be reported via the CPAN bug tracker at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Perl-Dist-WiX>
For other issues, contact the author.
=head1 AUTHOR
Curtis Jewell E<lt>csjewell@cpan.orgE<gt>
=head1 SEE ALSO
L<Perl::Dist::WiX|Perl::Dist::WiX>
=head1 COPYRIGHT AND LICENSE
Copyright 2009 - 2010 Curtis Jewell.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut