Find file
Fetching contributors…
Cannot retrieve contributors at this time
295 lines (207 sloc) 6.81 KB
@rem = '--*-Perl-*--
@echo off
if "%OS%" == "Windows_NT" goto WinNT
%~dp0perl\bin\perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
:WinNT
%~dp0perl\bin\perl -x -S %0 %*
goto endofperl
@rem ';
#!perl
use 5.008009;
use strict;
use warnings;
use File::Slurp qw(read_file write_file);
use Getopt::Long qw(GetOptions);
use Pod::Usage qw(pod2usage);
use English qw( -no_match_vars );
use File::Spec::Functions qw(splitpath catfile);
use Carp qw(carp);
use Win32::File::Object qw();
use FindBin;
sub usage;
sub version;
sub relocate_file;
our $STRING_VERSION = our $VERSION = '1.002';
$VERSION =~ s/_//;
my @files;
my $quiet = 0;
my $new_location = undef;
GetOptions('help|?' => sub { pod2usage(-exitstatus => 0, -verbose => 0); },
'man' => sub { pod2usage(-exitstatus => 0, -verbose => 2); },
'usage' => sub { usage(); },
'version' => sub { version(); exit(1); },
'file=s' => \@files,
'location=s' => \$new_location,
'quiet' => \$quiet,
) or pod2usage(-verbose => 2);
if (0 == scalar @files) {
@files = glob catfile($FindBin::Bin, '*.reloc.txt');
}
if (not defined $new_location) {
$new_location = $FindBin::Bin;
$new_location =~ s{/}{\\}g;
}
if ("\\" ne substr $new_location, -1, 1) {
$new_location .= "\\";
}
if ($new_location =~ m/ /) {
carp "New location cannot have spaces in it" if not $quiet;
exit(1);
}
if ($OSNAME eq 'MSWin32') {
my $long_name = Win32::GetLongPathName($new_location);
if ((defined $long_name) and ($long_name =~ m/ /)) {
carp "New location cannot have spaces in it" if not $quiet;
exit(1);
}
}
my @lines;
my $ok = 1;
foreach my $file (@files) {
@lines = read_file($file);
my $old_location = shift @lines;
chomp $old_location;
print "\nRelocating files from $old_location to $new_location\n" if not $quiet;
LINE:
foreach my $line (@lines) {
next LINE if $line eq "\n";
$ok = relocate_file($old_location, $new_location, $quiet, split /:/, $line);
if (not $ok) {
carp "Could not relocate $file.\n" if not $quiet;
exit(1);
}
}
unshift @lines, "$new_location\n";
write_file($file, @lines);
}
print "Relocation completed\n" if not $quiet;
exit(0);
sub get_replacements_backslash {
my ($old_location, $new_location) = @_;
$old_location =~ s{/}{\\}gmx;
$new_location =~ s{/}{\\}gmx;
return ("\Q$old_location\E", $new_location);
}
sub get_replacements_doublebackslash {
my ($old_location, $new_location) = @_;
$old_location =~ s{\\}{/}gmx;
$new_location =~ s{\\}{/}gmx;
$old_location =~ s{/}{\\\\}gmx;
$new_location =~ s{/}{\\\\}gmx;
return ("\Q$old_location\E", $new_location);
}
sub get_replacements_slash {
my ($old_location, $new_location) = @_;
$old_location =~ s{\\}{/}gmx;
$new_location =~ s{\\}{/}gmx;
return ("\Q$old_location\E", $new_location);
}
sub get_replacements_url {
my ($old_location, $new_location) = @_;
$old_location =~ s{\\}{/}gmx;
$new_location =~ s{\\}{/}gmx;
return ("file:///$old_location", "file:///$new_location");
}
sub relocate_file {
my ($old_location, $new_location, $quiet, $file, $type) = @_;
chomp $type;
print "Relocating file $file using $type relocation\n" if not $quiet;
my $full_file = catfile($new_location, $file);
my $contents = read_file($full_file);
my ($old, $new) =
('backslash' eq $type) ? get_replacements_backslash($old_location, $new_location)
: ('slash' eq $type) ? get_replacements_slash($old_location, $new_location)
: ('doublebackslash' eq $type) ? get_replacements_doublebackslash($old_location, $new_location)
: ('url' eq $type) ? get_replacements_url($old_location, $new_location)
: ();
if (defined $old) {
$contents =~ s{$old}{$new}g;
} else {
carp "Can't do a $type relocation\n" if not $quiet;
exit(1);
}
if ( not -f $full_file ) {
carp "Can't relocate a file $file that isn't a file\n" if not $quiet;
exit(1);
}
my $ok;
if ( not -w $full_file ) {
# Make sure it isn't readonly
my $fileobj = Win32::File::Object->new( $full_file, 1 );
my $readonly = $fileobj->readonly();
$fileobj->readonly(0);
# Do the actual write
$ok = write_file($full_file, $contents);
# Set it back to what it was
$fileobj->readonly($readonly);
} else {
$ok = write_file($full_file, $contents);
}
return $ok;
}
sub version {
my (undef, undef, $script) = splitpath( $PROGRAM_NAME );
print <<"EOF";
This is $script, version $STRING_VERSION, which relocates
Strawberry Perl to a new location.
Copyright 2010 Curtis Jewell.
This script may be copied only under the terms of either the Artistic License
or the GNU General Public License, which may be found in the Perl 5
distribution or the distribution containing this script.
EOF
return;
}
sub usage {
my $error = shift;
print "Error: $error\n\n" if (defined $error);
my (undef, undef, $script) = splitpath( $PROGRAM_NAME );
print <<"EOF";
This is $script, version $STRING_VERSION, which relocates
Strawberry Perl to a new location.
Usage: perl $script
[ --help ] [ --usage ] [ --man ] [ --version ] [ -? ]
[--file relocationfile] [--location path] [--quiet]
For more assistance, run perl $script --help.
EOF
exit(1);
}
__END__
=head1 NAME
relocation.pl.bat - Relocates Strawberry Perl.
=head1 VERSION
This document describes relocation.pl.bat version 1.002.
=head1 DESCRIPTION
This script updates all of Strawberry Perl's files to a new location.
=head1 SYNOPSIS
relocation.pl.bat [ --help ] [ --usage ] [ --man ] [ --version ] [ -?]
[--file relocationfile] [--location path] [--quiet]
Options:
--usage Gives a minimum amount of aid and comfort.
--help Gives aid and comfort.
-? Gives aid and comfort.
--man Gives maximum aid and comfort.
--version Gives the name, version and copyright of the script.
--file Gives the location of the file of hints to use to
relocate Perl. Defaults to all *.reloc.txt files in
the current directory.
--location The location to relocate to. Defaults to $FindBin::Bin.
--quiet Print nothing.
=head1 DEPENDENCIES
Perl 5.8.9 is the mimimum version of perl that this script will run on.
Other modules that this script depends on are
L<Getopt::Long|Getopt::Long>, L<Pod::Usage|Pod::Usage>,
L<File::Slurp|File::Slurp>, and L<Win32::File::Object|Win32::File::Object>
=head1 SUPPORT
Support is provided for this script on the same basis as Strawberry Perl.
See L<http://strawberryperl.com/support.html> for details.
=head1 AUTHOR
Curtis Jewell, E<lt>csjewell@cpan.orgE<gt>
=head1 COPYRIGHT & LICENSE
Copyright 2010 Curtis Jewell.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this distribution.
=cut
:endofperl