use 5.008001;
use Moose 0.90;
use Moose::Util::TypeConstraints;
use MooseX::Meta::TypeConstraint::Intersection;
use parent qw( Perl::Dist::WiX::BuildPerl
Perl::Dist::WiX::Checkpoint
Perl::Dist::WiX::Libraries
Perl::Dist::WiX::Installation
Perl::Dist::WiX::ReleaseNotes );
use Alien::WiX qw( :ALL );
use Archive::Zip qw( :ERROR_CODES );
use English qw( -no_match_vars );
use List::MoreUtils qw( any none uniq );
use MooseX::Types::Moose qw(
Int Str Maybe Bool Undef ArrayRef Maybe HashRef
);
use MooseX::Types::URI qw( Uri );
use Perl::Dist::WiX::Types qw(
Directory ExistingDirectory ExistingFile MaybeExistingDirectory
);
use Perl::Dist::WiX::PrivateTypes qw(
_NoDoubleSlashes _NoSpaces _NoForwardSlashes _NoSlashAtEnd _NotRootDir
);
use Params::Util qw(
_HASH _STRING _INSTANCE _IDENTIFIER _ARRAY0 _ARRAY
);
use Readonly qw( Readonly );
use Storable qw( retrieve );
use File::Spec::Functions qw(
catdir catfile catpath tmpdir splitpath rel2abs curdir
);
use Archive::Tar 1.42 qw();
use File::HomeDir qw();
use File::Remove qw();
use File::pushd qw();
use File::ShareDir qw();
use File::Copy::Recursive qw();
use File::PathList qw();
use HTTP::Status qw();
use IO::File qw();
use IO::String qw();
use IO::Handle qw();
use IPC::Run3 qw();
use LWP::UserAgent qw();
use LWP::Online qw();
use Module::CoreList 2.18 qw();
use PAR::Dist qw();
use Probe::Perl qw();
use SelectSaver qw();
use Template qw();
use URI qw();
use Win32 qw();
our $VERSION = '1.102_101';
$VERSION =~ s/_//ms;
has 'msi_feature_tree' => (
is => 'ro',
isa => Undef,
default => undef,
);
has '_icons' => (
is => 'ro',
isa => 'Maybe[Perl::Dist::WiX::IconArray]',
writer => '_set_icons',
init_arg => undef,
handles => { 'icons_string' => 'as_string', },
);
has '_toolchain' => (
is => 'bare',
isa => 'Maybe[Perl::Dist::WiX::Toolchain]',
reader => '_get_toolchain',
writer => '_set_toolchain',
init_arg => undef,
);
has '_build_start_time' => (
is => 'ro',
isa => Int,
default => time,
init_arg => undef,
);
has '_directories' => (
is => 'bare',
isa => 'Maybe[Perl::Dist::WiX::DirectoryTree2]',
writer => '_set_directories',
reader => 'get_directory_tree',
default => undef,
init_arg => undef,
);
has '_distributions' => (
traits => ['Array'],
is => 'bare',
isa => ArrayRef [Str],
default => sub { return [] },
init_arg => undef,
handles => {
'_add_distribution' => 'push',
'_get_distributions' => 'elements',
},
);
has '_env_path' => (
traits => ['Array'],
is => 'bare',
isa => ArrayRef [ ArrayRef [Str] ],
default => sub { return [] },
init_arg => undef,
handles => {
'_add_env_path_unchecked' => 'push',
'_get_env_path_unchecked' => 'elements',
},
);
has '_filters' => (
is => 'ro',
isa => ArrayRef [Str],
lazy => 1,
builder => '_build_filters',
init_arg => undef,
);
sub _build_filters {
my $self = shift;
return [ $self->temp_dir() . q{\\},
$self->_dir( qw{ perl man } ) . q{\\},
$self->_dir( qw{ perl html } ) . q{\\},
$self->_dir( qw{ c man } ) . q{\\},
$self->_dir( qw{ c doc } ) . q{\\},
$self->_dir( qw{ c info } ) . q{\\},
$self->_dir( qw{ c contrib } ) . q{\\},
$self->_dir( qw{ c html } ) . q{\\},
$self->_dir( qw{ c examples } ) . q{\\},
$self->_dir( qw{ c manifest } ) . q{\\},
$self->_dir( qw{ cpan sources } ) . q{\\},
$self->_dir( qw{ cpan build } ) . q{\\},
$self->_dir( qw{ c bin startup mac } ) . q{\\},
$self->_dir( qw{ c bin startup msdos } ) . q{\\},
$self->_dir( qw{ c bin startup os2 } ) . q{\\},
$self->_dir( qw{ c bin startup qssl } ) . q{\\},
$self->_dir( qw{ c bin startup tos } ) . q{\\},
$self->_dir( qw{ c libexec gcc mingw32 3.4.5 install-tools}) . q{\\},
$self->_file( qw{ c COPYING } ),
$self->_file( qw{ c COPYING.LIB } ),
$self->_file( qw{ c bin gccbug } ),
$self->_file( qw{ c bin mingw32-gcc-3.4.5 } ),
];
}
has '_fragments' => (
traits => ['Hash'],
is => 'ro',
isa => 'HashRef[WiX3::XML::Role::Fragment]'
,
default => sub { return {} },
init_arg => undef,
handles => {
get_fragment_object => 'get',
fragment_exists => 'defined',
_add_fragment => 'set',
_clear_fragments => 'clear',
_fragment_keys => 'keys',
},
);
has '_merge_modules' => (
traits => ['Hash'],
is => 'bare',
isa => 'HashRef[Perl::Dist::WiX::Tag::MergeModule]',
default => sub { return {} },
init_arg => undef,
handles => {
get_merge_module_object => 'get',
merge_module_exists => 'defined',
_add_merge_module => 'set',
_clear_merge_modules => 'clear',
_merge_module_keys => 'keys',
},
);
has '_in_merge_module' => (
is => 'ro',
isa => Bool,
default => 1,
init_arg => undef,
writer => '_set_in_merge_module',
);
has '_output_file' => (
traits => ['Array'],
is => 'bare',
isa => ArrayRef [Str],
default => sub { return [] },
init_arg => undef,
handles => {
add_output_file => 'push',
add_output_files => 'push',
get_output_files => 'elements',
},
);
has '_perl_version_corelist' => (
is => 'ro',
isa => Maybe [HashRef],
lazy => 1,
builder => '_build_perl_version_corelist',
init_arg => undef,
);
sub _build_perl_version_corelist {
my $self = shift;
my $corelist_version = $self->perl_version_literal() + 0;
my $hash = $Module::CoreList::version{$corelist_version};
unless ( _HASH($hash) ) {
PDWiX->throw( 'Failed to resolve Module::CoreList hash for '
. $self->perl_version_human() );
}
return $hash;
}
has 'pdw_class' => (
is => 'ro',
isa => Str,
required => 1,
);
has 'pdw_version' => (
is => 'ro',
isa => Str,
default => $Perl::Dist::WiX::VERSION,
init_arg => undef,
);
has '_guidgen' => (
is => 'ro',
writer => '_set_guidgen',
required => 1,
);
has '_trace_object' => (
is => 'ro',
isa => 'WiX3::Traceable',
required => 1,
writer => '_set_trace_object',
handles => ['trace_line'],
);
has _user_agent_directory => (
is => 'ro',
isa => ExistingDirectory,
lazy => 1,
builder => '_build_user_agent_directory',
init_arg => undef,
);
sub _build_user_agent_directory {
my $self = shift;
my $path = ref $self;
$path =~ s{::}{-}gmsx;
my $dir =
File::Spec->catdir( File::HomeDir->my_data(), 'Perl', $path, );
unless ( -d $dir ) {
unless ( File::Path::mkpath( $dir, { verbose => 0 } ) ) {
PDWiX->throw("Failed to create $dir");
}
}
unless ( -w $dir ) {
PDWiX->throw(
"No write permissions for LWP::UserAgent cache '$dir'");
}
return $dir;
}
has '_cpan_moved' => (
traits => ['Bool'],
is => 'bare',
isa => Bool,
reader => '_has_moved_cpan',
default => 0,
init_arg => undef,
handles => { '_move_cpan' => 'set', },
);
has '_cpan_sources_to' => (
is => 'ro',
isa => Str,
writer => '_set_cpan_sources_to',
default => undef,
init_arg => undef,
);
has '_cpan_sources_from' => (
is => 'ro',
isa => Str,
writer => '_set_cpan_sources_from',
default => undef,
init_arg => undef,
);
has '_portable_dist' => (
is => 'ro',
isa => 'Maybe[Portable::Dist]',
writer => '_set_portable_dist',
default => undef,
init_arg => undef,
);
has 'app_id' => (
is => 'ro',
required => 1,
);
has 'app_name' => (
is => 'ro',
isa => Str,
required => 1,
);
has 'app_publisher' => (
is => 'ro',
isa => Str,
required => 1,
);
has 'app_publisher_url' => (
is => 'ro',
isa => Uri,
coerce => 1,
required => 1,
);
has 'app_ver_name' => (
is => 'ro',
isa => Str,
lazy => 1,
builder => '_build_app_ver_name',
);
sub _build_app_ver_name {
my $self = shift;
return $self->app_name() . q{ } . $self->perl_version_human();
}
has 'beta_number' => (
is => 'ro',
isa => Int,
default => 0,
);
has 'binary_root' => (
is => 'ro',
isa => Uri,
coerce => 1,
lazy => 1,
builder => '_build_binary_root',
);
sub _build_binary_root {
my $self = shift;
if ( $self->offline() ) {
return URI::file->new( $self->download_dir() );
} else {
}
}
has 'bits' => (
is => 'ro',
isa => subtype(
'Int' => where {
if ( not defined $_ ) {
$_ = 32;
}
$_ == 32 or $_ == 64;
},
message {
'Not 32 or 64-bit';
},
),
default => 32,
);
has 'build_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => ExistingDirectory,
type_constraints =>
[ _NoDoubleSlashes, _NoForwardSlashes, _NoSlashAtEnd ],
),
lazy => 1,
builder => '_build_build_dir',
);
sub _build_build_dir {
my $self = shift;
my $dir = catdir( $self->temp_dir(), 'build' );
$self->_remake_path($dir);
return $dir;
}
has 'build_number' => (
is => 'ro',
isa => subtype(
'Int' => where { $_ < 256 and $_ >= 0 },
message {'Build number must be between 0 and 255'}
),
required => 1,
);
has 'checkpoint_after' => (
is => 'ro',
isa => ArrayRef [Int],
writer => '_set_checkpoint_after',
default => sub { return [0] },
);
has 'checkpoint_before' => (
is => 'ro',
isa => Int,
writer => '_set_checkpoint_before',
default => 0,
);
has 'checkpoint_dir' => (
is => 'ro',
isa => Maybe [ExistingDirectory],
lazy => 1,
builder => '_build_checkpoint_dir',
);
sub _build_checkpoint_dir {
my $self = shift;
my $dir = catdir( $self->temp_dir(), 'checkpoint' );
$self->_remake_path($dir);
return $dir;
}
has 'checkpoint_stop' => (
is => 'ro',
isa => Int,
writer => '_set_checkpoint_stop',
default => 0,
);
has 'cpan' => (
is => 'ro',
isa => Uri,
lazy => 1,
coerce => 1,
builder => '_build_cpan',
);
sub _build_cpan {
my $self = shift;
if ( $self->offline() ) {
PDWiX::Parameter->throw(
parameter => 'cpan: Required if offline => 1',
where => '->new'
);
} else {
}
return;
}
has 'debug_stderr' => (
is => 'ro',
isa => Str,
lazy => 1,
default => sub {
my $self = shift;
return catfile( $self->output_dir(), 'debug.err' );
},
);
has 'debug_stdout' => (
is => 'ro',
isa => Str,
lazy => 1,
default => sub {
my $self = shift;
return catfile( $self->output_dir(), 'debug.out' );
},
);
has 'default_group_name' => (
is => 'ro',
isa => Str,
lazy => 1,
default => sub {
my $self = shift;
return $self->app_name();
},
);
has 'download_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => ExistingDirectory,
type_constraints =>
[ _NoDoubleSlashes, _NoSpaces, _NoForwardSlashes, _NoSlashAtEnd ],
),
lazy => 1,
builder => '_build_download_dir',
);
sub _build_download_dir {
my $self = shift;
my $dir = catdir( $self->temp_dir(), 'download' );
$self->_make_path($dir);
return $dir;
}
has 'exe' => (
is => 'ro',
isa => Bool,
writer => '_set_exe',
default => 0,
);
has 'fileid_perl' => (
is => 'ro',
isa => Str,
writer => '_set_fileid_perl',
default => q{},
);
has 'fileid_relocation_pl' => (
is => 'ro',
isa => Str,
writer => '_set_fileid_relocation_pl',
default => q{},
);
has 'force' => (
is => 'ro',
isa => Bool,
default => 0,
);
has 'forceperl' => (
is => 'ro',
isa => Bool,
default => 0,
);
has 'fragment_dir' => (
is => 'ro',
isa => ExistingDirectory,
lazy => 1,
builder => '_build_fragment_dir',
);
sub _build_fragment_dir {
my $self = shift;
my $dir = catdir( $self->temp_dir(), 'fragments' );
$self->_remake_path($dir);
return $dir;
}
has 'gcc_version' => (
is => 'ro',
isa => subtype(
'Int' => where { $_ == 3 or $_ == 4 },
message {'Not 3 or 4'}
),
default => 3,
);
has 'git_checkout' => (
is => 'ro',
isa => Maybe [ExistingDirectory],
builder => '_build_git_checkout',
);
sub _build_git_checkout {
my $dir = q{C:\\perl-git};
if ( -d $dir ) {
return $dir;
} else {
return undef;
}
}
has 'git_location' => (
is => 'ro',
isa => Maybe [ExistingFile],
builder => '_build_git_location',
);
sub _build_git_location {
my $file = 'C:\Program Files\Git\bin\git.exe';
if ( -f $file ) {
return $file;
} else {
return undef;
}
}
has 'image_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => ExistingDirectory,
type_constraints => [
_NoDoubleSlashes, _NoSpaces,
_NoForwardSlashes, _NoSlashAtEnd,
_NotRootDir,
],
),
required => 1,
);
has 'license_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => ExistingDirectory,
type_constraints =>
[ _NoDoubleSlashes, _NoSpaces, _NoForwardSlashes, _NoSlashAtEnd ],
),
lazy => 1,
builder => '_build_license_dir',
);
sub _build_license_dir {
my $self = shift;
my $dir = $self->_dir('licenses');
$self->_remake_path($dir);
return $dir;
}
has 'modules_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => ExistingDirectory,
type_constraints =>
[ _NoDoubleSlashes, _NoSpaces, _NoForwardSlashes, _NoSlashAtEnd ],
),
lazy => 1,
builder => '_build_modules_dir',
);
sub _build_modules_dir {
my $self = shift;
my $dir = catdir( $self->download_dir(), 'modules' );
$self->_make_path($dir);
return $dir;
}
has 'msi' => (
is => 'ro',
isa => Bool,
writer => '_set_msi',
default => sub {
my $self = shift;
return $self->portable() ? 0 : 1;
},
);
has 'msi_banner_side' => (
is => 'ro',
);
has 'msi_banner_top' => (
is => 'ro',
);
has 'msi_debug' => (
is => 'ro',
isa => Bool,
default => 0,
);
has 'msi_help_url' => (
is => 'ro',
isa => Uri | Undef
,
coerce => 1,
default => undef,
);
has 'msi_license_file' => (
is => 'ro',
lazy => 1,
default => sub {
my $self = shift;
return catfile( $self->wix_dist_dir(), 'License.rtf' );
},
);
has 'msi_product_icon' => (
is => 'ro',
);
has 'msi_readme_file' => (
is => 'ro',
);
has 'msm' => (
is => 'ro',
isa => Bool,
default => 1,
);
has 'msm_code' => (
is => 'ro',
isa => Maybe [Str],
default => undef,
);
has 'msm_to_use' => (
is => 'ro',
isa => Uri | Undef,
default => undef,
coerce => 1,
);
has 'msm_zip' => (
is => 'ro',
isa => Uri | Undef,
default => undef,
coerce => 1,
);
has 'offline' => (
is => 'ro',
isa => Bool,
default => sub { return !!LWP::Online::offline() },
);
has 'output_base_filename' => (
is => 'ro',
isa => Str,
lazy => 1,
builder => '_build_output_base_filename',
);
sub _build_output_base_filename {
my $self = shift;
my $bits = ( 64 == $self->bits ) ? q{64bit-} : q{};
return
$self->app_id() . q{-}
. $self->perl_version_human() . q{-}
. $bits
. $self->output_date_string();
}
has 'output_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => ExistingDirectory,
type_constraints =>
[ _NoDoubleSlashes, _NoSpaces, _NoForwardSlashes, _NoSlashAtEnd ],
),
lazy => 1,
builder => '_build_output_dir',
);
sub _build_output_dir {
my $self = shift;
my $dir = catdir( $self->temp_dir(), 'output' );
$self->_make_path($dir);
return $dir;
}
has 'perl_config_cf_email' => (
is => 'ro',
default => 'anonymous@unknown.builder.invalid',
);
has 'perl_config_cf_by' => (
is => 'ro',
isa => Str,
lazy => 1,
builder => '_build_perl_config_cf_by',
);
sub _build_perl_config_cf_by {
my $self = shift;
return $self->perl_config_cf_email() =~ m/\A(.*)@.*\z/msx;
}
has 'perl_debug' => (
is => 'ro',
isa => Bool,
default => 0,
);
has 'perl_version' => (
is => 'ro',
isa => Str,
default => '5101',
);
has 'portable' => (
is => 'ro',
isa => Bool,
default => 0,
);
has 'relocatable' => (
is => 'ro',
isa => Bool,
default => 0,
);
has 'sitename' => (
is => 'ro',
required => 1,
);
has 'tasklist' => (
is => 'ro',
isa => ArrayRef [Str],
builder => '_build_tasklist',
);
sub _build_tasklist {
return [
'final_initialization',
'install_c_toolchain',
'install_perl',
'install_perl_toolchain',
'install_cpan_upgrades',
'install_portable',
'install_relocatable',
'remove_waste',
'regenerate_fragments',
'find_relocatable_fields',
'write_merge_module',
'install_win32_extras',
'create_distribution_list',
'regenerate_fragments',
'write',
];
}
has 'temp_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => Directory,
type_constraints =>
[ _NoDoubleSlashes, _NoForwardSlashes, _NoSlashAtEnd ],
),
default => sub { return catdir( tmpdir(), 'perldist' ) },
);
has 'tempenv_dir' => (
is => 'ro',
isa => MooseX::Meta::TypeConstraint::Intersection->new(
parent => Directory,
type_constraints =>
[ _NoDoubleSlashes, _NoForwardSlashes, _NoSlashAtEnd ],
),
lazy => 1,
builder => '_build_tempenv_dir',
);
sub _build_tempenv_dir {
my $self = shift;
my $dir = catdir( $self->temp_dir(), 'tempenv' );
$self->_remake_path($dir);
return $dir;
}
has 'trace' => (
is => 'ro',
isa => Int,
default => 1,
);
has 'user_agent' => (
is => 'ro',
isa => 'LWP::UserAgent',
lazy => 1,
builder => '_build_user_agent',
);
sub _build_user_agent {
my $self = shift;
my $ua;
if ( $self->user_agent_cache() ) {
SCOPE: {
local $ENV{HOME} ||= File::HomeDir->my_home;
}
$ua = LWP::UserAgent::WithCache->new( {
agent => ref($self) . q{/} . ( $VERSION || '0.00' ),
namespace => 'perl-dist',
cache_root => $self->_user_agent_directory(),
cache_depth => 0,
default_expires_in => 86_400 * 30,
show_progress => 1,
} );
} else {
$ua = LWP::UserAgent->new(
agent => ref($self) . q{/} . ( $VERSION || '0.00' ),
timeout => 30,
show_progress => 1,
);
}
$ENV{HTTP_PROXY} and $ua->proxy( http => $ENV{HTTP_PROXY} );
return $ua;
}
has 'user_agent_cache' => (
is => 'ro',
isa => Bool,
default => 1,
);
has 'zip' => (
is => 'ro',
isa => Bool,
lazy => 1,
default => sub {
my $self = shift;
return $self->portable() ? 1 : 0;
},
);
sub BUILDARGS {
my $class = shift;
my %params;
if ( @_ == 1 && 'HASH' eq ref $_[0] ) {
%params = %{ $_[0] };
} elsif ( 0 == @_ % 2 ) {
%params = (@_);
} else {
PDWiX->throw(
'Parameters incorrect (not a hashref or hash) for Perl::Dist::WiX->new()'
);
}
eval {
$params{_trace_object} ||=
WiX3::Traceable->new( tracelevel => $params{trace} );
1;
} || eval {
WiX3::Trace::Object->_clear_instance();
WiX3::Traceable->_clear_instance();
$params{_trace_object} ||=
WiX3::Traceable->new( tracelevel => $params{trace} );
} || die 'Could not create trace object';
{
my $time = scalar localtime;
$params{_trace_object}
->trace_line( 0, "Starting build at $time.\n" );
}
unless ( _STRING( $params{app_publisher_url} ) ) {
PDWiX::Parameter->throw(
parameter => 'app_publisher_url',
where => '::Installer->new'
);
}
unless ( _STRING( $params{sitename} ) ) {
$params{sitename} = URI->new( $params{app_publisher_url} )->host;
}
$params{_guidgen} ||=
WiX3::XML::GeneratesGUID::Object->new(
_sitename => $params{sitename} );
if ( $params{temp_dir} =~ m{[.]}ms ) {
PDWiX::Parameter->throw(
parameter => 'temp_dir: Cannot be '
. 'a directory that has a . in the name.',
where => '->new'
);
}
if ( defined $params{build_dir} && $params{build_dir} =~ m{[.]}ms ) {
PDWiX::Parameter->throw(
parameter => 'build_dir: Cannot be '
. 'a directory that has a . in the name.',
where => '->new'
);
}
if ( defined $params{image_dir} ) {
my $perl_location = lc Probe::Perl->find_perl_interpreter();
$params{_trace_object}
->trace_line( 3, "Currently executing perl: $perl_location\n" );
my $our_perl_location =
lc catfile( $params{image_dir}, qw(perl bin perl.exe) );
$params{_trace_object}->trace_line( 3,
"Our perl to create: $our_perl_location\n" );
PDWiX::Parameter->throw(
parameter => ' image_dir : attempting to commit suicide ',
where => '->new'
) if ( $our_perl_location eq $perl_location );
PDWiX::Parameter->throw(
parameter =>
' image_dir : cannot contain two consecutive slashes ',
where => '->new'
) if ( $params{image_dir} =~ m{\\\\}ms );
PDWiX::Parameter->throw(
parameter => 'image_dir: Spaces are not allowed',
where => '->new'
) if ( $params{image_dir} =~ /\s/ms );
$class->_make_path( $params{image_dir} );
} else {
PDWiX::Parameter->throw(
parameter => 'image_dir: is not defined',
where => '->new'
);
}
if ( $params{app_name} =~ m{[\\/:*"<>|]}msx ) {
PDWiX::Parameter->throw(
parameter => 'app_name: Contains characters invalid '
. 'for Windows file/directory names',
where => '->new'
);
}
$params{pdw_class} = $class;
return \%params;
}
sub DEMOLISH {
my $self = shift;
if ( $self->_has_moved_cpan() ) {
my $x = eval {
File::Remove::remove( \1, $self->_cpan_sources_from() );
File::Copy::Recursive::move( $self->_cpan_sources_to(),
$self->_cpan_sources_from() );
};
}
return;
}
has 'feature_tree_object' => (
is => 'ro',
isa => 'Maybe[Perl::Dist::WiX::FeatureTree2]',
writer => '_set_feature_tree_object',
default => undef,
init_arg => undef,
);
has 'bin_perl' => (
is => 'ro',
isa => Maybe [Str],
writer => '_set_bin_perl',
init_arg => undef,
default => undef,
);
has 'bin_make' => (
is => 'ro',
isa => Maybe [Str],
writer => '_set_bin_make',
init_arg => undef,
default => undef,
);
has 'bin_pexports' => (
is => 'ro',
isa => Maybe [Str],
writer => '_set_bin_pexports',
init_arg => undef,
default => undef,
);
has 'bin_dlltool' => (
is => 'ro',
isa => Maybe [Str],
writer => '_set_bin_dlltool',
init_arg => undef,
default => undef,
);
sub dist_dir {
my $self = shift;
return $self->wix_dist_dir();
}
has 'wix_dist_dir' => (
is => 'ro',
isa => ExistingDirectory,
builder => '_build_wix_dist_dir',
init_arg => undef,
);
sub _build_wix_dist_dir {
my $dir;
unless ( eval { $dir = File::ShareDir::dist_dir('Perl-Dist-WiX'); 1; } )
{
PDWiX::Caught->throw(
message =>
'Could not find distribution directory for Perl::Dist::WiX',
info => ( defined $EVAL_ERROR ) ? $EVAL_ERROR : 'Unknown error',
);
}
return $dir;
}
has 'git_describe' => (
is => 'ro',
isa => Str,
lazy => 1,
builder => '_build_git_describe',
init_arg => undef,
);
sub _build_git_describe {
my $self = shift;
my $checkout = $self->git_checkout();
my $location = $self->git_location();
if ( not -f $location ) {
PDWiX->throw("Could not find git at $location");
}
$location = Win32::GetShortPathName($location);
if ( not defined $location ) {
PDWiX->throw(
'Could not convert the location of git.exe to a path with short names'
);
}
$self->trace_line( 2,
"Finding current commit using $location describe\n" );
my $describe =
qx{cmd.exe /d /e:on /c "pushd $checkout && $location describe && popd"};
if ($CHILD_ERROR) {
PDWiX->throw("'git describe' returned an error: $CHILD_ERROR");
}
$describe =~ s/v5[.]/5./ms;
$describe =~ s/\n//ms;
return $describe;
}
has 'perl_version_literal' => (
is => 'ro',
lazy => 1,
builder => '_build_perl_version_literal',
init_arg => undef,
);
sub _build_perl_version_literal {
my $self = shift;
my $x = {
'589' => '5.008009',
'5100' => '5.010000',
'5101' => '5.010001',
'5115' => '5.011005',
'git' => '5.011005',
}->{ $self->perl_version() }
|| 0;
unless ($x) {
PDWiX::Parameter->throw(
parameter => 'perl_version_literal: Failed to resolve',
where => '->(building of accessor)'
);
}
return $x;
}
has 'perl_version_human' => (
is => 'ro',
lazy => 1,
builder => '_build_perl_version_human',
writer => '_set_perl_version_human',
init_arg => undef,
);
sub _build_perl_version_human {
my $self = shift;
my $x = {
'589' => '5.8.9',
'5100' => '5.10.0',
'5101' => '5.10.1',
'5115' => '5.11.5',
'git' => 'git',
}->{ $self->perl_version() }
|| 0;
unless ($x) {
PDWiX::Parameter->throw(
parameter => 'perl_version_human: Failed to resolve',
where => '->(building of accessor)'
);
}
return $x;
}
sub distribution_version_human {
my $self = shift;
my $version = $self->perl_version_human();
if ( 'git' eq $version ) {
$version = $self->git_describe();
}
return
$version . q{.}
. $self->build_number()
. ( $self->portable() ? ' Portable' : q{} )
. ( $self->beta_number() ? ' Beta ' . $self->beta_number() : q{} );
}
sub distribution_version_file {
my $self = shift;
my $version = $self->perl_version_human();
if ( 'git' eq $version ) {
$version = $self->git_describe();
}
return
$version . q{.}
. $self->build_number()
. ( $self->portable() ? '-portable' : q{} )
. ( $self->beta_number() ? '-beta-' . $self->beta_number() : q{} );
}
sub output_date_string {
my @t = localtime;
return sprintf '%04d%02d%02d', $t[5] + 1900, $t[4] + 1, $t[3];
}
sub msi_ui_type {
my $self = shift;
if ( defined $self->msi_feature_tree() ) {
return 'FeatureTree';
} elsif ( $self->relocatable() ) {
return 'MyInstallDir';
} else {
return 'Minimal';
}
}
sub msi_platform_string {
my $self = shift;
return ( 64 == $self->bits() ) ? 'x64' : 'x86';
}
sub msi_product_icon_id {
my $self = shift;
if ( defined $self->msi_product_icon() ) {
return 'I_'
. $self->_icons()->search_icon( $self->msi_product_icon );
} else {
return undef;
}
}
sub msi_product_id {
my $self = shift;
my $generator = WiX3::XML::GeneratesGUID::Object->instance();
my $product_name =
$self->app_name()
. ( $self->portable() ? ' Portable ' : q{ } )
. $self->app_publisher_url()
. q{ ver. }
. $self->msi_perl_version();
my $guid = $generator->generate_guid($product_name);
return $guid;
}
sub msm_product_id {
my $self = shift;
my $generator = WiX3::XML::GeneratesGUID::Object->instance();
my $product_name =
$self->app_name()
. ( $self->portable() ? ' Portable ' : q{ } )
. $self->app_publisher_url()
. q{ ver. }
. $self->msi_perl_version()
. q{ merge module.};
my $guid = $generator->generate_guid($product_name);
$guid =~ s/-/_/msg;
return $guid;
}
sub msi_upgrade_code {
my $self = shift;
my $generator = WiX3::XML::GeneratesGUID::Object->instance();
my $upgrade_ver =
$self->app_name()
. ( $self->portable() ? ' Portable' : q{} ) . q{ }
. $self->app_publisher_url();
my $guid = $generator->generate_guid($upgrade_ver);
return $guid;
}
sub msm_package_id {
my $self = shift;
if ( defined $self->msm_code() ) { return $self->msm_code(); }
my $generator = WiX3::XML::GeneratesGUID::Object->instance();
my $upgrade_ver =
$self->app_name()
. ( $self->portable() ? ' Portable' : q{} ) . q{ }
. $self->app_publisher_url()
. q{ merge module.};
my $guid = $generator->generate_guid($upgrade_ver);
return $guid;
}
sub msm_package_id_property {
my $self = shift;
my $guid = $self->msm_package_id();
$guid =~ s/-/_/msg;
return $guid;
}
sub msm_code_property {
my $self = shift;
my $guid = $self->msm_code();
$guid =~ s/-/_/msg;
return $guid;
}
sub msi_perl_version {
my $self = shift;
my $ver = {
'589' => [ 5, 8, 9 ],
'5100' => [ 5, 10, 0 ],
'5101' => [ 5, 10, 1 ],
'5115' => [ 5, 11, 5 ],
'git' => [ 5, 0, 0 ],
}->{ $self->perl_version() }
|| [ 0, 0, 0 ];
$ver->[2] = ( $ver->[2] << 8 ) + $self->build_number();
return join q{.}, @{$ver};
}
sub msi_perl_major_version {
my $self = shift;
my $ver = {
'589' => [ 5, 8, 0 ],
'5100' => [ 5, 9, 255 ],
'5101' => [ 5, 10, 0 ],
'5115' => [ 5, 11, 4 ],
'git' => [ 5, 11, 0 ],
}->{ $self->perl_version() }
|| [ 0, 0, 0 ];
$ver->[2] <<= 8;
$ver->[2] += 255;
if ( 'git' eq $self->perl_version() ) {
$ver->[2] = $self->build_number() - 1;
}
return join q{.}, @{$ver};
}
sub msi_relocation_commandline {
my $self = shift;
my $perl_id =
$self->fileid_perl() . q{.} . $self->msm_package_id_property();
my $script_id =
$self->fileid_relocation_pl() . q{.}
. $self->msm_package_id_property();
my $answer = join q{ }, ""[#$perl_id]"", "[#$script_id]",
'--location', '[#INSTALLDIR]', '--quiet';
my %files = $self->msi_relocation_commandline_files();
my ( $fragment, $file, $id );
while ( ( $fragment, $file ) = each %files ) {
$id = $self->get_fragment_object($fragment)->find_file($file);
PDWiX->throw("Could not find file $file in fragment $fragment\n")
if not defined $id;
$answer .= " --file [#$id]";
}
return $answer;
}
sub msm_relocation_commandline {
my $self = shift;
my $perl_id = $self->fileid_perl();
my $script_id = $self->fileid_relocation_pl();
my $answer = join q{ }, ""[#$perl_id]"", "[#$script_id]",
'--location', '[#INSTALLDIR]', '--quiet';
my %files = $self->msm_relocation_commandline_files();
my ( $fragment, $file, $id );
while ( ( $fragment, $file ) = each %files ) {
$id = $self->get_fragment_object($fragment)->find_file($file);
PDWiX->throw("Could not find file $file in fragment $fragment\n")
if not defined $id;
$answer .= " --file [#$id]";
}
return $answer;
}
sub msi_relocation_commandline_files {
my $self = shift;
PDWiX::Unimplemented->throw();
return;
}
sub msm_relocation_commandline_files {
my $self = shift;
PDWiX::Unimplemented->throw();
return;
}
sub msi_relocation_ca {
my $self = shift;
return ( 64 == $self->bits() ) ? 'CAQuietExec64' : 'CAQuietExec';
}
sub perl_config_myuname {
my $self = shift;
my $version =
$self->perl_version_human() . q{.} . $self->build_number();
if ( $version =~ m/git/ms ) {
$version = $self->git_describe() . q{.} . $self->build_number();
}
if ( $self->beta_number() > 0 ) {
$version .= '.beta_' . $self->beta_number();
}
my $bits = ( 64 == $self->bits() ) ? 'x64' : 'i386';
return join q{ }, 'Win32', $self->app_id(), $version, '#1',
scalar localtime $self->_build_start_time(), $bits;
}
sub get_component_array {
my $self = shift;
print "Running get_component_array...\n";
my @answer;
foreach my $key ( $self->_fragment_keys() ) {
push @answer,
$self->get_fragment_object($key)->get_componentref_array();
}
return @answer;
}
sub mk_debug {
my $self = shift;
return ( $self->perl_debug() ) ? 'CFG' : '#CFG';
}
sub mk_gcc4 {
my $self = shift;
return ( 4 == $self->gcc_version() ) ? 'GCC_4XX' : '#GCC_4XX';
}
sub mk_bits {
my $self = shift;
my $bits = 1;
$bits &= ( 4 == $self->gcc_version() );
$bits &= ( 32 == $self->bits() );
$bits &= (
'x86' ne (
lc( $ENV{'PROCESSOR_ARCHITECTURE'}
or 'x86'
) )
or 'x86' ne (
lc( $ENV{'PROCESSOR_ARCHITEW6432'}
or 'x86'
) ) );
return $bits ? 'WIN64' : '#WIN64';
}
sub mk_gcc4_dll {
my $self = shift;
return ( 4 == $self->gcc_version() ) ? 'GCCHELPERDLL' : '#GCCHELPERDLL';
}
sub mk_extralibs {
my $self = shift;
return
( 3 == $self->gcc_version() ) ? q{}
: ( 64 == $self->bits() )
? catdir( $self->image_dir, qw(c x86_64-w64-mingw32 lib) )
: catdir( $self->image_dir, qw(c i686-w64-mingw32 lib) );
}
sub prepare { return 1 }
sub run {
my $self = shift;
my $start = time;
unless ( $self->msi or $self->zip ) {
$self->trace_line('No msi or zip target, nothing to do');
return 1;
}
STDOUT->autoflush(1);
STDERR->autoflush(1);
my @task_list = @{ $self->tasklist() };
my $task_number = 1;
my $task;
my $answer = 1;
while ( $answer and ( $task = shift @task_list ) ) {
$answer = $self->checkpoint_task( $task => $task_number );
$task_number++;
}
$self->trace_line( 0,
'Distribution generation completed in '
. ( time - $start )
. " seconds\n" );
foreach my $file ( $self->get_output_files ) {
$self->trace_line( 0, "Created distribution $file\n" );
}
return 1;
}
sub final_initialization {
my $self = shift;
if ( 64 == $self->bits() ) {
$self->_check_64_bit_arch();
}
$self->trace_line( 1,
"Emptying the directory to redirect \$ENV{TEMP} to...\n" );
$self->_remake_path( $self->tempenv_dir() );
$ENV{TEMP} = $self->tempenv_dir();
$self->trace_line( 5, 'Emptied: ' . $self->tempenv_dir() . "\n" );
if ( $self->cpan()->as_string() =~ m{\Afile://}mxsi ) { CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
my $cpan_path_from = $CPAN::Config->{'keep_source_where'};
my $cpan_path_to =
rel2abs( catdir( $cpan_path_from, q{..}, 'old_sources' ) );
$self->trace_line( 0, "Moving CPAN sources files:\n" );
$self->trace_line( 2, <<"EOF");
From: $cpan_path_from
To: $cpan_path_to
EOF
File::Copy::Recursive::move( $cpan_path_from, $cpan_path_to );
$self->_set_cpan_sources_from($cpan_path_from);
$self->_set_cpan_sources_to($cpan_path_to);
$self->_move_cpan();
}
unless ( $self->cpan()->as_string() =~ m{\/\z}ms ) {
PDWiX::Parameter->throw(
parameter => 'cpan: Missing trailing slash',
where => '->final_initialization'
);
}
unless ( $self->can( 'install_perl_' . $self->perl_version() ) ) {
my $class = ref $self;
PDWiX->throw(
"$class does not support Perl " . $self->perl_version() );
}
if ( $self->build_dir() =~ /\s/ms ) {
PDWiX::Parameter->throw(
parameter => 'build_dir: Spaces are not allowed',
where => '->final_initialization'
);
}
if ( $self->portable() ) {
$self->_set_exe(0);
$self->_set_msi(0);
if ( not $self->zip() ) {
PDWiX->throw('Cannot be portable and not build a .zip');
}
}
$self->_set_in_merge_module(1);
$self->trace_line( 2, "Creating in-memory directory tree...\n" );
Perl::Dist::WiX::DirectoryTree2->_clear_instance();
$self->_set_directories(
Perl::Dist::WiX::DirectoryTree2->new(
app_dir => $self->image_dir(),
app_name => $self->app_name(),
)->initialize_tree( $self->perl_version ) );
$self->_add_fragment( 'Environment',
Perl::Dist::WiX::Fragment::Environment->new() );
$self->_add_fragment(
'CreateCpan',
Perl::Dist::WiX::Fragment::CreateFolder->new(
directory_id => 'Cpan',
id => 'CPANFolder',
) );
$self->_add_fragment(
'CreateCpanSources',
Perl::Dist::WiX::Fragment::CreateFolder->new(
directory_id => 'CpanSources',
id => 'CPANSourcesFolder',
) );
$self->_add_fragment(
'CreatePerl',
Perl::Dist::WiX::Fragment::CreateFolder->new(
directory_id => 'Perl',
id => 'PerlFolder',
) );
$self->_add_fragment(
'CreatePerlSite',
Perl::Dist::WiX::Fragment::CreateFolder->new(
directory_id => 'PerlSite',
id => 'PerlSiteFolder',
) );
$self->_add_fragment(
'CreatePerlSiteBin',
Perl::Dist::WiX::Fragment::CreateFolder->new(
directory_id => 'PerlSiteBin',
id => 'PerlSiteBinFolder',
) );
$self->_add_fragment(
'CreateCpanplus',
Perl::Dist::WiX::Fragment::CreateFolder->new(
directory_id => 'Cpanplus',
id => 'CPANPLUSFolder',
) ) if ( '589' ne $self->perl_version() );
my @directories_to_make = ( $self->_dir('cpan'), );
push @directories_to_make, $self->_dir('cpanplus')
if ( '589' ne $self->perl_version() );
for my $d (@directories_to_make) {
next if -d $d;
File::Path::mkpath($d);
}
$self->trace_line( 1,
'Wait a second while we empty the image, '
. "output, and fragment directories...\n" );
$self->_remake_path( $self->image_dir() );
$self->_remake_path( $self->output_dir() );
$self->_remake_path( $self->fragment_dir() );
$self->add_env( 'TERM', 'dumb' );
$self->add_env( 'FTP_PASSIVE', '1' );
return 1;
}
sub _check_64_bit {
my $self = shift;
my $arch = lc( $ENV{'PROCESSOR_ARCHITECTURE'} or 'x86' );
my $archw6432 = lc( $ENV{'PROCESSOR_ARCHITEW6432'} or 'x86' );
if ( ( 'ix86' eq $arch )
or ( 'ix86' eq $archw6432 ) )
{
PDWiX->throw( 'We do not support building 64-bit Perl'
. ' on Itanium architectures.' );
}
if ( ( 'x86' eq $arch )
and ( 'x86' eq $archw6432 ) )
{
PDWiX->throw( 'We do not support building 64-bit Perl'
. ' on 32-bit machines.' );
}
return;
}
sub initialize_nomsm {
my $self = shift;
$self->_set_in_merge_module(0);
$self->_add_fragment(
'StartMenuIcons',
Perl::Dist::WiX::Fragment::StartMenu->new(
directory_id => 'D_App_Menu',
) );
$self->_add_fragment(
'Win32Extras',
Perl::Dist::WiX::Fragment::Files->new(
id => 'Win32Extras',
files => File::List::Object->new(),
) );
$self->_set_icons(
$self->get_fragment_object('StartMenuIcons')->get_icons() );
if ( defined $self->msi_product_icon() ) {
$self->_icons()->add_icon( $self->msi_product_icon() );
}
return 1;
}
sub initialize_using_msm {
my $self = shift;
$self->_set_in_merge_module(0);
my $tgz = $self->_mirror( $self->msm_zip(), $self->download_dir() );
$self->_extract( $tgz, $self->image_dir() );
$self->_add_fragment(
'StartMenuIcons',
Perl::Dist::WiX::Fragment::StartMenu->new(
directory_id => 'D_App_Menu',
) );
$self->_add_fragment(
'Win32Extras',
Perl::Dist::WiX::Fragment::Files->new(
id => 'Win32Extras',
files => File::List::Object->new(),
) );
$self->_set_icons(
$self->get_fragment_object('StartMenuIcons')->get_icons() );
if ( defined $self->msi_product_icon() ) {
$self->_icons()->add_icon( $self->msi_product_icon() );
}
my $msm = $self->_mirror( $self->msm_to_use(), $self->download_dir() );
my $mm = Perl::Dist::WiX::Tag::MergeModule->new(
id => 'Perl',
disk_id => 1,
language => 1033,
source_file => $msm,
primary_reference => 1,
);
$self->_add_merge_module( 'Perl', $mm );
$self->get_directory_tree()
->add_merge_module( $self->image_dir(), $mm );
$self->_set_bin_perl( $self->_file(qw/perl bin perl.exe/) );
$self->_set_bin_make( $self->_file(qw/c bin dmake.exe/) );
$self->_set_bin_pexports( $self->_file(qw/c bin pexports.exe/) );
$self->_set_bin_dlltool( $self->_file(qw/c bin dlltool.exe/) );
$self->add_path( 'perl', 'bin' );
$self->add_path( 'perl', 'site', 'bin' );
$self->add_path( 'c', 'bin' );
return 1;
}
sub install_c_toolchain {
my $self = shift;
$self->install_dmake;
$self->install_gcc_toolchain;
$self->install_mingw_make;
$self->install_pexports;
$self->add_path( 'c', 'bin' );
return 1;
}
sub install_portable {
my $self = shift;
return 1 unless $self->portable();
$self->install_modules( qw(
Sub::Uplevel
) ) unless $self->isa('Perl::Dist::Strawberry');
$self->install_modules( qw(
Test::Exception
) );
$self->install_modules( qw(
Test::Tester
Test::NoWarnings
LWP::Online
) ) unless $self->isa('Perl::Dist::Strawberry');
$self->install_modules( qw(
Class::Inspector
CPAN::Mini
Portable
) ) unless $self->isa('Perl::Dist::Bootstrap');
$self->trace_line( 1, "Creating Portable::Dist\n" );
$self->_set_portable_dist(
Portable::Dist->new( perl_root => $self->_dir('perl') ) );
$self->trace_line( 1, "Running Portable::Dist\n" );
$self->_portable_dist()->run();
$self->trace_line( 1, "Completed Portable::Dist\n" );
$self->install_file(
share => 'Perl-Dist-WiX portable\portable.perl',
install_to => 'portable.perl',
);
$self->install_file(
share => 'Perl-Dist-WiX portable\README.portable.txt',
install_to => 'README.portable.txt',
);
$self->install_file(
share => 'Perl-Dist-WiX portable\portableshell.bat',
install_to => 'portableshell.bat',
);
return 1;
}
sub install_relocatable {
my $self = shift;
return 1 unless $self->relocatable();
$self->_copy( catfile( $self->dist_dir(), 'relocation.pl' ),
$self->image_dir() );
$self->insert_fragment(
'relocation_script',
File::List::Object->new()
->add_file( catfile( $self->image_dir(), 'relocation.pl' ) ),
);
return 1;
}
sub find_relocatable_fields {
my $self = shift;
return 1 unless $self->relocatable();
my $perl_id =
$self->get_fragment_object('perl')
->find_file( catfile( $self->image_dir(), qw(perl bin perl.exe) ) );
if ( not $perl_id ) {
PDWiX->throw("Could not find perl.exe's ID.\n");
}
$self->_set_fileid_perl($perl_id);
my $script_id =
$self->get_fragment_object('relocation_script')
->find_file( catfile( $self->image_dir(), 'relocation.pl' ) );
if ( not $script_id ) {
PDWiX->throw("Could not find relocation.pl's ID.\n");
}
$self->_set_fileid_relocation_pl($script_id);
return 1;
}
sub install_win32_extras {
my $self = shift;
File::Path::mkpath( $self->_dir('win32') );
if ( $self->msi() ) {
$self->install_launcher(
name => 'CPAN Client',
bin => 'cpan',
);
$self->install_website(
name => 'CPAN Search',
icon_file => catfile( $self->wix_dist_dir(), 'cpan.ico' ) );
if ( $self->perl_version_human eq '5.8.9' ) {
$self->install_website(
name => 'Perl 5.8.9 Documentation',
icon_file => catfile( $self->wix_dist_dir(), 'perldoc.ico' )
);
}
if ( $self->perl_version_human eq '5.10.0' ) {
$self->install_website(
name => 'Perl 5.10.0 Documentation',
icon_file => catfile( $self->wix_dist_dir(), 'perldoc.ico' )
);
}
if ( $self->perl_version_human eq '5.10.1' ) {
$self->install_website(
name => 'Perl 5.10.1 Documentation',
icon_file => catfile( $self->wix_dist_dir(), 'perldoc.ico' )
);
}
$self->install_website(
name => 'Win32 Perl Wiki',
icon_file => catfile( $self->wix_dist_dir(), 'win32.ico' ) );
$self->get_fragment_object('StartMenuIcons')->add_shortcut(
name => 'Perl (command line)',
description =>
'Quick way to get to the command line in order to use Perl',
target => '[SystemFolder]cmd.exe',
id => 'PerlCmdLine',
working_dir => 'PersonalFolder',
);
}
return $self;
}
sub remove_waste {
my $self = shift;
$self->trace_line( 1, "Removing waste\n" );
$self->trace_line( 2,
" Removing doc, man, info and html documentation\n" );
$self->_remove_dir(qw{ perl man });
$self->_remove_dir(qw{ perl html });
$self->_remove_dir(qw{ c man });
$self->_remove_dir(qw{ c doc });
$self->_remove_dir(qw{ c info });
$self->_remove_dir(qw{ c contrib });
$self->_remove_dir(qw{ c html });
$self->trace_line( 2, " Removing C examples, manifests\n" );
$self->_remove_dir(qw{ c examples });
$self->_remove_dir(qw{ c manifest });
$self->trace_line( 2, " Removing extra dmake/gcc files\n" );
$self->_remove_dir(qw{ c bin startup mac });
$self->_remove_dir(qw{ c bin startup msdos });
$self->_remove_dir(qw{ c bin startup os2 });
$self->_remove_dir(qw{ c bin startup qssl });
$self->_remove_dir(qw{ c bin startup tos });
$self->_remove_dir(
qw{ c libexec gcc mingw32 3.4.5 install-tools});
$self->trace_line( 2, " Removing redundant files\n" );
$self->_remove_file(qw{ c COPYING });
$self->_remove_file(qw{ c COPYING.LIB });
$self->_remove_file(qw{ c bin gccbug });
$self->_remove_file(qw{ c bin mingw32-gcc-3.4.5 });
$self->trace_line( 2,
" Removing CPAN build directories and download caches\n" );
$self->_remove_dir(qw{ cpan sources });
$self->_remove_dir(qw{ cpan build });
$self->_remove_file(qw{ cpan cpandb.sql });
$self->_remove_file(qw{ cpan FTPstats.yml });
$self->_remove_file(qw{ cpan cpan_sqlite_log.* });
$self->_remake_path( catdir( $self->build_dir, 'cpan' ) );
return 1;
}
sub _remove_dir {
my $self = shift;
my $dir = $self->_dir(@_);
File::Remove::remove( \1, $dir ) if -e $dir;
return 1;
}
sub _remove_file {
my $self = shift;
my $file = $self->_file(@_);
File::Remove::remove( \1, $file ) if -e $file;
return 1;
}
sub regenerate_fragments {
my $self = shift;
return 1 unless $self->msi();
if ( $self->fragment_exists('perl') ) {
$self->add_to_fragment( 'perl',
[ $self->_file(qw(perl lib perllocal.pod)) ] );
}
my @fragment_names_regenerate;
my @fragment_names = $self->_fragment_keys();
while ( 0 != scalar @fragment_names ) {
foreach my $name (@fragment_names) {
my $fragment = $self->get_fragment_object($name);
if ( defined $fragment ) {
push @fragment_names_regenerate, $fragment->regenerate();
} else {
$self->trace_line( 0,
"Couldn't regenerate fragment $name because fragment object did not exist.\n"
);
}
}
$#fragment_names = -1; # clears the array.
@fragment_names = uniq @fragment_names_regenerate;
$#fragment_names_regenerate = -1;
}
return 1;
}
sub write {
my $self = shift;
if ( $self->zip() ) {
$self->add_output_files( $self->_write_zip() );
}
if ( $self->msi() ) {
$self->add_output_files( $self->_write_msi() );
}
return 1;
}
sub write_merge_module {
my $self = shift;
if ( $self->msi() ) {
$self->add_output_files( $self->_write_msm() );
$self->_clear_fragments();
my $zipfile = catfile( $self->output_dir(), 'fragments.zip' );
$self->trace_line( 1, "Generating zip at $zipfile\n" );
my $zip = Archive::Zip->new();
$zip->addTree( $self->fragment_dir(), q{} );
my @members = $zip->members();
foreach my $member (@members) {
next if $member->isDirectory();
$member->desiredCompressionLevel(9);
if ( $member->fileName =~ m{[.] wixout\z}smx ) {
$zip->removeMember($member);
}
if ( $member->fileName =~ m{[.] wixobj\z}smx ) {
$zip->removeMember($member);
}
}
$zip->writeToFileNamed($zipfile);
$self->_remake_path( $self->fragment_dir() );
$self->_set_directories(undef);
Perl::Dist::WiX::DirectoryTree2->_clear_instance();
$self->_set_directories(
Perl::Dist::WiX::DirectoryTree2->new(
app_dir => $self->image_dir(),
app_name => $self->app_name(),
)->initialize_short_tree( $self->perl_version() ) );
$self->_set_in_merge_module(0);
$self->_add_fragment(
'StartMenuIcons',
Perl::Dist::WiX::Fragment::StartMenu->new(
directory_id => 'D_App_Menu',
) );
$self->_add_fragment(
'Win32Extras',
Perl::Dist::WiX::Fragment::Files->new(
id => 'Win32Extras',
files => File::List::Object->new(),
) );
$self->_set_icons(
$self->get_fragment_object('StartMenuIcons')->get_icons() );
if ( defined $self->msi_product_icon() ) {
$self->_icons()->add_icon( $self->msi_product_icon() );
}
my $mm = Perl::Dist::WiX::Tag::MergeModule->new(
id => 'Perl',
disk_id => 1,
language => 1033,
source_file => catfile(
$self->output_dir(), $self->output_base_filename() . '.msm'
),
primary_reference => 1,
);
$self->_add_merge_module( 'Perl', $mm );
$self->get_directory_tree()
->add_merge_module( $self->image_dir(), $mm );
}
return 1;
}
sub _write_zip {
my $self = shift;
my $file =
catfile( $self->output_dir, $self->output_base_filename . '.zip' );
$self->trace_line( 1, "Generating zip at $file\n" );
my $zip = Archive::Zip->new();
$zip->addTree( $self->image_dir(), q{} );
my @members = $zip->members();
foreach my $member (@members) {
next if $member->isDirectory();
$member->desiredCompressionLevel(9);
if ( $member->fileName =~ m{[.] AAA\z}smx ) {
$zip->removeMember($member);
}
}
$zip->writeToFileNamed($file);
return $file;
}
sub add_icon {
my $self = shift;
my %params = @_;
my ( $vol, $dir, $file, $dir_id );
( $vol, $dir, $file ) = splitpath( $params{filename} );
$self->trace_line( 4, "Directory being searched for: $vol $dir\n" );
$dir_id = $self->get_directory_tree()->search_dir(
path_to_find => catdir( $vol, $dir ),
exact => 1,
descend => 1,
)->get_id();
my $id = $params{name};
$id =~ s{\s}{_}msxg;
$self->get_fragment_object('StartMenuIcons')->add_shortcut(
name => $params{name},
description => $params{name},
target => "[D_$dir_id]$file",
id => $id,
working_dir => $dir_id,
icon_id => $params{icon_id},
);
return $self;
}
sub add_path {
my $self = shift;
my @path = @_;
my $dir = $self->_dir(@path);
unless ( -d $dir ) {
PDWiX->throw("PATH directory $dir does not exist");
}
$self->_add_env_path_unchecked( [@path] );
return 1;
}
sub get_path_string {
my $self = shift;
return join q{;},
map { $self->_dir( @{$_} ) } $self->_get_env_path_unchecked();
}
sub _compile_wxs {
my ( $self, $filename, $wixobj ) = @_;
my @files = @_;
unless ( _STRING($filename) ) {
PDWiX::Parameter->throw(
parameter => 'filename',
where => '::Installer->compile_wxs'
);
}
unless ( _STRING($wixobj) ) {
PDWiX::Parameter->throw(
parameter => 'wixobj',
where => '::Installer->compile_wxs'
);
}
unless ( -r $filename ) {
PDWiX->throw("$filename does not exist or is not readable");
}
my $cmd = [
wix_bin_candle(),
'-out', $wixobj,
$filename,
];
my $out;
my $rv = IPC::Run3::run3( $cmd, \undef, \$out, \undef );
if ( ( not -f $wixobj ) and ( $out =~ /error|warning/msx ) ) {
$self->trace_line( 0, $out );
PDWiX->throw( "Failed to find $wixobj (probably "
. "compilation error in $filename)" );
}
return $rv;
}
sub _write_msi {
my $self = shift;
my $dir = $self->fragment_dir;
my ( $fragment, $fragment_name, $fragment_string );
my ( $filename_in, $filename_out );
my $fh;
my @files;
$self->trace_line( 1, "Generating msi\n" );
FRAGMENT:
foreach my $key ( $self->_fragment_keys() ) {
$fragment = $self->get_fragment_object($key);
$fragment_string = $fragment->as_string();
next
if ( ( not defined $fragment_string )
or ( $fragment_string eq q{} ) );
$fragment_name = $fragment->get_id;
$filename_in = catfile( $dir, $fragment_name . q{.wxs} );
$filename_out = catfile( $dir, $fragment_name . q{.wixout} );
$fh = IO::File->new( $filename_in, 'w' );
if ( not defined $fh ) {
PDWiX->throw(
"Could not open file $filename_in for writing [$OS_ERROR] [$EXTENDED_OS_ERROR]"
);
}
$fh->print($fragment_string);
$fh->close;
$self->trace_line( 2, "Compiling $filename_in\n" );
$self->_compile_wxs( $filename_in, $filename_out )
or PDWiX->throw("WiX could not compile $filename_in");
unless ( -f $filename_out ) {
PDWiX->throw( "Failed to find $filename_out (probably "
. "compilation error in $filename_in)" );
}
push @files, $filename_out;
}
$self->_set_feature_tree_object(
Perl::Dist::WiX::FeatureTree2->new( parent => $self, ) );
my $mm;
foreach my $mm_key ( $self->_merge_module_keys() ) {
$mm = $self->get_merge_module_object($mm_key);
$self->feature_tree_object()->add_merge_module($mm);
}
my $content = $self->as_string('Main.wxs.tt');
$content =~ s{\r\n}{\n}msg;
$filename_in =
catfile( $self->fragment_dir(), $self->app_name() . q{.wxs} );
if ( -f $filename_in ) {
PDWiX->throw(
"Could not write out $filename_in: File already exists.");
}
$filename_out =
catfile( $self->fragment_dir, $self->app_name . q{.wixobj} );
$fh = IO::File->new( $filename_in, 'w' );
if ( not defined $fh ) {
PDWiX->throw(
"Could not open file $filename_in for writing [$OS_ERROR] [$EXTENDED_OS_ERROR]"
);
}
$fh->print($content);
$fh->close;
$self->trace_line( 2, "Compiling $filename_in\n" );
$self->_compile_wxs( $filename_in, $filename_out )
or PDWiX->throw("WiX could not compile $filename_in");
unless ( -f $filename_out ) {
PDWiX->throw( "Failed to find $filename_out (probably "
. "compilation error in $filename_in)" );
}
my $output_msi =
catfile( $self->output_dir, $self->output_base_filename . '.msi', );
my $input_wixouts = catfile( $self->fragment_dir, '*.wixout' );
my $input_wixobj =
catfile( $self->fragment_dir, $self->app_name . '.wixobj' );
$self->trace_line( 1, "Linking $output_msi\n" );
my $out;
my $cmd = [
wix_bin_light(),
'-sice:ICE38',
'-sice:ICE43',
'-sice:ICE47',
'-sice:ICE48',
'-out', $output_msi,
'-ext', wix_lib_wixui(),
'-ext', wix_library('WixUtil'),
$input_wixobj,
$input_wixouts,
];
my $rv = IPC::Run3::run3( $cmd, \undef, \$out, \undef );
$self->trace_line( 1, $out );
if ( ( not -f $output_msi ) and ( $out =~ /error|warning/msx ) ) {
$self->trace_line( 0, $out );
PDWiX->throw(
"Failed to find $output_msi (probably compilation error)");
}
return $output_msi;
}
sub _write_msm {
my $self = shift;
my $dir = $self->fragment_dir;
my ( $fragment, $fragment_name, $fragment_string );
my ( $filename_in, $filename_out );
my $fh;
my @files;
$self->trace_line( 1, "Generating msm\n" );
foreach my $value ( map { '[INSTALLDIR]' . catdir( @{$_} ) }
$self->_get_env_path_unchecked() )
{
$self->add_env( 'PATH', $value, 1 );
}
FRAGMENT:
foreach my $key ( $self->_fragment_keys() ) {
$fragment = $self->get_fragment_object($key);
$fragment_string = $fragment->as_string();
next
if ( ( not defined $fragment_string )
or ( $fragment_string eq q{} ) );
$fragment_name = $fragment->get_id();
$filename_in = catfile( $dir, $fragment_name . q{.wxs} );
$filename_out = catfile( $dir, $fragment_name . q{.wixout} );
$fh = IO::File->new( $filename_in, 'w' );
if ( not defined $fh ) {
PDWiX->throw(
"Could not open file $filename_in for writing [$OS_ERROR] [$EXTENDED_OS_ERROR]"
);
}
$fh->print($fragment_string);
$fh->close;
$self->trace_line( 2, "Compiling $filename_in\n" );
$self->_compile_wxs( $filename_in, $filename_out )
or PDWiX->throw("WiX could not compile $filename_in");
unless ( -f $filename_out ) {
PDWiX->throw( "Failed to find $filename_out (probably "
. "compilation error in $filename_in)" );
}
push @files, $filename_out;
}
$self->_set_feature_tree_object(
Perl::Dist::WiX::FeatureTree2->new( parent => $self, ) );
my $content = $self->as_string('Merge-Module.wxs.tt');
$content =~ s{\r\n}{\n}msg;
$filename_in =
catfile( $self->fragment_dir, $self->app_name . q{.wxs} );
if ( -f $filename_in ) {
PDWiX->throw(
"Could not write out $filename_in: File already exists.");
}
$filename_out =
catfile( $self->fragment_dir, $self->app_name . q{.wixobj} );
$fh = IO::File->new( $filename_in, 'w' );
if ( not defined $fh ) {
PDWiX->throw(
"Could not open file $filename_in for writing [$OS_ERROR] [$EXTENDED_OS_ERROR]"
);
}
$fh->print($content);
$fh->close;
$self->trace_line( 2, "Compiling $filename_in\n" );
$self->_compile_wxs( $filename_in, $filename_out )
or PDWiX->throw("WiX could not compile $filename_in");
unless ( -f $filename_out ) {
PDWiX->throw( "Failed to find $filename_out (probably "
. "compilation error in $filename_in)" );
}
my $output_msm =
catfile( $self->output_dir, $self->output_base_filename . '.msm', );
my $input_wixouts = catfile( $self->fragment_dir, '*.wixout' );
my $input_wixobj =
catfile( $self->fragment_dir, $self->app_name . '.wixobj' );
$self->trace_line( 1, "Linking $output_msm\n" );
my $out;
my $cmd = [
wix_bin_light(), '-out',
$output_msm, '-ext',
wix_lib_wixui(), '-ext',
wix_library('WixUtil'), $input_wixobj,
$input_wixouts,
];
my $rv = IPC::Run3::run3( $cmd, \undef, \$out, \undef );
$self->trace_line( 1, $out );
if ( ( not -f $output_msm ) and ( $out =~ /error|warning/msx ) ) {
$self->trace_line( 0, $out );
PDWiX->throw(
"Failed to find $output_msm (probably compilation error)");
}
my $output_docs =
catfile( $self->output_dir(),
'merge-module-' . $self->distribution_version_file() . '.html',
);
my $docs =
$self->process_template('Merge-Module.documentation.html.tt');
$fh = IO::File->new( $output_docs, 'w' );
if ( not defined $fh ) {
PDWiX->throw(
"Could not open file $filename_in for writing [$OS_ERROR] [$EXTENDED_OS_ERROR]"
);
}
$fh->print($docs);
$fh->close;
return ( $output_msm, $output_docs );
}
sub add_env {
my ( $self, $name, $value, $append ) = @_;
unless ( defined $append ) {
$append = 0;
}
unless ( _STRING($name) ) {
PDWiX::Parameter->throw(
parameter => 'name',
where => '::Installer->add_env'
);
}
unless ( _STRING($value) ) {
PDWiX::Parameter->throw(
parameter => 'value',
where => '::Installer->add_env'
);
}
my $env_fragment = $self->get_fragment_object('Environment');
my $num = $env_fragment->get_entries_count();
$env_fragment->add_entry(
id => "Env_$num",
name => $name,
value => $value,
action => 'set',
part => $append ? 'last' : 'all',
);
return $self;
}
sub add_file {
my ( $self, %params ) = @_;
unless ( _STRING( $params{source} ) ) {
PDWiX::Parameter->throw(
parameter => 'source',
where => '::Installer->add_file'
);
}
unless ( -f $params{source} ) {
PDWiX->throw("File $params{source} does not exist");
}
unless ( _IDENTIFIER( $params{fragment} ) ) {
PDWiX::Parameter->throw(
parameter => 'fragment',
where => '::Installer->add_file'
);
}
unless ( $self->fragment_exists( $params{fragment} ) ) {
PDWiX->throw("Fragment $params{fragment} does not exist");
}
$self->get_fragment_object( $params{fragment} )
->add_file( $params{source} );
return $self;
}
sub insert_fragment {
my ( $self, $id, $files_obj, $overwritable ) = @_;
unless ( _IDENTIFIER($id) ) {
PDWiX::Parameter->throw(
parameter => 'id',
where => '->insert_fragment'
);
}
unless ( _INSTANCE( $files_obj, 'File::List::Object' ) ) {
PDWiX::Parameter->throw(
parameter => 'files_obj',
where => '->insert_fragment'
);
}
defined $overwritable or $overwritable = 0;
$self->trace_line( 2, "Adding fragment $id...\n" );
my $frag;
FRAGMENT:
foreach my $frag_key ( $self->_fragment_keys() ) {
$frag = $self->get_fragment_object($frag_key);
next FRAGMENT
if not $frag->isa('Perl::Dist::WiX::Fragment::Files');
$frag->check_duplicates($files_obj);
}
my $fragment = Perl::Dist::WiX::Fragment::Files->new(
id => $id,
files => $files_obj,
can_overwrite => $overwritable,
in_merge_module => $self->_in_merge_module(),
);
$self->_add_fragment( $id, $fragment );
return $fragment;
}
sub add_to_fragment {
my ( $self, $id, $files_ref ) = @_;
unless ( _IDENTIFIER($id) ) {
PDWiX::Parameter->throw(
parameter => 'id',
where => '->add_to_fragment'
);
}
unless ( _ARRAY($files_ref) ) {
PDWiX::Parameter->throw(
parameter => 'files_ref',
where => '->add_to_fragment'
);
}
if ( not $self->fragment_exists($id) ) {
PDWiX->throw("Fragment $id does not exist");
}
my @files = @{$files_ref};
my $files_obj = File::List::Object->new()->add_files(@files);
my $frag;
foreach my $frag_key ( $self->_fragment_keys() ) {
$frag = $self->get_fragment_object($frag_key);
$frag->check_duplicates($files_obj);
}
my $fragment = $self->get_fragment_object($id)->add_files(@files);
return $fragment;
}
sub as_string {
my $self = shift;
my $template_file = shift;
return $self->process_template(
$template_file,
( directory_tree =>
Perl::Dist::WiX::DirectoryTree2->instance()->as_string(),
) );
}
sub process_template {
my $self = shift;
my $template_file = shift;
my @vars_in = @_;
my $tt = Template->new( {
INCLUDE_PATH => [ $self->dist_dir(), $self->wix_dist_dir(), ],
EVAL_PERL => 1,
} )
|| PDWiX::Caught->throw(
message => 'Template error',
info => Template->error(),
);
my $answer;
my $vars = {
dist => $self,
@vars_in,
};
$tt->process( $template_file, $vars, \$answer )
|| PDWiX::Caught->throw(
message => 'Template error',
info => $tt->error() );
$answer =~ s{(?>\x0D\x0A?|[\x0A-\x0C\x85\x{2028}\x{2029}])
\s*?
(?>\x0D\x0A?|[\x0A-\x0C\x85\x{2028}\x{2029}])}
{\r\n}msgx;
return $answer;
}
sub patch_include_path {
my $self = shift;
my $share = File::ShareDir::dist_dir('Perl-Dist-WiX');
my $path = catdir( $share, 'default', );
my $portable = catdir( $share, 'portable', );
unless ( -d $path ) {
PDWiX->throw("Directory $path does not exist");
}
if ( $self->portable() ) {
unless ( -d $portable ) {
PDWiX->throw("Directory $portable does not exist");
}
return [ $portable, $path ];
} else {
return [$path];
}
}
sub patch_pathlist {
my $self = shift;
return File::PathList->new( paths => $self->patch_include_path(), );
}
has 'patch_template' => (
is => 'ro',
isa => 'Maybe[Template]',
lazy => 1,
builder => '_build_patch_template',
);
sub _build_patch_template {
my $self = shift;
return Template->new(
INCLUDE_PATH => $self->patch_include_path,
ABSOLUTE => 1,
);
}
sub patch_file {
my $self = shift;
my $file = shift;
my $file_tt = $file . '.tt';
my $dir = shift;
my $to = catfile( $dir, $file );
my $pathlist = $self->patch_pathlist();
my $from = $pathlist->find_file($file);
my $from_tt = $pathlist->find_file($file_tt);
unless ( defined $from and defined $from_tt ) {
PDWiX->throw(
"Missing or invalid file $file or $file_tt in pathlist search"
);
}
if ( $from_tt ne q{} ) {
my $hash = _HASH(shift) || {};
my ( $fh, $output ) =
File::Temp::tempfile( 'pdwXXXXXX', TMPDIR => 1 );
$self->trace_line( 2,
"Generating $from_tt into temp file $output\n" );
$self->patch_template()
->process( $from_tt, { %{$hash}, self => $self }, $fh, )
or PDWiX->throw("Template processing failed for $from_tt");
$fh->close or PDWiX->throw("Could not close: $OS_ERROR");
$self->_copy( $output => $to );
unlink $output
or PDWiX->throw("Could not delete $output: $OS_ERROR");
} elsif ( $from ne q{} ) {
$self->_copy( $from => $to );
} else {
PDWiX->throw("Failed to find file $file");
}
return 1;
}
sub image_drive {
my $self = shift;
return substr rel2abs( $self->image_dir() ), 0, 2;
}
sub image_dir_url {
my $self = shift;
return URI::file->new( $self->image_dir() )->as_string();
}
sub image_dir_quotemeta {
my $self = shift;
my $string = $self->image_dir();
$string =~ s{\\}
{\\\\}gmsx;
return $string;
}
sub _dir {
return catdir( shift->image_dir(), @_ );
}
sub _file {
return catfile( shift->image_dir(), @_ );
}
sub _mirror {
my ( $self, $url, $dir ) = @_;
my $no_display_trace = 0;
my (undef, undef, undef, $sub, undef,
undef, undef, undef, undef, undef
) = caller 0;
if ( $sub eq 'install_par' ) { $no_display_trace = 1; }
my $file = $url;
$file =~ s{.+\/}
{}msx;
my $target = catfile( $dir, $file );
if ( $self->offline and -f $target ) {
return $target;
}
if ( $self->offline and not $url =~ m{\Afile://}msx ) { PDWiX->throw("Currently offline, cannot download $url.\n");
}
File::Path::mkpath($dir);
$self->trace_line( 2, "Downloading file $url...\n", $no_display_trace );
my $ua = LWP::UserAgent->new;
my $r = $ua->mirror( $url, $target );
if ( $r->is_error ) {
$self->trace_line( 0,
" Error getting $url:\n" . $r->as_string . "\n" );
} elsif ( $r->code == HTTP::Status::RC_NOT_MODIFIED ) {
$self->trace_line( 2, "(already up to date)\n",
$no_display_trace );
}
} else {
my $ua = $self->user_agent();
my $r = $ua->mirror( $url, $target );
if ( $r->is_error ) {
$self->trace_line( 0,
" Error getting $url:\n" . $r->as_string . "\n" );
} elsif ( $r->code == HTTP::Status::RC_NOT_MODIFIED ) {
$self->trace_line( 2, "(already up to date)\n",
$no_display_trace );
}
}
return $target;
}
sub _copy {
my ( $self, $from, $to ) = @_;
my $basedir = File::Basename::dirname($to);
File::Path::mkpath($basedir) unless -e $basedir;
$self->trace_line( 2, "Copying $from to $to\n" );
if ( -f $to and not -w $to ) {
my $file = Win32::File::Object->new( $to, 1 );
my $readonly = $file->readonly();
$file->readonly(0);
File::Copy::Recursive::rcopy( $from, $to )
or PDWiX->throw("Copy error: $OS_ERROR");
$file->readonly($readonly);
} else {
File::Copy::Recursive::rcopy( $from, $to )
or PDWiX->throw("Copy error: $OS_ERROR");
}
return 1;
}
sub _move {
my ( $self, $from, $to ) = @_;
my $basedir = File::Basename::dirname($to);
File::Path::mkpath($basedir) unless -e $basedir;
$self->trace_line( 2, "Moving $from to $to\n" );
File::Copy::Recursive::rmove( $from, $to )
or PDWiX->throw("Move error: $OS_ERROR");
return;
}
sub _pushd {
my $self = shift;
my $dir = catdir(@_);
$self->trace_line( 2, "Lexically changing directory to $dir...\n" );
return File::pushd::pushd($dir);
}
sub _build {
my $self = shift;
my @params = @_;
$self->trace_line( 2,
join( q{ }, '>', 'Build.bat', @params ) . qq{\n} );
$self->_run3( 'Build.bat', @params )
or PDWiX->throw('build failed');
PDWiX->throw('build failed (OS error)') if ( $CHILD_ERROR >> 8 );
return 1;
}
sub _make {
my $self = shift;
my @params = @_;
$self->trace_line( 2,
join( q{ }, '>', $self->bin_make, @params ) . qq{\n} );
$self->_run3( $self->bin_make, @params )
or PDWiX->throw('make failed');
PDWiX->throw('make failed (OS error)') if ( $CHILD_ERROR >> 8 );
return 1;
}
sub _perl {
my $self = shift;
my @params = @_;
unless ( -x $self->bin_perl() ) {
PDWiX->throw( q{Can't execute } . $self->bin_perl() );
}
$self->trace_line( 2,
join( q{ }, '>', $self->bin_perl(), @params ) . qq{\n} );
$self->_run3( $self->bin_perl(), @params )
or PDWiX->throw('perl failed');
PDWiX->throw('perl failed (OS error)') if ( $CHILD_ERROR >> 8 );
return 1;
}
sub _run3 {
my $self = shift;
my @path = split /;/ms, $ENV{PATH};
my @keep = ();
foreach my $p (@path) {
next unless -d $p;
next if -f catfile( $p, 'dmake.exe' );
next if -f catfile( $p, 'perl.exe' );
next if -f catfile( $p, 'unzip.exe' );
next if -f catfile( $p, 'gzip.exe' );
push @keep, $p;
}
local $ENV{LIB} = undef;
local $ENV{INCLUDE} = undef;
local $ENV{PERL5LIB} = undef;
local $ENV{PATH} = $self->get_path_string() . q{;} . join q{;}, @keep;
$self->trace_line( 3, "Path during _run3: $ENV{PATH}\n" );
return IPC::Run3::run3( [@_], \undef, $self->debug_stdout(),
$self->debug_stderr(), );
}
sub _convert_name {
my $name = shift;
my @paths = split m{\/}ms, $name;
my $filename = pop @paths;
$filename = q{} unless defined $filename;
my $local_dirs = @paths ? catdir(@paths) : q{};
my $local_name = catpath( q{}, $local_dirs, $filename );
$local_name = rel2abs($local_name);
return $local_name;
}
sub _extract {
my ( $self, $from, $to ) = @_;
File::Path::mkpath($to);
my $wd = $self->_pushd($to);
my @filelist;
$self->trace_line( 2, "Extracting $from...\n" );
if ( $from =~ m{[.] zip\z}msx ) {
my $zip = Archive::Zip->new($from);
if ( not defined $zip ) {
PDWiX->throw("Could not open archive $from for extraction");
}
my @members = $zip->members();
foreach my $member (@members) {
my $filename = $member->fileName();
$filename = _convert_name($filename)
;
my $status = $member->extractToFileNamed($filename);
if ( $status != AZ_OK ) {
PDWiX->throw('Error in archive extraction');
}
push @filelist, $filename;
}
} elsif ( $from =~ m{ [.] tar [.] gz | [.] tgz}msx ) {
local $Archive::Tar::CHMOD = 0;
my @fl = @filelist = Archive::Tar->extract_archive( $from, 1 );
@filelist = map { catfile( $to, $_ ) } @fl;
if ( !@filelist ) {
PDWiX->throw('Error in archive extraction');
}
} else {
PDWiX->throw("Didn't recognize archive type for $from");
}
return @filelist;
}
sub _extract_filemap {
my ( $self, $archive, $filemap, $basedir, $file_only ) = @_;
my @files;
if ( $archive =~ m{[.] zip\z}msx ) {
my $zip = Archive::Zip->new($archive);
my $wd = $self->_pushd($basedir);
while ( my ( $f, $t ) = each %{$filemap} ) {
$self->trace_line( 2, "Extracting $f to $t\n" );
my $dest = catfile( $basedir, $t );
my @members = $zip->membersMatching("^\Q$f");
foreach my $member (@members) {
my $filename = $member->fileName();
$filename =~
s{\A\Q$f}
{$dest}msx;
$filename = _convert_name($filename);
my $status = $member->extractToFileNamed($filename);
if ( $status != AZ_OK ) {
PDWiX->throw('Error in archive extraction');
}
push @files, $filename;
}
}
} elsif ( $archive =~ m{[.] tar [.] gz | [.] tgz}msx ) {
local $Archive::Tar::CHMOD = 0;
my $tar = Archive::Tar->new($archive);
for my $file ( $tar->get_files ) {
my $f = $file->full_path;
my $canon_f = File::Spec::Unix->canonpath($f);
for my $tgt ( keys %{$filemap} ) {
my $canon_tgt = File::Spec::Unix->canonpath($tgt);
my $t;
if ($file_only) {
next unless
$canon_f =~ m{\A([^/]+[/])?\Q$canon_tgt\E\z}imsx;
( $t = $canon_f ) =~ s{\A([^/]+[/])?\Q$canon_tgt\E\z}
{$filemap->{$tgt}}imsx;
} else {
next unless
$canon_f =~ m{\A([^/]+[/])?\Q$canon_tgt\E}imsx;
( $t = $canon_f ) =~ s{\A([^/]+[/])?\Q$canon_tgt\E}
{$filemap->{$tgt}}imsx;
}
my $full_t = catfile( $basedir, $t );
$self->trace_line( 2, "Extracting $f to $full_t\n" );
$tar->extract_file( $f, $full_t );
push @files, $full_t;
}
}
} else {
PDWiX->throw("Didn't recognize archive type for $archive");
}
return @files;
}
sub _dll_to_a {
my $self = shift;
my %params = @_;
unless ( $self->bin_dlltool ) {
PDWiX->throw('dlltool has not been installed');
}
my @files;
my $source = $params{source};
if ( $source and not( $source =~ /[.]dll\z/msx ) ) {
PDWiX::Parameter->throw(
parameter => 'source',
where => '->_dll_to_a'
);
}
my $dll = $params{dll};
unless ( $dll and $dll =~ /[.]dll/msx ) {
PDWiX::Parameter->throw(
parameter => 'dll',
where => '->_dll_to_a'
);
}
my $def = $params{def};
unless ( $def and $def =~ /[.]def\z/msx ) {
PDWiX::Parameter->throw(
parameter => 'def',
where => '->_dll_to_a'
);
}
my $_a = $params{a};
unless ( $_a and $_a =~ /[.]a\z/msx ) {
PDWiX::Parameter->throw(
parameter => 'a',
where => '->_dll_to_a'
);
}
unless ( ( $source and -f $source ) or -f $dll ) {
PDWiX::Parameter->throw(
parameter => 'source or dll: Need one of '
. 'these two parameters, and the file needs to exist',
where => '->_dll_to_a'
);
}
if ($source) {
$self->_move( $source => $dll );
push @files, $dll;
}
SCOPE: {
my $bin = $self->bin_pexports;
unless ($bin) {
PDWiX->throw('pexports has not been installed');
}
my $ok = !system "$bin $dll > $def";
unless ( $ok and -f $def ) {
PDWiX->throw('pexports failed to generate .def file');
}
push @files, $def;
}
SCOPE: {
my $bin = $self->bin_dlltool;
unless ($bin) {
PDWiX->throw('dlltool has not been installed');
}
my $ok = !system "$bin -dllname $dll --def $def --output-lib $_a";
unless ( $ok and -f $_a ) {
PDWiX->throw('dlltool failed to generate .a file');
}
push @files, $_a;
}
return @files;
}
sub _make_path {
my $class = shift;
my $dir = rel2abs(shift);
File::Path::mkpath($dir) unless -d $dir;
unless ( -d $dir ) {
PDWiX->throw("Failed to create directory $dir");
}
return $dir;
}
sub _remake_path {
my $class = shift;
my $dir = rel2abs(shift);
File::Remove::remove( \1, $dir ) if -d $dir;
File::Path::mkpath($dir);
unless ( -d $dir ) {
PDWiX->throw("Failed to recreate directory $dir");
}
return $dir;
}
1;