view release on metacpan or  search on metacpan

lib/Perl/Dist/WiX/Mixin/Support.pm  view on Meta::CPAN

			dir     => $dir,
			message => 'Failed to recreate directory, no information why'
		);
	}
	return $dir;
} ## end sub remake_path



=head2 remove_path

	$dist->remove_path('perl\bin');

Removes a path, removing all the files in it if the path already exists.

The path passed in is converted to an absolute path using 
L<File::Spec::Functions|File::Spec::Functions>::L<rel2abs()|File::Spec/rel2abs>
before deletion occurs.

=cut

sub remove_path {
	my $class = shift;
	my $dir   = rel2abs(shift);
	my $err;
	if ( -d "$dir" ) {
		File::Path::remove_tree(
			"$dir",
			{   keep_root => 0,
				error     => \$err,
			} );
		my $e = $EVAL_ERROR;
		if ($e) {
			PDWiX::Directory->throw(
				dir     => $dir,
				message => "Failed to remove directory, critical error:\n$e"
			);
		}
		if ( @{$err} ) {
			my $errors = q{};
			for my $diag ( @{$err} ) {
				my ( $file, $message ) = %{$diag};
				if ( $file eq q{} ) {
					$errors .= "General error: $message\n";
				} else {
					$errors .= "Problem removing $file: $message\n";
				}
			}
			PDWiX::Directory->throw(
				dir     => $dir,
				message => "Failed to remove directory, errors:\n$errors"
			);
		} ## end if ( @{$err} )
	} ## end if ( -d "$dir" )

	return;
} ## end sub remove_path



=head2 make_relocation_file

	$dist->make_relocation_file('strawberry_merge_module.reloc.txt');
	
	$dist->make_relocation_file('strawberry_ui.reloc.txt', 
		'strawberry_merge_module.reloc.txt');
	
Creates a file to be input to relocation.pl.

The first file is created, and it includes all files in the .source file 
that actually exist, and adds all .packlist files that are not already
being processed for relocation in files after the first.

If there is no second parameter, the first file will include all
.packlist files existing to that point.

=cut 

sub make_relocation_file {
	my $self                      = shift;
	my $file                      = shift;
	my (@files_already_processed) = @_;

	## no critic(ProhibitComplexMappings ProhibitMutatingListFunctions)
	## no critic(ProhibitCaptureWithoutTest RequireBriefOpen)
	# TODO: Calm down on the no critics.

	# Get the input and output filenames.
	my $file_in  = $self->patch_pathlist()->find_file( $file . '.source' );
	my $file_out = $self->image_dir()->file($file);

	# Find files we're already assigned for relocation.
	my @filelist;
	my %files_already_relocating;
	foreach my $file_already_processed (@files_already_processed) {
		@filelist = read_file(
			$self->image_dir()->file($file_already_processed)->stringify()
		);
		shift @filelist;
		%files_already_relocating = (
			%files_already_relocating,
			map { m/\A([^:]*):.*\z/msx; $1 => 1 } @filelist
		);
	}

	# Find all the .packlist files.
	my @packlists_list =
	  File::Find::Rule->file()->name('.packlist')->relative()
	  ->in( $self->image_dir()->stringify() );
	my %packlists = map { s{/}{\\}msg; $_ => 1 } @packlists_list;

	# Find all the .bat files.
	my @batch_files_list =
	  File::Find::Rule->file()->name('*.bat')->relative()
	  ->in( $self->image_dir()->stringify() );
	my %batch_files = map { s{/}{\\}msg; $_ => 1 } @batch_files_list;

	# Get rid of the .packlist and *.bat files we're already relocating.
	delete @packlists{ keys %files_already_relocating };
	delete @batch_files{ keys %files_already_relocating };

	# Print the first line of the relocation file.
	my $file_out_handle;
	open $file_out_handle, '>', $file_out
	  or PDWiX::File->throw(
		file    => $file_out,
		message => 'Could not open.'
	  );
	print {$file_out_handle} $self->image_dir()->stringify();
	print {$file_out_handle} "\\\n";

	# Read the source file, writing out the files that actually exist.
	@filelist = read_file($file_in);
	foreach my $filelist_entry (@filelist) {
		$filelist_entry =~ m/\A([^:]*):.*\z/msx;
		if ( defined $1 and -f $self->image_dir()->file($1)->stringify() ) {
			print {$file_out_handle} $filelist_entry;
		}
	}

	# Print out the rest of the .packlist files.
	foreach my $pl ( sort { $a cmp $b } keys %packlists ) {
		print {$file_out_handle} "$pl:backslash\n";
	}

	# Print out the batch files that need relocated.
	my $batch_contents;
	my $match_string =
	  q(eval [ ] 'exec [ ] )
	  . quotemeta $self->image_dir()->file('perl\\bin\\perl.exe')
	  ->stringify();
	foreach my $batch_file ( sort { $a cmp $b } keys %batch_files ) {
		$self->trace_line( 5,
			"Checking to see if $batch_file needs relocated.\n" );
		$batch_contents =
		  read_file( $self->image_dir()->file($batch_file)->stringify() );
		if ( $batch_contents =~ m/$match_string/msgx ) {
			print {$file_out_handle} "$batch_file:backslash\n";
		}
	}

	# Finish up by closing the handle.
	close $file_out_handle or PDWiX->throw('Ouch!');

	return 1;
} ## end sub make_relocation_file

no Moose;
__PACKAGE__->meta()->make_immutable();

1;

__END__

=pod

=head1 SUPPORT

Bugs should be reported via the CPAN bug tracker at

L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Perl-Dist-WiX>

For other issues, contact the author.

=head1 AUTHOR

Curtis Jewell E<lt>csjewell@cpan.orgE<gt>

Adam Kennedy E<lt>adamk@cpan.orgE<gt>

=head1 SEE ALSO

L<Perl::Dist::WiX|Perl::Dist::WiX>, 

=head1 COPYRIGHT AND LICENSE

Copyright 2009 - 2011 Curtis Jewell.

Copyright 2007 - 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 distribution.

=cut