run
package Perl::Dist::WiX;
Perl::Dist::WiX - 4th generation Win32 Perl distribution builder
This document describes Perl::Dist::WiX version 1.200001.
This package is the upgrade to Perl::Dist based on Windows Installer XML technology, instead of Inno Setup.
Perl distributions built with this module have the option of being created as Windows Installer databases (otherwise known as .msi files)
# Sets up a distribution with the following options
my $distribution = Perl::Dist::WiX->new(
msi => 1,
trace => 1,
build_number => 1,
cpan => URI->new(('file://C|/minicpan/')),
image_dir => 'C:\myperl',
download_dir => 'C:\cpandl',
output_dir => 'C:\myperl_build',
temp_dir => 'C:\temp',
app_id => 'myperl',
app_name => 'My Perl',
app_publisher => 'My Perl Distribution Project',
app_publisher_url => 'http://test.invalid/',
);
# Creates the distribution
$distribution->run();#<<< use 5.008001; use Moose 0.90; use Moose::Util::TypeConstraints; use namespace::autoclean; use parent qw( Perl::Dist::WiX::BuildPerl Perl::Dist::WiX::Checkpoint Perl::Dist::WiX::Libraries Perl::Dist::WiX::Installation Perl::Dist::WiX::Support 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 MooseX::Types::Path::Class qw( File Dir ); use Perl::Dist::WiX::Types qw( ExistingDirectory ExistingFile TemplateObj ExistingSubdirectory ExistingDirectory_Spaceless ExistingDirectory_SaneSlashes ); 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 File::HomeDir 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.29 qw(); use PAR::Dist qw(); use Path::Class::Dir qw(); use Probe::Perl qw(); use SelectSaver qw(); use Template qw(); use URI qw(); use Win32 qw(); use File::List::Object qw(); use Perl::Dist::WiX::Exceptions qw(); use Perl::Dist::WiX::DirectoryTree2 qw(); use Perl::Dist::WiX::FeatureTree2 qw(); use Perl::Dist::WiX::Fragment::CreateFolder qw(); use Perl::Dist::WiX::Fragment::Files qw(); use Perl::Dist::WiX::Fragment::Environment qw(); use Perl::Dist::WiX::Fragment::StartMenu qw(); use Perl::Dist::WiX::IconArray qw(); use Perl::Dist::WiX::Tag::MergeModule qw(); use WiX3::XML::GeneratesGUID::Object qw(); use WiX3::Traceable qw(); #>>>
our $VERSION = '1.200001'; $VERSION =~ s/_//ms;
#####################################################################
# Constructor
#
# (Technically, the definition of the public attributes, and the
# BUILDARGS routine, as Moose provides our new().)
#
The new method creates a Perl::Dist::WiX object that describes a distribution of perl.
Each object is used to create a single distribution by calling run(), and then should be discarded.
Although there are about 30 potential constructor arguments that can be provided, most of them are automatically resolved and exist for overloading puposes only, or they revert to sensible defaults and generally never need to be modified.
This routine may take a few minutes to run.
An example of the most likely attributes that will be specified is in the SYNOPSIS.
Attributes that are required to be set are marked as (required) below. They may often be set by subclasses.
All attributes below can also be called as accessors on the object created.
The app_id parameter provides the base identifier of the distribution that is used in constructing filenames by default. This must be a legal Perl identifier (no spaces, for example) and is required.
has 'app_id' => ( is => 'ro', # String that passes _IDENTIFIER isa => subtype( Str => where { _IDENTIFIER($_) }, message {'app_id must be a legal Perl identifier'} ), required => 1, );
The app_name parameter provides the name of the distribution. This is required.
has 'app_name' => ( is => 'ro', isa => Str, required => 1, );
The app_publisher parameter provides the publisher of the distribution.
has 'app_publisher' => ( is => 'ro', isa => Str, required => 1, );
The app_publisher_url parameter provides the URL of the publisher of the distribution.
It can be a string or a URI object.
has 'app_publisher_url' => ( is => 'ro', isa => Uri, coerce => 1, required => 1, );
The app_ver_name parameter provides the name and version of the distribution.
This is not required, and is assembled from app_name and perl_version_human if not given.
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(); }
The optional integer beta_number parameter is used to set the beta number portion of the distribution's version number (if this is a beta distribution), and is used in constructing filenames.
It defaults to 0 if not set, which will construct distributions without a beta number.
has 'beta_number' => ( is => 'ro', isa => Int, default => 0, );
The binary_root accessor is the URL (as a string, not including the filename) where the distribution will find its libraries to download.
Defaults to 'http://strawberryperl.com/package' unless offline is set, in which case it defaults to the empty string.
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 { return 'http://strawberryperl.com/package'; } }
The optional bits parameter specifies whether the perl being built is for 32-bit (i386) or 64-bit (referred to as Intel64 / amd-x64) Windows
32-bit (i386) is the default.
has 'bits' => ( is => 'ro', # Integer 32/64 isa => subtype( 'Int' => where { if ( not defined $_ ) { $_ = 32; }
$_ == 32 or $_ == 64; }, message { 'Not 32 or 64-bit'; }, ), default => 32, );
The directory where the source files for the distribution will be extracted and built from.
Defaults to temp_dir . '\build', and must exist if given.
has 'build_dir' => ( is => 'ro', isa => ExistingDirectory_SaneSlashes, coerce => 1, 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; }
The required integer build_number parameter is used to set the build number portion of the distribution's version number, and is used in constructing filenames.
has 'build_number' => ( is => 'ro', isa => subtype( 'Int' => where { $_ < 256 and $_ >= 0 }, message {'Build number must be between 0 and 255'} ), required => 1, );
checkpoint_after is given an arrayref of task numbers. After each task in the list, Perl::Dist::WiX will stop and save a checkpoint.
[ 0 ] is the default, meaning that you do not wish to save a checkpoint anywhere.
has 'checkpoint_after' => ( is => 'ro', isa => ArrayRef [Int], writer => '_set_checkpoint_after', default => sub { return [0] }, );
checkpoint_before is given an integer to know when to load a checkpoint. Unlike the other parameters, this is based on the task number that is GOING to execute, rather than the task number that just executed, so that if a checkpoint was saved after (for example) task 5, this parameter should be 6 in order to load the checkpoint and start on task 6.
0 is the default, meaning that you do not wish to load a checkpoint.
has 'checkpoint_before' => ( is => 'ro', isa => Int, writer => '_set_checkpoint_before', default => 0, );
The directory where Perl::Dist::WiX will store its checkpoints.
Defaults to temp_dir . '\checkpoint', and must exist if given.
has 'checkpoint_dir' => ( is => 'ro', isa => ExistingDirectory, lazy => 1, builder => '_build_checkpoint_dir', );
sub _build_checkpoint_dir { my $self = shift; my $dir = $self->temp_dir()->subdir('checkpoint'); if ( not -d "$dir" ) { $self->remake_path("$dir"); } return $dir; }
checkpoint_stop stops execution after the specified task if no error has happened before then.
0 is the default, meaning that you do not wish to stop unless an error occurs.
has 'checkpoint_stop' => ( is => 'ro', isa => Int, writer => '_set_checkpoint_stop', default => 0, );
The cpan param provides a path to a CPAN or minicpan mirror that the installer can use to fetch any needed files during the build process.
The param should be a URI object to the root of the CPAN repository, including trailing slash. Strings will be coerced to URI objects.
If you are online and no cpan param is provided, the value will default to the http://cpan.strawberryperl.com repository as a convenience.
has 'cpan' => ( is => 'ro', isa => Uri, lazy => 1, coerce => 1, builder => '_build_cpan', );
sub _build_cpan { my $self = shift;
# If we are online and don't have a cpan repository, # use cpan.strawberryperl.com as a default. if ( $self->offline() ) { PDWiX::Parameter->throw( parameter => 'cpan: Required if offline => 1', where => '->new' ); } else { return URI->new('http://cpan.strawberryperl.com/'); }
return; } ## end sub _build_cpan
The optional debug_stderr parameter is used to set the location of the file that STDERR is redirected to when the perl tarball and perl modules are built.
The default location is in debug.err in the output_dir.
has 'debug_stderr' => ( is => 'ro', isa => File, lazy => 1, coerce => 1, default => sub { my $self = shift; return $self->output_dir()->file('debug.err'); }, );
The optional debug_stdout parameter is used to set the location of the file that STDOUT is redirected to when the perl tarball and perl modules are built.
The default location is in debug.out in the output_dir.
has 'debug_stdout' => ( is => 'ro', isa => File, lazy => 1, coerce => 1, default => sub { my $self = shift; return $self->output_dir()->file('debug.out'); }, );
The name for the Start menu group that the distribution's installer installs its shortcuts to. Defaults to app_name if none is provided.
has 'default_group_name' => ( is => 'ro', isa => Str, lazy => 1, default => sub { my $self = shift; return $self->app_name(); }, );
The optional download_dir parameter sets the location of the directory that packages of various types will be downloaded and cached to.
Defaults to temp_dir . '\download', and must exist if given.
has 'download_dir' => ( is => 'ro', isa => ExistingDirectory_Spaceless, coerce => 1, 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; }
The optional boolean exe param is unused at the moment.
has 'exe' => ( is => 'ro', isa => Bool, writer => '_set_exe', default => 0, );
The fileid_perl parameter helps the relocation find the perl executable.
If the merge module is being built, this is set by install_relocatable().
If the merge module is being used, it needs to be passed in to new().
has 'fileid_perl' => ( is => 'ro', isa => Str, writer => '_set_fileid_perl', default => q{}, );
The fileid_relocation_pl parameter helps the relocation find the relocation script.
If the merge module is being built, this is set by install_relocatable().
If the merge module is being used, it needs to be passed in to new().
has 'fileid_relocation_pl' => ( is => 'ro', isa => Str, writer => '_set_fileid_relocation_pl', default => q{}, );
The force parameter determines if perl and perl modules are tested upon installation. If this parameter is true, then no testing is done.
has 'force' => ( is => 'ro', isa => Bool, default => 0, );
The force parameter determines if perl and perl modules are tested upon installation. If this parameter is true, then testing is done only upon installed modules, not upon perl itself.
has 'forceperl' => ( is => 'ro', isa => Bool, default => 0, );
The subdirectory of temp_dir where the .wxs fragment files for the different portions of the distribution will be created.
Defaults to temp_dir . '\fragments', and needs to exist if given.
has 'fragment_dir' => ( is => 'ro', isa => ExistingDirectory_SaneSlashes, lazy => 1, coerce => 1, builder => '_build_fragment_dir', );
sub _build_fragment_dir { my $self = shift;
my $dir = catdir( $self->temp_dir(), 'fragments' ); $self->remake_path($dir); return Path::Class::Dir->new($dir); }
The optional gcc_version parameter specifies whether perl is being built using gcc 3.4.5 from the mingw32 project (by specifying a value of '3'), or using gcc 4.4.3 from the mingw64 project (by specifying a value of '4').
'3' (gcc 3.4.5) is the default, and is incompatible with bits => 64. '4' is compatible with both 32 and 64-bit.
has 'gcc_version' => ( is => 'ro', isa => subtype( 'Int' => where { $_ == 3 or $_ == 4 }, message {'Not 3 or 4'} ), default => 3, );
The git_checkout parameter is not used unless you specify that perl_version is 'git'. In that event, this parameter should contain a string pointing to the location of a checkout from http://perl5.git.perl.org/.
The default is 'C:\perl-git', if it exists.
has 'git_checkout' => ( is => 'ro', isa => Undef | ExistingDirectory_Spaceless, builder => '_build_git_checkout', coerce => 1, );
sub _build_git_checkout { my $dir = q{C:\\perl-git};
if ( -d $dir ) { return Path::Class::Dir->new($dir); } else { ## no critic (ProhibitExplicitReturnUndef) return undef; } }
The git_location parameter is not used unless you specify that perl_version is 'git'. In that event, this parameter should contain a string pointing to the location of the git.exe binary, as because a perl.exe file is in the same directory, it gets removed from the PATH during the execution of programs from Perl::Dist::WiX.
The default is 'C:\Program Files\Git\bin\git.exe', if it exists. Otherwise, the default is undef.
People on x64 systems should set this to 'C:\Program Files (x86)\Git\bin\git.exe' unless MSysGit is installed in a different location (or a 64-bit version becomes available).
This will be converted to a short name before execution, so this must NOT be on a partition that does not have them, unless the location does not have spaces.
has 'git_location' => ( is => 'ro', isa => Undef | ExistingFile, builder => '_build_git_location', coerce => 1, );
sub _build_git_location { my $file = 'C:\Program Files\Git\bin\git.exe';
if ( -f $file ) { return $file; } else { ## no critic (ProhibitExplicitReturnUndef) return undef; } }
Perl::Dist::WiX distributions can only be installed to fixed paths as of yet.
To facilitate a correctly working CPAN setup, the files that will ultimately end up in the installer must also be assembled under the same path on the author's machine.
The image_dir method specifies the location of the Perl install, both on the author's and end-user's host.
Please note that this directory will be automatically deleted if it already exists at object creation time. Trying to build a Perl distribution on the SAME distribution can thus have devastating results, and an attempt is made to prevent this from happening.
has 'image_dir' => ( is => 'ro', isa => ExistingSubdirectory, coerce => 1, required => 1, );
The subdirectory of image_dir where the licenses for the different portions of the distribution will be copied to.
Defaults to image_dir . '\licenses', and needs to exist if given.
has 'license_dir' => ( is => 'ro', isa => ExistingDirectory_Spaceless, lazy => 1, coerce => 1, builder => '_build_license_dir', );
sub _build_license_dir { my $self = shift;
my $dir = $self->image_dir()->subdir('licenses'); $self->remake_path("$dir"); return $dir; }
The optional modules_dir parameter sets the location of the directory that perl modules will be downloaded and cached to.
Defaults to download_dir . '\modules', and must exist if given.
has 'modules_dir' => ( is => 'ro', isa => ExistingDirectory_Spaceless, lazy => 1, builder => '_build_modules_dir', );
sub _build_modules_dir { my $self = shift;
my $dir = $self->download_dir()->subdir('modules'); $self->remake_path("$dir"); return $dir; }
The optional boolean msi param is used to indicate that a Windows Installer distribution package (otherwise known as an msi file) should be created.
has 'msi' => ( is => 'ro', isa => Bool, writer => '_set_msi', default => sub { my $self = shift; return $self->portable() ? 0 : 1; }, );
The optional msi_banner_side parameter specifies the location of a 493x312 .bmp file that is used in the introductory dialog in the MSI file.
WiX will use its default if no file is supplied here.
has 'msi_banner_side' => ( is => 'ro', isa => Undef | ExistingFile, coerce => 1, default => undef, );
The optional msi_banner_top parameter specifies the location of a 493x58 .bmp file that is used on the top of most of the dialogs in the MSI file.
WiX will use its default if no file is supplied here.
has 'msi_banner_top' => ( is => 'ro', isa => Undef | ExistingFile, coerce => 1, default => undef, );
The optional boolean msi_debug parameter is used to indicate that a debugging MSI (one that creates a log in $ENV{TEMP} upon execution in Windows Installer 4.0 or above) will be created if msi is also true.
has 'msi_debug' => ( is => 'ro', isa => Bool, default => 0, );
The optional msi_help_url parameter specifies the URL that Add/Remove Programs directs you to for support when you click the "Click here for support information." text.
has 'msi_help_url' => ( is => 'ro', isa => Uri | Undef , # Maybe[ Uri ] will not work. Unions inherit coercions, parameterized types don't. coerce => 1, default => undef, );
The optional msi_license_file parameter specifies the location of an .rtf or .txt file to be displayed at the point where the MSI asks you to accept a license.
Perl::Dist::WiX provides a default one if none is supplied here.
has 'msi_license_file' => ( is => 'ro', isa => ExistingFile, lazy => 1, coerce => 1, default => sub { my $self = shift; return catfile( $self->wix_dist_dir(), 'License.rtf' ); }, );
The optional msi_product_icon parameter specifies the icon that is used in Add/Remove Programs for this MSI file.
has 'msi_product_icon' => ( is => 'ro', isa => Undef | ExistingFile, coerce => 1, default => undef, );
The optional msi_readme_file parameter specifies a .txt or .rtf file or a URL (TODO: check) that is linked in Add/Remove Programs in the "Click here for support information." text.
has 'msi_readme_file' => ( is => 'ro', isa => Undef | ExistingFile, coerce => 1, default => undef, );
The optional boolean msm param is used to indicate that a Windows Installer merge module (otherwise known as an msm file) should be created.
has 'msm' => ( is => 'ro', isa => Bool, default => 1, );
Subclasses can start building a perl distribution from a merge module, instead of having to build perl from scratch.
This means that the distribution can:
1) update the version of Perl installed using the merge module.
2) be installed on top of another distribution using that merge module (or an earlier version of it).
The next 3 options specify the information required to use a merge module.
The optional msm_code param is used to specify the product code for the merge module referred to in msm_to_use.
msm_to_use, msm_zip, and this parameter must either be all unset, or all set. They must be all set if initialize_using_msm is in the tasklist.
has 'msm_code' => ( is => 'ro', isa => Maybe [Str], default => undef, );
The optional msm_to_use ...
It can be specified as a string, a Path::Class::File object, or a URI object.
has 'msm_to_use' => ( is => 'ro', isa => Uri | Undef, default => undef, coerce => 1, );
The optional msm_zip refers to where the .zip version of Strawberry Perl that matches the merge module specified in msm_to_use
It can be a file:// URL if it's already downloaded.
It can be specified as a string, a Path::Class::File object, or a URI object.
has 'msm_zip' => ( is => 'ro', isa => Uri | Undef, default => undef, coerce => 1, );
The Perl::Dist::WiX module has limited ability to build offline, if all packages have already been downloaded and cached.
The connectedness of the Perl::Dist object is checked automatically be default using LWP::Online. It can be overidden by providing the offline parameter to new().
The offline accessor returns true if no connection to "the internet" is available and the object will run in offline mode, or false otherwise.
has 'offline' => ( is => 'ro', isa => Bool, default => sub { return !!LWP::Online::offline() }, );
The optional output_base_filename parameter specifies the filename (without extensions) that is used for the installer(s) being generated.
The default is based on app_id, perl_version, bits, and the current date.
has 'output_base_filename' => ( is => 'ro', isa => Str, lazy => 1, builder => '_build_output_base_filename', );
# Default the output filename to the id plus the current date 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(); }
This is the location where the compiled installers and other files necessary to the build are written.
Defaults to temp_dir . '\output', and must exist when given.
has 'output_dir' => ( is => 'ro', isa => ExistingDirectory_SaneSlashes, lazy => 1, coerce => 1, builder => '_build_output_dir', );
sub _build_output_dir { my $self = shift;
my $dir = $self->temp_dir()->subdir('output'); $self->make_path("$dir"); return $dir; }
The optional perl_config_cf_email parameter specifies the e-mail of the person building the perl distribution defined by this object.
It is compiled into the perl binary as the cf_email option accessible through perl -V:cf_email.
The username (the part before the at sign) of this parameter also sets the cf_by option.
If not defined, this is set to anonymous@unknown.builder.invalid.
has 'perl_config_cf_email' => ( is => 'ro', # E-mail address isa => subtype( Str => where { $_ =~ m/\A.*@.*\z/msx }, message { 'perl_config_cf_email must be in the form of an e-mail address'; } ), default => 'anonymous@unknown.builder.invalid', );
The optional perl_config_cf_email parameter specifies the username part of the e-mail address of the person building the perl distribution defined by this object.
It is compiled into the perl binary as the cf_by option accessible through perl -V:cf_by.
If not defined, this is set to the username part of perl_config_cf_email.
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; }
The optional boolean perl_debug parameter is used to indicate that a debugging perl interpreter will be created.
This only applies to 5.11.5 as of yet.
has 'perl_debug' => ( is => 'ro', isa => Bool, default => 0, );
The perl_version parameter specifies what version of perl is downloaded and built. Legal values for this parameter are 'git', '589', '5100', '5101', and '5120' (for a version from perl5.git.perl.org, 5.8.9, 5.10.0, 5.10.1, and 5.12.0, respectively.)
This parameter defaults to '5101' if not specified.
has 'perl_version' => ( is => 'ro', isa => enum( [qw(git 589 5100 5101 5120)] ), default => '5101', );
The optional portable parameter is used to determine whether a portable 'Perl-on-a-stick' distribution - one that is intended for distribution on a portable storage device - is built with this object.
If set to a true value, zip must also be set to a true value, and msi will be set to a false value.
This defaults to a false value.
has 'portable' => ( is => 'ro', isa => Bool, default => 0, );
The optional relocatable parameter is used to determine whether the distribution is meant to be relocatable.
This defaults to a false value.
has 'relocatable' => ( is => 'ro', isa => Bool, default => 0, );
The optional sitename parameter is used to generate the GUID's necessary during the process of building the distribution.
This defaults to the host part of app_publisher_url.
has 'sitename' => ( is => 'ro', # Hostname isa => Str, required => 1, # Default is provided in BUILDARGS. );
The optional tasklist parameter specifies the list of routines that the object can do. The routines are object methods of Perl::Dist::WiX (or its subclasses) that will be executed in order, and their task numbers (as used below) will begin with 1 and increment in sequence.
Task routines should either return 1, or throw an exception.
The default task list for Perl::Dist::WiX is as shown below. Subclasses should provide their own list and insert their tasks in this list, rather than overriding routines shown above.
has 'tasklist' => ( is => 'ro', isa => ArrayRef [Str], builder => '_build_tasklist', );
sub _build_tasklist { return [
# Final initialization 'final_initialization',
# Install the core C toolchain 'install_c_toolchain',
# Install the Perl binary 'install_perl',
# Install the Perl toolchain 'install_perl_toolchain',
# Install additional Perl modules 'install_cpan_upgrades',
# Apply optional portability support 'install_portable',
# Apply optional relocation support 'install_relocatable',
# Remove waste and temporary files 'remove_waste',
# Regenerate file fragments 'regenerate_fragments',
# Find file ID's for relocation. 'find_relocatable_fields',
# Write out the merge module 'write_merge_module',
# Install the Win32 extras 'install_win32_extras',
# Create the distribution list 'create_distribution_list',
# Regenerate file fragments again. 'regenerate_fragments',
# Write out the distributions 'write', ]; } ## end sub _build_tasklist
Perl::Dist::WiX needs a series of temporary directories while it is running the build, including places to cache downloaded files, somewhere to expand tarballs to build things, and somewhere to put debugging output and the final installer zip and msi files.
The temp_dir param specifies the root path for where these temporary directories should be created.
For convenience it is best to make these short paths with simple names, near the root.
This parameter defaults to a subdirectory of $ENV{TEMP} if not specified.
has 'temp_dir' => ( is => 'ro', isa => ExistingDirectory_SaneSlashes, coerce => 1, default => sub { return Path::Class::Dir->new( catdir( tmpdir(), 'perldist' ) ) } , );
The processes that Perl::Dist::WiX executes sometimes need a place to put their temporary files, usually in $ENV{TEMP}.
In order to avoid leaving detritus behind in that directory, that environment variable is redirected early, to this directory.
This parameter defaults to a subdirectory of temp_dir() if not specified.
has 'tempenv_dir' => ( is => 'ro', isa => ExistingDirectory_SaneSlashes, lazy => 1, coerce => 1, builder => '_build_tempenv_dir', );
sub _build_tempenv_dir { my $self = shift;
my $dir = $self->temp_dir()->subdir('tempenv'); $self->remake_path("$dir"); return $dir; }
The trace parameter sets the level of tracing that is output.
Setting this parameter to 0 prints out only MAJOR stuff and errors.
Setting this parameter to 2 or above will print out the level as the first thing on the line, and when an error occurs and an exception object is printed, a stack trace will be printed as well.
Setting this parameter to 3 or above will print out the filename and line number after the trace level on those lines that require a trace level of 3 or above to print.
Setting this parameter to 5 or above will print out the filename and line number on every line.
Default is 1 if not set.
has 'trace' => ( is => 'ro', isa => Int, default => 1, );
The optional use_dll_relocation parameter specifies whether to use the C++ relocation dll that's being tested for relocating perl, or to call a Perl relocation script from the .msi's.
This parameter has no effect is the msi parameter is false, or if the relocatable parameter is false.
The default is false, so as to use the Perl relocation script instead.
has 'use_dll_relocation' => ( is => 'ro', isa => Bool, default => 0, );
The user_agent parameter stores the LWP::UserAgent object (or an object of a subclass of LWP::UserAgent) that Perl::Dist::WiX uses to download files.
The default depends on the user_agent_cache parameter.
has 'user_agent' => ( is => 'ro', isa => class_type( 'LWP::UserAgent', { message => sub {'Invalid user_agent'} } ), lazy => 1, writer => '_set_user_agent', builder => '_build_user_agent', clearer => '_clear_user_agent', );
sub _build_user_agent { my $self = shift; my $ua;
if ( $self->user_agent_cache() ) { SCOPE: {
# Temporarily set $ENV{HOME} to the File::HomeDir # version while loading the module. local $ENV{HOME} ||= File::HomeDir->my_home; require LWP::UserAgent::WithCache; } $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; } ## end sub _build_user_agent
The boolean user_agent_cache parameter specifies whether the default user_cache object is a LWP::UserAgent::WithCache (true) or a LWP::UserAgent object (false).
Defaults to a true value if not specified.
has 'user_agent_cache' => ( is => 'ro', isa => Bool, default => 1, );
The optional boolean zip param is used to indicate that a zip distribution package should be created.
has 'zip' => ( is => 'ro', isa => Bool, lazy => 1, default => sub { my $self = shift; return $self->portable() ? 1 : 0; }, );
sub BUILDARGS { ## no critic (ProhibitExcessComplexity) my $class = shift; my %params;
if ( @_ == 1 && 'HASH' eq ref $_[0] ) { %params = %{ $_[0] }; } elsif ( 0 == @_ % 2 ) { %params = (@_); } else { PDWiX::ParametersNotHash->throw( where => '->new()' ); }
## no critic(ProtectPrivateSubs RequireCarping RequireUseOfExceptions) 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';
# Announce that we're starting. { my $time = scalar localtime; $params{_trace_object} ->trace_line( 0, "Starting build at $time.\n" ); }
# Get the parameters required for the GUID generator set up. unless ( _STRING( $params{app_publisher_url} ) or _INSTANCE( $params{app_publisher_url}, 'URI' ) ) { PDWiX::Parameter->throw( parameter => 'app_publisher_url', where => '::Installer->new' ); }
# Convert a string to a URI object. if ( _STRING( $params{app_publisher_url} ) ) { $params{app_publisher_url} = URI->new( $params{app_publisher_url} ); }
# Default the sitename unless it is given. unless ( _STRING( $params{sitename} ) ) { $params{sitename} = $params{app_publisher_url}->host(); }
# Create the GUID generator. $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 );
# We don't want to delete a previous one yet. $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' ); }
return \%params; } ## end sub BUILDARGS
# This is called by Moose's DESTROY, and handles moving the CPAN source # files back. 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; } ## end sub DEMOLISH
################################################################
#
# Private attributes. (Ones that have no public accessors or
# are not valid parameters for new().)
#
# Reserved for a future parameter to new() has 'msi_feature_tree' => ( is => 'ro', isa => Undef, default => undef, init_arg => 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, # Cannot set this parameter in new(). );
has '_directories' => ( is => 'bare', isa => 'Maybe[Perl::Dist::WiX::DirectoryTree2]', writer => '_set_directories', reader => 'get_directory_tree', clearer => '_clear_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;
# Initialize filters. #<<< 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 } ), ]; #>>> } ## end sub _build_filters
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;
# Find the core list 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; } ## end sub _build_perl_version_corelist
has 'pdw_version' => ( is => 'ro', isa => Str, default => $Perl::Dist::WiX::VERSION, init_arg => undef, # Cannot set this parameter in new(). );
has '_guidgen' => ( is => 'ro', isa => 'WiX3::XML::GeneratesGUID::Object', required => 1, # Default is provided in BUILDARGS. writer => '_set_guidgen', clearer => '_clear_guidgen', );
has '_trace_object' => ( is => 'ro', isa => 'WiX3::Traceable', required => 1, writer => '_set_trace_object', clearer => '_clear_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;
# Create a legal path out of the object's class name under # {Application Data}/Perl. my $path = ref $self; $path =~ s{::}{-}gmsx; # Changes all :: to -. my $dir = File::Spec->catdir( File::HomeDir->my_data(), 'Perl', $path, );
# Make the directory or die vividly. unless ( -d $dir ) { unless ( File::Path::mkpath( $dir, { verbose => 0 } ) ) { PDWiX::Directory->throw( dir => $dir, message => 'Failed to create' ); } } unless ( -w $dir ) { PDWiX::Directory->throw( dir => $dir, message => 'No write permissions for LWP::UserAgent cache' ); } return $dir; } ## end sub _build_user_agent_directory
has '_cpan_moved' => ( traits => ['Bool'], is => 'bare', isa => Bool, reader => '_has_moved_cpan', default => 0, init_arg => undef, # Cannot set this parameter in new(). handles => { '_move_cpan' => 'set', }, );
has '_cpan_sources_to' => ( is => 'ro', isa => Str, writer => '_set_cpan_sources_to', default => undef, init_arg => undef, # Cannot set this parameter in new(). );
has '_cpan_sources_from' => ( is => 'ro', isa => Str, writer => '_set_cpan_sources_from', default => undef, init_arg => undef, # Cannot set this parameter in new(). );
has '_portable_dist' => ( is => 'ro', # String isa => 'Maybe[Portable::Dist]', writer => '_set_portable_dist', default => undef, init_arg => undef, # Cannot set this parameter in new(). );
$id = $dist->bin_candle(); Accessors will return a specified portion of the distribution state.
If it can also be set as a parameter to new, it is marked as (also new parameter) below.
The location where this object will write the information for WiX to process to create the MSI. A default is provided if this is not specified.
Returns the Perl::Dist::WiX::DirectoryTree object associated with this distribution. Created by "new"
Returns a hashref containing the objects subclassed from Perl::Dist::WiX::Base::Fragment associated with this distribution. Created as the distribution's "run" routine progresses.
Returns the parameter of the same name passed in from "new". Unused as of yet.
Specifies the Id for the icon that is used in Add/Remove Programs for this MSI file.
Returns the Perl::Dist::WiX::FeatureTree object associated with this distribution.
has 'feature_tree_object' => ( is => 'ro', # String isa => 'Maybe[Perl::Dist::WiX::FeatureTree2]', writer => '_set_feature_tree_object', default => undef, init_arg => undef, );
The location of perl.exe, dmake.exe, pexports.exe, and dlltool.exe.
These only are available (not undef) once the appropriate packages are installed.
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, );
Provides a shortcut to the location of the shared files directory.
Returns a directory as a string or throws an exception on error.
sub dist_dir { my $self = shift;
return $self->wix_dist_dir(); }
Provides a shortcut to the location of the shared files directory for Perl::Dist::WiX.
Returns a directory as a string or throws an exception on error.
has 'wix_dist_dir' => ( is => 'ro', isa => ExistingDirectory_Spaceless, builder => '_build_wix_dist_dir', init_arg => undef, coerce => 1, );
sub _build_wix_dist_dir { my $dir;
unless ( eval { $dir = Path::Class::Dir->new( 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', ); } ## end unless ( eval { $dir = Path::Class::Dir...})
return $dir; } ## end sub _build_wix_dist_dir
Used in the templates for documentation purposes.
sub pdw_class { my $self = shift;
return ref $self; }
The git_describe method returns the output of git describe on the directory pointed to by git_checkout.
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::File->throw( message => 'Could not find git', file => $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' ); }
## no critic(ProhibitBacktickOperators) $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; } ## end sub _build_git_describe
The perl_version_literal method returns the literal numeric Perl version for the distribution.
For Perl 5.8.9 this will be '5.008009', Perl 5.10.0 will be '5.010000', and for Perl 5.10.1 this will be '5.010001'.
has 'perl_version_literal' => ( is => 'ro', # String 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', '5120' => '5.012000', 'git' => '5.013000', }->{ $self->perl_version() } || 0;
unless ($x) { PDWiX::Parameter->throw( parameter => 'perl_version_literal: Failed to resolve', where => '->(building of accessor)' ); }
return $x; } ## end sub _build_perl_version_literal
The perl_version_human method returns the "marketing" form of the Perl version.
This will be either 'git', '5.8.9', '5.10.0', or '5.10.1'.
has 'perl_version_human' => ( is => 'ro', # String 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', '5120' => '5.12.0', 'git' => 'git', }->{ $self->perl_version() } || 0;
unless ($x) { PDWiX::Parameter->throw( parameter => 'perl_version_human: Failed to resolve', where => '->(building of accessor)' ); }
return $x; } ## end sub _build_perl_version_human
The distribution_version_human method returns the "marketing" form of the distribution version.
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{} ); } ## end sub distribution_version_human
The distribution_version_file method returns the "marketing" form of the distribution version, in such a way that it can be used in a file name.
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{} ); } ## end sub distribution_version_file
Returns a stringified date in YYYYMMDD format for the use of other routines.
# Convenience method sub output_date_string { my @t = localtime; return sprintf '%04d%02d%02d', $t[5] + 1900, $t[4] + 1, $t[3]; }
Returns the UI type that the MSI needs to use.
# For template sub msi_ui_type { my $self = shift;
if ( defined $self->msi_feature_tree() ) { return 'FeatureTree'; } elsif ( $self->relocatable() ) { return 'MyInstallDir'; } else { return 'Minimal'; } }
Returns the Platform attribute to the MSI's Package tag.
See http://wix.sourceforge.net/manual-wix3/wix_xsd_package.htm
# For template sub msi_platform_string { my $self = shift; return ( 64 == $self->bits() ) ? 'x64' : 'x86'; }
Returns the product icon to use in the main template.
sub msi_product_icon_id { my $self = shift;
# Get the icon ID if we can. if ( defined $self->msi_product_icon() ) { return 'I_' . $self->_icons() ->search_icon( $self->msi_product_icon()->stringify() ); } else { ## no critic (ProhibitExplicitReturnUndef) return undef; } } ## end sub msi_product_icon_id
Returns the Id for the MSI's <Product> tag.
See http://wix.sourceforge.net/manual-wix3/wix_xsd_product.htm
# For template 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();
#... then use it to create a GUID out of the ID. my $guid = $generator->generate_guid($product_name);
return $guid; } ## end sub msi_product_id
Returns the Id for the <Product> tag for the MSI's merge module.
See http://wix.sourceforge.net/manual-wix3/wix_xsd_product.htm
# For template 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.};
#... then use it to create a GUID out of the ID. my $guid = $generator->generate_guid($product_name); $guid =~ s/-/_/msg;
return $guid; } ## end sub msm_product_id
Returns the Id for the MSI's <Upgrade> tag.
See http://wix.sourceforge.net/manual-wix3/wix_xsd_upgrade.htm
# For template 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();
#... then use it to create a GUID out of the ID. my $guid = $generator->generate_guid($upgrade_ver);
return $guid; } ## end sub msi_upgrade_code
Returns the Id for the MSM's <Package> tag.
See http://wix.sourceforge.net/manual-wix3/wix_xsd_package.htm
# For template sub msm_package_id { my $self = shift;
# Handles including a merge module correctly. 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.};
#... then use it to create a GUID out of the ID. my $guid = $generator->generate_guid($upgrade_ver);
return $guid; } ## end sub msm_package_id
Returns the Id for the MSM's <Package> tag, as the merge module would append it.
This is used in the main .wxs file.
# For template. sub msm_package_id_property { my $self = shift;
my $guid = $self->msm_package_id(); $guid =~ s/-/_/msg;
return $guid; }
Returns the Id passed in as msm_code, as the merge module would append it.
This is used in the main .wxs file for subclasses.
# For template. sub msm_code_property { my $self = shift;
my $guid = $self->msm_code(); $guid =~ s/-/_/msg;
return $guid; }
Returns the Version attribute for the MSI's <Product> tag.
See http://wix.sourceforge.net/manual-wix3/wix_xsd_product.htm
# For template. # MSI versions are 3 part, not 4, with the maximum version being 255.255.65535 sub msi_perl_version { my $self = shift;
# Get perl version arrayref. my $ver = { '589' => [ 5, 8, 9 ], '5100' => [ 5, 10, 0 ], '5101' => [ 5, 10, 1 ], '5120' => [ 5, 12, 0 ], 'git' => [ 5, 0, 0 ], }->{ $self->perl_version() } || [ 0, 0, 0 ];
# Merge build number with last part of perl version. $ver->[2] = ( $ver->[2] << 8 ) + $self->build_number();
return join q{.}, @{$ver};
} ## end sub msi_perl_version
Returns the major perl version so that upgrades that jump delete the site directory.
# For template. # MSI versions are 3 part, not 4, with the maximum version being 255.255.65535 sub msi_perl_major_version { my $self = shift;
# Get perl version arrayref. my $ver = { '589' => [ 5, 8, 0 ], '5100' => [ 5, 9, 127 ], '5101' => [ 5, 10, 0 ], '5120' => [ 5, 11, 127 ], 'git' => [ 5, 12, 127 ], # 'git' should now be 5.13.0 }->{ $self->perl_version() } || [ 0, 0, 0 ];
# Shift the third portion over to match msi_perl_version. $ver->[2] <<= 8; $ver->[2] += 255;
# Correct to the build number (minus 1 so as not to duplicate) for git if ( 'git' eq $self->perl_version() ) { $ver->[2] = $self->build_number() - 1; }
return join q{.}, @{$ver};
} ## end sub msi_perl_major_version
Returns a command line to use in Main.wxs.tt for relocation purposes.
# For template. sub msi_relocation_commandline { my $self = shift;
my $answer; my %files = $self->msi_relocation_commandline_files();
my ( $fragment, $file, $id ); while ( ( $fragment, $file ) = each %files ) { $id = $self->get_fragment_object($fragment)->find_file_id($file); PDWiX->throw("Could not find file $file in fragment $fragment\n") if not defined $id; $answer .= " --file [#$id]"; }
return $answer; } ## end sub msi_relocation_commandline
Returns a command line to use in Merge-Module.wxs.tt for relocation purposes.
# For template. sub msm_relocation_commandline { my $self = shift;
my $answer; my %files = $self->msm_relocation_commandline_files();
my ( $fragment, $file, $id ); while ( ( $fragment, $file ) = each %files ) { $id = $self->get_fragment_object($fragment)->find_file_id($file); PDWiX->throw("Could not find file $file in fragment $fragment\n") if not defined $id; $answer .= " --file [#$id]"; }
return $answer; } ## end sub msm_relocation_commandline
Returns the files to use in Main.wxs.tt for relocation purposes.
This is overridden in subclasses, and creates an exception if not overridden.
# For template. sub msi_relocation_commandline_files { my $self = shift;
PDWiX::Unimplemented->throw();
return; }
Returns the files to use in Merge-Module.wxs.tt for relocation purposes.
This is overridden in subclasses, and creates an exception if not overridden.
# For template. sub msm_relocation_commandline_files { my $self = shift;
PDWiX::Unimplemented->throw();
return; }
Returns which CA to use in Main.wxs.tt and Merge-Module.wxs.tt for relocation purposes.
sub msi_relocation_ca { my $self = shift;
return ( 64 == $self->bits() ) ? 'CAQuietExec64' : 'CAQuietExec'; }
Returns the value to be used for perl -V:myuname, which is in this pattern:
Win32 app_id 5.10.0.1.beta_1 #1 Mon Jun 15 23:11:00 2009 i386
(the .beta_X is omitted if the beta_number accessor is not set.)
# For template. 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;
} ## end sub perl_config_myuname
Returns the array of <Component Id>'s required.
See http://wix.sourceforge.net/manual-wix3/wix_xsd_component.htm, http://wix.sourceforge.net/manual-wix3/wix_xsd_componentref.htm
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; } ## end sub get_component_array
Used in the makefile.mk template for 5.11.5+ to activate building a debugging perl.
sub mk_debug { my $self = shift;
return ( $self->perl_debug() ) ? 'CFG' : '#CFG'; }
Used in the makefile.mk template for 5.11.5+ to activate building with gcc4.
sub mk_gcc4 { my $self = shift;
return ( 4 == $self->gcc_version() ) ? 'GCC_4XX' : '#GCC_4XX'; }
Used in the makefile.mk template for 5.11.5+ to activate building 64 or 32-bit versions. (Actually, this turns off the fact that we're building a 64-bit version of perl when we want a 32-bit version on 64-bit processors)
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'; } ## end sub mk_bits
Used in the makefile.mk template for 5.11.5+ to activate using the correct helper dll for our gcc4 packs.
sub mk_gcc4_dll { my $self = shift;
return ( 4 == $self->gcc_version() ) ? 'GCCHELPERDLL' : '#GCCHELPERDLL'; }
Used in the makefile.mk template for 5.11.5+ to activate using the correct extra library directory for our gcc4 packs.
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) ); }
my $bool = $dist->fragment_exists('FragmentId');
Returns whether the fragment with the name given has been attached to this distribution.
my $fragment_tag = $dist->get_fragment_object('FragmentId');Returns the WiX3::XML::Role::Fragment-using object that is attached to this distribution with the given name.
Returns undef if no such object found.
has '_fragments' => ( traits => ['Hash'], is => 'ro', isa => 'HashRef[WiX3::XML::Role::Fragment]' , # Needs to be Perl::Dist::WiX::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', }, );
#####################################################################
# Top Level Process Methods
sub prepare { return 1 }
The run method is the main method for the class.
It does a complete build of a product, spitting out an installer, by running each method named in the tasklist in order.
Returns true, or throws an exception on error.
This method may take an hour or more to run.
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; }
# Don't buffer 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++; }
# Finished $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; } ## end sub run
#####################################################################
#
# Perl::Dist::WiX Main Methods
# (Those referred to in the tasklist.)
#
run my $dist = Perl::Dist::WiX->new(
tasklist => [
'final_initialization',
...
],
...
);These methods are used in the tasklist, along with other methods that are defined by Perl::Dist::WiX or its subclasses.
The final_initialization routine does the initialization that is required after the object representing a distribution has been created, but before files can be installed.
sub final_initialization { my $self = shift;
# Check for architectures that we can't build 64-bit on. if ( 64 == $self->bits() ) { $self->_check_64_bit(); }
# Redirect $ENV{TEMP} to within our build directory. $self->trace_line( 1, "Emptying the directory to redirect \$ENV{TEMP} to...\n" ); $self->remake_path( $self->tempenv_dir() ); ## no critic (RequireLocalizedPunctuationVars) $ENV{TEMP} = $self->tempenv_dir(); $self->trace_line( 5, 'Emptied: ' . $self->tempenv_dir() . "\n" );
# If we have a file:// url for the CPAN, move the # sources directory out of the way. if ( $self->cpan()->as_string() =~ m{\Afile://}mxsi ) { require CPAN; 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(); } ## end if ( $self->cpan()->as_string...)
# Do some sanity checks. 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' ); }
# Handle portable special cases 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'); } }
# Making sure that this is set. $self->_set_in_merge_module(1);
## no critic(ProtectPrivateSubs) # Set up element collections $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 ) );
# Create an environment fragment. $self->_add_fragment( 'Environment', Perl::Dist::WiX::Fragment::Environment->new() );
# Add directories that need created. $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( 'CreatePerlSiteLib', Perl::Dist::WiX::Fragment::CreateFolder->new( directory_id => 'PerlSiteLib', id => 'PerlSiteLibFolder', ) ); $self->_add_fragment( 'CreateCpanplus', Perl::Dist::WiX::Fragment::CreateFolder->new( directory_id => 'Cpanplus', id => 'CPANPLUSFolder', ) ) if ( '589' ne $self->perl_version() );
# Make some directories. 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); }
# Empty directories that need emptied. $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() );
# Add environment variables. $self->add_env( 'TERM', 'dumb' ); $self->add_env( 'FTP_PASSIVE', '1' );
return 1; } ## end sub final_initialization
sub _check_64_bit { my $self = shift;
# Make the environment variable checks shorter. my $arch = lc( $ENV{'PROCESSOR_ARCHITECTURE'} or 'x86' ); my $archw6432 = lc( $ENV{'PROCESSOR_ARCHITEW6432'} or 'x86' );
# Check for Itanium architecture. if ( ( 'ix86' eq $arch ) or ( 'ix86' eq $archw6432 ) ) { PDWiX->throw( 'We do not support building 64-bit Perl' . ' on Itanium architectures.' ); }
# Check for x86 architecture. if ( ( 'x86' eq $arch ) and ( 'x86' eq $archw6432 ) ) { PDWiX->throw( 'We do not support building 64-bit Perl' . ' on 32-bit machines.' ); }
return; } ## end sub _check_64_bit
The initialize_nomsm routine does the initialization that is required after final_initialization has been called, but before files can be installed if msm is 0.
sub initialize_nomsm { my $self = shift;
# Making sure that this is unset. $self->_set_in_merge_module(0);
# Add fragments that otherwise would be after the merge module is done. $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; } ## end sub initialize_nomsm
The initialize_using_msm routine does the initialization that is required after final_initialization has been called, but before files can be installed if a merge module is to be used.
(see "Using a merge module" for more information.)
sub initialize_using_msm { my $self = shift;
# Making sure that this is unset. $self->_set_in_merge_module(0);
# Download and extract the image. my $tgz = $self->mirror_url( $self->msm_zip(), $self->download_dir() ); $self->_extract( $tgz, $self->image_dir() );
# Start adding the fragments that are only for an .msi. $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() ); }
# Download the merge module. my $msm = $self->mirror_url( $self->msm_to_use(), $self->download_dir() );
# Connect the Merge Module tag. 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 );
# Set the file paths that the first portion of the build otherwise would. $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/) );
# Do the same for the environment variables $self->add_path( 'c', 'bin' ); $self->add_path( 'perl', 'site', 'bin' ); $self->add_path( 'perl', 'bin' );
return 1; } ## end sub initialize_using_msm
The install_c_toolchain method is used by run to install various binary packages to provide a working C development environment.
By default, the C toolchain consists of dmake, gcc (C/C++), binutils, pexports, the mingw runtime environment, and the win32api C package.
Although dmake is the "standard" make for Perl::Dist distributions, it will also install the mingw version of GNU make for use with those modules that require it.
# Install the required toolchain elements. # We use separate methods for each tool to make # it easier for individual distributions to customize # the versions of tools they incorporate. sub install_c_toolchain { my $self = shift;
# The primary make $self->install_dmake;
# Core compiler and support libraries. $self->install_gcc_toolchain;
# C Utilities $self->install_mingw_make; $self->install_pexports;
# Set up the environment variables for the binaries $self->add_path( 'c', 'bin' );
return 1; } ## end sub install_c_toolchain
The install_portable method is used by run to install the perl modules to make Perl installable on a portable device.
# Portability support must be added after modules sub install_portable { my $self = shift;
return 1 unless $self->portable();
# Install the regular parts of Portability $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');
# Create the portability object $self->trace_line( 1, "Creating Portable::Dist\n" ); require Portable::Dist; $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" );
# Install the file that turns on Portability last $self->install_file( share => 'Perl-Dist-WiX portable\portable.perl', install_to => 'portable.perl', );
# Install files to help use Strawberry Portable. $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; } ## end sub install_portable
The install_relocatable method is used by run to install the perl script to make Perl relocatable when installed.
This routine must be run before "regenerate_fragments", so that the fragment created in this method is regenerated and the file ID can be found by "find_relocatable_fields" later.
# Relocatability support must be added before writing the merge module sub install_relocatable { my $self = shift;
return 1 unless $self->relocatable();
# Copy the relocation information in. $self->copy_file( catfile( $self->wix_dist_dir(), 'relocation.pl' ), $self->image_dir() );
# Make sure it gets installed. $self->insert_fragment( 'relocation_script', File::List::Object->new()->add_file( $self->file('relocation.pl') ), );
return 1; } ## end sub install_relocatable
The find_relocatable_fields method is used by run to find the property ID's required to make Perl relocatable when installed.
This routine must be run after "regenerate_fragments".
# Relocatability support must be added before writing the merge module sub find_relocatable_fields { my $self = shift;
return 1 unless $self->relocatable();
# Set the fileid attributes. my $perl_id = $self->get_fragment_object('perl') ->find_file_id( $self->file(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_id( $self->file('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; } ## end sub find_relocatable_fields
The install_win32_extras method is used by run to install the links and launchers into the Start menu.
# Install links and launchers and so on 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', url => 'http://search.cpan.org/', 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', url => 'http://perldoc.perl.org/5.8.9/', 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', url => 'http://perldoc.perl.org/5.10.0/', 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', url => 'http://perldoc.perl.org/5.10.1/', icon_file => catfile( $self->wix_dist_dir(), 'perldoc.ico' ) ); } if ( $self->perl_version_human eq '5.12.0' ) { $self->install_website( name => 'Perl 5.12.0 Documentation', url => 'http://perldoc.perl.org/5.12.0/', icon_file => catfile( $self->wix_dist_dir(), 'perldoc.ico' ) ); } $self->install_website( name => 'Win32 Perl Wiki', url => 'http://win32.perl.org/', 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', );
$self->add_to_fragment( 'Win32Extras', [ catfile( $self->image_dir(), qw(win32 win32.ico) ), catfile( $self->image_dir(), qw(win32 cpan.ico) ), ] );
} ## end if ( $self->msi() )
return $self; } ## end sub install_win32_extras
The remove_waste method is used by run to remove files that the distribution does not need to package.
# Delete various stuff we won't be needing 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.* });
# Readding the cpan directory. $self->remake_path( catdir( $self->build_dir, 'cpan' ) );
return 1; } ## end sub remove_waste
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; }
The regenerate_fragments method is used by run to fully generate the object tree for file-containing fragments, which only contain a list of files until their regenerate() routines are run.
sub regenerate_fragments { my $self = shift;
return 1 unless $self->msi();
# Add the perllocal.pod here, because apparently it's disappearing. 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" ); } }
= -1; # clears the array. @fragment_names = uniq @fragment_names_regenerate; = -1; } ## end while ( 0 != scalar @fragment_names)
return 1; } ## end sub regenerate_fragments
The write method is used by run to compile the final installers for the distribution.
sub write { ## no critic 'ProhibitBuiltinHomonyms' 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; }
The write_merge_module method is used by run to compile the merge module for the distribution.
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" );
# Create the archive my $zip = Archive::Zip->new();
# Add the fragments directory to the root $zip->addTree( $self->fragment_dir(), q{} );
my @members = $zip->members();
# Set max compression for all members, deleting .AAA files. 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); } }
# Write out the file name $zip->writeToFileNamed($zipfile);
# Remake the fragments directory. $self->remake_path( $self->fragment_dir() );
## no critic(ProtectPrivateSubs) # Reset the directory tree. $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);
# Start adding the fragments that are only for the .msi. $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()->stringify() ); }
my $mm = Perl::Dist::WiX::Tag::MergeModule->new( id => 'Perl', disk_id => 1, language => 1033, source_file => $self->output_dir() ->file( $self->output_base_filename() . '.msm' )->stringify(), primary_reference => 1, ); $self->_add_merge_module( 'Perl', $mm ); $self->get_directory_tree() ->add_merge_module( $self->image_dir()->stringify(), $mm ); } ## end if ( $self->msi() )
return 1; } ## end sub write_merge_module
#####################################################################
# Package Generation
The _write_zip method is used to generate a standalone .zip file containing the entire distribution, for situations in which a full installer database is not wanted (such as for "Portable Perl" type installations). It is called by write when needed.
The .zip file is written to the output directory, and the location of the file is printed to STDOUT.
Returns true or throws an exception or error.
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" );
# Make directories. $self->remake_path( catdir( $self->image_dir(), qw(cpan sources) ) ); $self->remake_path( catdir( $self->image_dir(), qw(cpanplus ) ) );
# Create the archive my $zip = Archive::Zip->new();
# Add the image directory to the root $zip->addTree( $self->image_dir(), q{} );
my @members = $zip->members();
# Set max compression for all members, deleting .AAA files. foreach my $member (@members) { next if $member->isDirectory(); $member->desiredCompressionLevel(9); if ( $member->fileName =~ m{[.] AAA\z}smx ) { $zip->removeMember($member); } }
# Write out the file name $zip->writeToFileNamed($file);
return $file; } ## end sub _write_zip
TODO: Document
sub add_icon { my $self = shift; my %params = @_; my ( $vol, $dir, $file, $dir_id );
# Get the Id for directory object that stores the filename passed in. ( $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();
# Get a legal id. my $id = $params{name}; $id =~ s{\s}{_}msxg; # Convert whitespace to underlines.
# Add the start menu icon. $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; } ## end sub add_icon
$self->add_path('perl', 'bin');Adds a path entry that will be installed when the installer is executed.
sub add_path { my $self = shift; my @path = @_; my $dir = $self->dir(@path); unless ( -d $dir ) { PDWiX::Directory->throw( dir => $dir, message => 'PATH directory does not exist' ); } $self->_add_env_path_unchecked( [@path] ); return 1; } ## end sub add_path
my $ENV{PATH} = "$ENV{PATH};" . $dist->get_path_string();Returns a string containing all the path entries that have been added, so that later portions of the installer generation can use the programs that have already been put in place.
sub get_path_string { my $self = shift; return join q{;}, map { $self->dir( @{$_} ) } $self->_get_env_path_unchecked(); }
Compiles a .wxs file (specified by $filename) into a .wixobj file (specified by $wixobj.) Both parameters are required.
$self = $self->_compile_wxs("Perl.wxs", "Perl.wixobj");sub _compile_wxs { my ( $self, $filename, $wixobj ) = @_; my @files = @_;
# Check parameters. 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::File->throw( file => $filename, message => 'File does not exist or is not readable' ); }
# Compile the .wxs file 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; } ## end sub _compile_wxs
$self->_write_msi;The _write_msi method is used to generate the compiled installer database. It creates the entire installation file tree, and then executes WiX to create the final executable.
This method is called by write, and should only be called after all installation phases have been completed and all of the files for the distribution are in place.
The executable file is written to the output directory, and the location of the file is printed to STDOUT.
Returns true or throws an exception or error.
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:
# Write out .wxs files for all the fragments and compile them. 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::File->throw( file => $filename_in, message => 'Could not open file 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; } ## end foreach my $key ( $self->_fragment_keys...)
# Generate feature tree. $self->_set_feature_tree_object( Perl::Dist::WiX::FeatureTree2->new( parent => $self, ) );
my $mm;
# Add merge modules. foreach my $mm_key ( $self->_merge_module_keys() ) { $mm = $self->get_merge_module_object($mm_key); $self->feature_tree_object()->add_merge_module($mm); }
# Write out the .wxs file my $content = $self->as_string('Main.wxs.tt'); $content =~ s{\r\n}{\n}msg; # CRLF -> LF $filename_in = catfile( $self->fragment_dir(), $self->app_name() . q{.wxs} );
if ( -f $filename_in ) {
# Had a collision. Yell and scream. 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::File->throw( file => $filename_in, message => 'Could not open file for writing ' . "[$OS_ERROR] [$EXTENDED_OS_ERROR]" ); } $fh->print($content); $fh->close;
# Compile the main .wxs $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)" ); }
# Start linking the msi.
# Get the parameters for the msi linking. 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' );
# Link the .wixobj files $self->trace_line( 1, "Linking $output_msi\n" ); my $out; my $cmd = [ wix_bin_light(), '-sice:ICE38', # Gets rid of ICE38 warning. '-sice:ICE43', # Gets rid of ICE43 warning. '-sice:ICE47', # Gets rid of ICE47 warning. # (Too many components in one # feature for Win9X) '-sice:ICE48', # Gets rid of ICE48 warning. # (Hard-coded installation location)
# '-v', # Verbose for the moment. '-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 );
# Did everything get done correctly? 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; } ## end sub _write_msi
$self->_write_msm;The _write_msm method is used to generate the compiled merge module used in the installer. It creates the entire installation file tree, and then executes WiX to create the merge module.
This method is called by write_merge_module, and should only be called after all installation phases that install perl modules that should be in the .msm have been completed and all of the files for the merge module are in place.
The merge module file is written to the output directory, and the location of the file is printed to STDOUT.
Returns true or throws an exception or error.
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" );
# Add the path in. foreach my $value ( map { '[INSTALLDIR]' . catdir( @{$_} ) } $self->_get_env_path_unchecked() ) { $self->add_env( 'PATH', $value, 1 ); }
FRAGMENT:
# Write out .wxs files for all the fragments and compile them. 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::File->throw( file => $filename_in, message => 'Could not open file 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; } ## end foreach my $key ( $self->_fragment_keys...)
# Generate feature tree. $self->_set_feature_tree_object( Perl::Dist::WiX::FeatureTree2->new( parent => $self, ) );
# Write out the .wxs file my $content = $self->as_string('Merge-Module.wxs.tt'); $content =~ s{\r\n}{\n}msg; # CRLF -> LF $filename_in = catfile( $self->fragment_dir, $self->app_name . q{.wxs} );
if ( -f $filename_in ) {
# Had a collision. Yell and scream. 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;
# Compile the main .wxs $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)" ); }
# Start linking the merge module.
# Get the parameters for the msi linking. 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' );
# Link the .wixobj files $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 );
# Did everything get done correctly? 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)"); }
# Now write out the documentation for the msm. 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::File->throw( file => $filename_in, message => 'Could not open file for writing ' . "[$OS_ERROR] [$EXTENDED_OS_ERROR]" ); } $fh->print($docs); $fh->close;
return ( $output_msm, $output_docs ); } ## end sub _write_msm
Adds the contents of $value to the environment variable $name (or appends to it, if $append is true) upon installation (by adding it to the Reg_Environment fragment.)
$name and $value are required.
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; } ## end sub add_env
Adds the file $filename to the fragment named by $fragment_name.
Both parameters are required, and the file and fragment must both exist.
sub add_file { my ( $self, %params ) = @_;
unless ( _STRING( $params{source} ) ) { PDWiX::Parameter->throw( parameter => 'source', where => '::Installer->add_file' ); }
unless ( -f $params{source} ) { PDWiX::File->throw( file => $params{source}, message => 'File 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; } ## end sub add_file
$self->insert_fragment($id, $files_obj, $overwritable);Adds the list of files $files_obj (which is a File::List::Object) to the fragment named by $id. $overwritable defaults to false, and most be set to true if the files in this fragment can be overwritten by future fragments.
The fragment is created by this routine, so this can only be done once.
This MUST be done for each set of files to be installed in an MSI.
sub insert_fragment { my ( $self, $id, $files_obj, $overwritable ) = @_;
# Check parameters. 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; } ## end sub insert_fragment
$dist->add_to_fragment($id, $files_obj);Adds the list of files $files_obj (which is a File::List::Object) to the fragment named by $id.
The fragment must already exist.
sub add_to_fragment { my ( $self, $id, $files_ref ) = @_;
# Check parameters. 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; } ## end sub add_to_fragment
#####################################################################
#
# Serialization
#
Loads the file template passed in as the parameter, using this object, and returns it as a string.
Used for .wxs files.
# Loads up the merge module template.
$wxs = $self->as_string('Merge-Module.wxs.tt');
# Loads up the main template
$wxs = $self->as_string('Main.wxs.tt');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(), ) ); }
Loads the file template passed in as the first parameter, using this object, and returns it as a string.
Additional entries (beyond the one given that 'dist' is the Perl::Dist::WiX object) for the second parameter of Template->process are given as a reference to a list of pairs in the optional second parameter.
# Loads up the template for merge module docs.
$text = $self->process_template('Merge-Module.documentation.txt.tt');sub process_template { my $self = shift; my $template_file = shift; my @vars_in = @_;
my $tt = $self->patch_template();
my $answer; my $tt_answer; my %vars = ( @vars_in, dist => $self, );
$tt_answer = $tt->process( $template_file, \%vars, \$answer );
PDWiX::Caught->throw( info => 'Template', message => $tt->error()->as_string() ) if not $tt_answer;
#<<< # Delete empty lines. ## no critic(ProhibitComplexRegexes) $answer =~ s{(?>\x0D\x0A?|[\x0A-\x0C\x85\x{2028}\x{2029}]) # Replace a linebreak, # (within parentheses is = to \R for 5.8) \s*? # any whitespace we may be able to catch, (?>\x0D\x0A?|[\x0A-\x0C\x85\x{2028}\x{2029}])} # and a second linebreak {\r\n}msgx; # With one Windows linebreak. #>>>
# Combine it all return $answer; } ## end sub process_template
#####################################################################
#
# Patch Support
#
# TODO: May be moved to Perl::Dist::WiX::Patching
#
Returns an array reference containing a list of paths containing files that are used to replace or patch files in the distribution.
# By default only use the default (as a default...) 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::Directory->throw( dir => $path, message => 'Directory does not exist' ); } if ( $self->portable() ) { unless ( -d $portable ) { PDWiX::Directory->throw( dir => $portable, message => 'Directory does not exist' ); } return [ $portable, $path ]; } else { return [$path]; } } ## end sub patch_include_path
Returns the list of directories in patch_include_path as a File::PathList object.
sub patch_pathlist { my $self = shift; return File::PathList->new( paths => $self->patch_include_path(), ); }
patch_template returns the Template object that is used to generate patched files.
has 'patch_template' => ( is => 'ro', isa => TemplateObj, lazy => 1, init_arg => undef, builder => '_build_patch_template', clearer => '_clear_patch_template', );
sub _build_patch_template { my $self = shift; my $obj = Template->new( INCLUDE_PATH => $self->patch_include_path(), ABSOLUTE => 1, );
PDWiX::Caught->throw( message => Template::error(), info => 'Template' ) unless $obj;
return $obj; } ## end sub _build_patch_template
patch_file patches an individual file installed in the distribution using a file from the directories returned from "patch_pathlist".
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();
# Locate the source file 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{} ) {
# Generate the file 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");
# Copy the file to the final location $fh->close or PDWiX->throw("Could not close: $OS_ERROR"); $self->copy_file( $output => $to ); unlink $output or PDWiX->throw("Could not delete $output: $OS_ERROR");
} elsif ( $from ne q{} ) {
# Simple copy of the regular file to the target location $self->copy_file( $from => $to );
} else { PDWiX::File->throw( file => $file, message => 'Failed to find file' ); }
return 1; } ## end sub patch_file
The drive letter of the image directory. Retrieved from image_dir.
sub image_drive { my $self = shift; return substr rel2abs( $self->image_dir() ), 0, 2; }
Returns a string containing the image_dir as a file: URL.
sub image_dir_url { my $self = shift; return URI::file->new( $self->image_dir() )->as_string(); }
Returns a string containing the image_dir, with all backslashes converted to 2 backslashes.
# This is a temporary hack sub image_dir_quotemeta { my $self = shift; my $string = $self->image_dir(); $string =~ s{\\} # Convert a backslash {\\\\}gmsx; ## to 2 backslashes. return $string; }
1;
__END__
See Perl::Dist::WiX::Diagnostics for a list of exceptions that this module can throw.
Perl 5.8.1 is the mimimum version of perl that this module will run on.
Other modules that this module depends on are a working version of Alien::WiX, Data::Dump::Streamer 2.08, Data::UUID 1.149, Devel::StackTrace 1.20, Exception::Class 1.22, File::ShareDir 1.00, IO::String 1.08, List::MoreUtils 0.07, Module::CoreList 2.29, Win32::Exe 0.13, Object::InsideOut 3.53, Perl::Dist 1.14, Process 0.26, Readonly 1.03, URI 1.35, and Win32 0.35.
Bugs should be reported via:
1) The CPAN bug tracker at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Perl-Dist-WiX if you have an account there.
2) Email to <bug-Perl-Dist-WiX@rt.cpan.org> if you do not.
For other issues, contact the topmost author.
Curtis Jewell <csjewell@cpan.org>
Adam Kennedy <adamk@cpan.org>
Perl::Dist, Perl::Dist::Inno, http://ali.as/, http://csjewell.comyr.com/perl/
Copyright 2009 - 2010 Curtis Jewell.
Copyright 2008 - 2009 Adam Kennedy.
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.