@rem = '--*-Perl-*--
@echo off
if "%OS%" == "Windows_NT" goto WinNT
Perl\bin\perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
:WinNT
Perl\bin\perl -x -S %0 %*
if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
if %errorlevel% == 9009 echo You do not have Perl in your PATH.
if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
goto endofperl
@rem ';
#!Perl/bin/perl -w
#line 15
#
# ActivePerl ZIP installer
#
# Copyright (c) 2000-2004 ActiveState Corp.  All rights reserved.
# ActiveState is a division of Sophos Plc.
#
# This program completes a simple installation of ActivePerl
#
# The intent of this program is to provide a "fail-safe" way of installing
# a fully-functional version of ActivePerl.  If there is a failure, this
# script should explain exactly what went wrong, and how to fix it.
# If not, submit that as a bug.
#
# What is does:
#     o Relocates Perl
#     o Creates MSWin32 Shortcuts to the HTML documentation
#     o Configures PPM
#     o Configures lib/Config.pm for use with a development system
#     o Creates ActivePerl registry entries
#     o Updates the PATH environment variable
#
# Todo:
#     o uninstall (pretty simple)
#     o configure Perl for use with a Web Server
#     o set up file associations on Win32
#

my $product = "ActivePerl";
die "Template not expanded yet" if $product =~ /TMPL_VAR/;

# The path we will be replacing
#my \$replace = q[$path];

# The ActivePerl version we are installing
my $APVersion = Win32::BuildNumber();

# It should be safe to comment the following out on non-MSWin32 platforms
use Win32;
use Win32API::Registry (':ALL');
use Win32::Shortcut;

use Cwd;
use strict;
no strict "subs";    # not my fault

$|=1; #disable buffering

(-d 'Perl/bin' && -d 'Perl/lib' && -d 'Perl/site')
    || die "Error: you must run this script from the directory in which you unzipped ActivePerl into.\n";

my $temp = $ENV{'TEMP'}
    || die "You must set the 'TEMP' environment variable.\n";

my $cwd = cwd;
$cwd =~ s#/#\\#g;

if (@ARGV && $ARGV[0] eq '--remove') {
    remove_html_shortcuts();
    print <<EOM;

ActivePerl uninstalled...you may now delete this directory and
its subdirectories.

EOM
    exit;
}

print <<EOM;
    Welcome to ActivePerl.

    This installer can install ActivePerl in any location of your choice.
    You do not need Administrator privileges.  However, please make sure
    that you have write access to this location.

EOM

my $prefix;
do {
    print 'Enter top level directory for install [c:\Perl]: ';
    chomp($prefix=<>);
    $prefix ||='c:\Perl';

    unless ($prefix =~/(^.:\\)|(\\\\)/) {
	print "Error: You must include the drive letter or the full UNC PATH\n\n";
	$prefix = undef;
    }
} until defined $prefix;

if (-d $prefix) {
    print <<EOM;

$prefix appears to already exist.

    WARNING: Install may fail if any existing files cannot be
    overwritten.
EOM
}

if ($prefix =~ /[\s;,!|<>~\@\%\&\$\*\?\+]/) {
    print <<EOM;

    Looks like you are trying to install Perl into a path that contains
    spaces or other special characters.  Though the latest Windows
    operating systems claim to support filenames with such special
    characters, many existing utilities will have trouble with such
    path names.  Chances are that you will find this is simply too
    much of a bad idea to be worth it.

EOM
    }

print <<EOM;

    The typical ActivePerl software installation requires 75 megabytes.
    Please make sure enough free space is available before continuing.

    ActivePerl $APVersion will be installed into '$prefix'
EOM
print 'Proceed? [y] ';
<> =~ /^\s*[y|\n]$/i or exit 1;

# Hint to MSWin32 users that devsys environment should be set before installing
#
if ((!defined($ENV{'INCLUDE'}) || !defined($ENV{'LIB'})) && $^O eq 'MSWin32') {
    print <<EOM;

    If you have a development environment (e.g. Visual Studio) that you
    wish to use with Perl, you should ensure that your environment (e.g.
    %LIB% and %INCLUDE%) is set before installing, for example, by running
    vcvars32.bat first.
EOM

    print 'Proceed? [y] ';
    <> =~ /^\s*[y|\n]$/i or exit 1;
}

    print "\nCreate shortcuts to the HTML documentation? [y] ";
    (my $create_html_shortcuts = <>) =~ /^\s*[y|\n]$/i;

    print "\nAdd the Perl/bin directory to the PATH? [y] ";
    (my $add_path = <>) =~ /^\s*[y|\n]$/i;

#alright, copy the files
print <<EOM;

    Copying files...
EOM

# disables prompting in newer versions of cmd.exe if there are
# older files of the same name
$ENV{COPYCMD} = "/y";

my $cmd = "xcopy /q /r /i /e Perl\\* \"$prefix\" ";
system($cmd) && die "$!\n";

print "    Finished copying files...\n";

my $perl = "$prefix/bin/perl.exe";
$ENV{PATH} = "$prefix\\bin;$ENV{PATH}";

# system($perl, "$prefix/bin/reloc_perl", '-a', '-i', '-v', '-t', $prefix, $replace) == 0
#     or die "Couldn't run reloc_perl: $!";

# Relocate
if (open(my $reloc, "support/reloc.txt")) {
    use Config;
    my $sponge = $Config{prefix};
    die "Can't relocate to a path longer than " . length($sponge) . " chars"
	if length($prefix) > length($sponge);
    my $binary_pad = "\0" x (length($sponge) - length($prefix));

    print "Relocating...";
    my $count = 0;
    local $_;
    while (<$reloc>) {
	chomp;
	my($type, $f) = split(' ', $_, 2);
	$f = "$prefix/$f";
	#print "Relocating $f...\n";
	my $read_only;
	unless (-w $f) {
	    $read_only++;
	    run("\@attrib", "-r", $f);
	}

	open(my $fh, "+<", $f) || die "Can't open $f: $!";
	binmode($fh);
	my $content = do { local $/; <$fh> };

	if ($type eq "B") {
	    $content =~ s,\Q$sponge\E([^\0]*),$prefix$1$binary_pad,go;
	}
	else {
	    $content =~ s,\Q$sponge\E,$prefix,go;
	    truncate($fh, length($content)) || die "Can't truncate '$f': $!";
	}

	seek($fh, 0, 0) || die "Can't reset file pos on '$f': $!";
	print $fh $content;
	close($fh) || die "Can't write back content to '$f': $!";

	run("\@attrib", "+r", $f) if $read_only;

	$count++;
    }
    print "done ($count files relocated)\n";
}

if ($^O eq 'MSWin32') {
    create_html_shortcuts() if $create_html_shortcuts;
    create_registry_entries();
    update_path() if $add_path;
    configure_configpm();
}
configure_ppm();
build_html();

print <<EOM;

This simplified installation program currently does *not*:

    o set up MSWin32 file associations
    o configure Perl for use with a Web Server

Refer to your Operating System and/or Web Server documentation for
details on how to to perform these modifications.

Thank you for installing ActivePerl!

EOM

if (Win32::IsWin95) {
    sleep 5; #STDIN is dead
}
else {
    print "Press return to exit.\n";
    <>;
}

exit;

sub configure_configpm
{
    my ($LIB, $INC);
    print "\nConfiguring $prefix/lib/Config.pm for use in $prefix...\n\n";

    system($perl, "$prefix/bin/config.pl", $prefix) == 0
        or die "Couldn't config $prefix/lib/config.pm: $!";

    # Create values for libpth and incpath in Config.pm
    if (defined $ENV{'LIB'}) {
        $LIB = '"' . join(q(" "), split(/;/, $ENV{'LIB'})) . '" ';
    } else {
        $LIB = '/lib /usr/lib /usr/local/lib ';
    }
    $LIB .= qq("$prefix\\lib\\CORE");

    if (defined $ENV{'INCLUDE'}) {
        $INC = '"' . join(q(" "), split(/;/, $ENV{'INCLUDE'})) . '" ';
    } else {
        $INC = '/usr/include /usr/local/include ';
    }
    $INC .= qq("$prefix\\lib\\CORE");

    my @Config;
    open (CONFIG, "<$prefix/lib/Config.pm")
        or die "Can't open $prefix/lib/Config.pm for reading: $!";
    @Config = <CONFIG>;
    close(CONFIG);
    foreach(@Config) {
        s@^libpth=.*$@libpth='$LIB'@g;
        s@^incpath=.*$@incpath='$INC'@g;
    }
    unlink("$prefix/lib/Config.pm.old") if -f "$prefix/lib/Config.pm.old";
    rename("$prefix/lib/Config.pm", "$prefix/lib/Config.pm.old")
        or die "Can't rename $prefix/lib/Config.pm to $prefix/lib/Config.pm.old: $!";

    open (CONFIG, ">$prefix/lib/Config.pm")
        or die "Can't open $prefix/lib/Config.pm for writing: $!";
    print CONFIG @Config;
    close(CONFIG);
}


sub configure_ppm
{
    print "\nConfiguring PPM for use in $prefix...\n\n";

    if (-f "$prefix/bin/ppm2.bat") {
	system($perl, "$prefix/bin/ppm2.bat", 'set', 'build', $temp) == 0
	    or die "Couldn't set ppm2 BUILDDIR: $!";
    }
    if (-f "$prefix/bin/ppm3.bat") {
	system($perl, "$prefix/bin/ppm3.bat", 'set', 'tempdir', $temp) == 0
	    or die "Couldn't set ppm3 TEMPDIR: $!";
    }
    print <<EOM;

If you are behind a firewall, you may need to set the following
environment variables so that PPM will operate properly:

    set HTTP_proxy=address:port         [e.g. 192.0.0.1:8080]
    set HTTP_proxy_user=username
    set HTTP_proxy_pass=password
    set HTTP_proxy_agent=agent          [e.g. "Mozilla/5.0"]

EOM
}

sub build_html {
    print "\nBuilding HTML documentation, please wait...\n\n";

    # Can't do this in-process because the by now modified Config.pm and
    # %Config can't be reloaded easily
    system($perl, "-MActivePerl::DocTools", "-e", "UpdateHTML('wait')") == 0
	or die "Failed to build HTML documentation\n";
}

sub create_html_shortcuts
{
    my ($key, $location);
    $key = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\\';
    $key .= Win32::IsWin95() ? 'Programs' : 'Common Programs';

    my $try = Get(HKEY_LOCAL_MACHINE, $key, \$location);

    unless ($try) {
        $key = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Programs';
        $location = undef;
        $try = Get(HKEY_CURRENT_USER, $key, \$location);
    }

    unless ($try) {
        warn 'Read of shortcut dir failed: '. Win32::FormatMessage(Win32::GetLastError()) ."\n";
        return undef;
    }

    $location .= sprintf("/ActiveState ActivePerl %d.%d", ord($^V), ord(substr($^V,1)));
    mkdir($location, 0777) unless -d $location;

    my $link = new Win32::Shortcut();
    # Stupid NT can't handle / path separator in the shortcut
    ($link->{'Path'} = "$prefix\\html\\index.html") =~ s@/@\\@g;
    ($link->{'WorkingDirectory'} = "$prefix\\html") =~ s@/@\\@g;
    $link->{'Description'} = "ActivePerl Documentation in HTML format.";
    $link->{'ShowCmd'} = SW_SHOWNORMAL;
    $link->Save("$location\\Documentation.lnk");

    $link = new Win32::Shortcut();
    ($link->{'Path'} = "$prefix\\bin\\ppm3-bin.bat") =~ s@/@\\@g;
    ($link->{'WorkingDirectory'} = "$prefix\\bin") =~ s@/@\\@g;
    $link->{'Description'} = "Perl Package Manager.";
    $link->{'ShowCmd'} = SW_SHOWNORMAL;
    $link->Save("$location\\Perl Package Manager.lnk");

    $link = new Win32::Shortcut();
    ($link->{'Path'} = "$prefix\\html\\OLE-Browser\\Browser.html") =~ s@/@\\@g;
    ($link->{'WorkingDirectory'} = "$prefix\\html\\OLE-Browser") =~ s@/@\\@g;
    $link->{'Description'} = "OLE Browser.";
    $link->{'ShowCmd'} = SW_SHOWNORMAL;
    $link->Save("$location\\OLE-Browser.lnk");
}

sub create_registry_entries
{
    # Attempt to set some registry entries.
    (my $prefix = $prefix) =~ s@/@\\@g;

    Set(HKEY_LOCAL_MACHINE, 'SOFTWARE\ActiveState\ActivePerl\CurrentVersion', $APVersion, REG_SZ)
	|| warn "Couldn't make registry entry: $!\n";

    Set(HKEY_LOCAL_MACHINE, "SOFTWARE\\ActiveState\\ActivePerl\\$APVersion\\", $prefix, REG_SZ)
	|| warn "Couldn't make registry entry: $!\n";

    Set(HKEY_LOCAL_MACHINE, 'Software\Perl\\', $prefix, REG_SZ)
	|| warn "Couldn't make registry entry: $!\n";

    Set(HKEY_LOCAL_MACHINE, 'Software\Perl\BinDir', $perl, REG_SZ)
	|| warn "Couldn't make registry entry: $!\n";
}

sub update_path
{
    my $perlbin = "$prefix\\bin";
    $perlbin =~ s@/@\\@g;

    if (Win32::IsWin95()) {

	if ($perlbin =~ /\s/) {
	    $perlbin = qq["$perlbin"];
	}

	my $path_set = 0;

	if ($ENV{winbootdir}) {
	    my $autoexec = substr($ENV{winbootdir},0,2) .'\autoexec.bat';
	    if (-e $autoexec && ! -w $autoexec) {
		chmod 0755, $autoexec;
	    }
	    if (open(my $F, ">>$autoexec")) {
		print $F "\nSET PATH=$perlbin;%PATH%\n";
		close $F;
		++$path_set;
	    }
	    else {
		warn "Unable to open $autoexec for writing: $!\n";
	    }
	}
	else {
	    warn "No winbootdir environment variable found.\n";
	}
	unless ($path_set) {
	    print <<EOT;

The PATH has not been updated to include '$perlbin'.
You can edit your AUTOEXEC.BAT to add this yourself later.

EOT
	}
	return;
    }

    my $path;
    Get(HKEY_LOCAL_MACHINE, 'System\CurrentControlSet\Control\Session Manager\Environment\Path', \$path)
	|| warn "Unable to read PATH from registry: $!\n";

    $path = "$perlbin;$path" unless $path =~ m#\Q$perlbin\E#; #quote the path to avoid Unicode errors

    Set(HKEY_LOCAL_MACHINE, 'System\CurrentControlSet\Control\Session Manager\Environment\Path', $path, REG_EXPAND_SZ)
	|| warn "Unable to update PATH in registry: $!\n";
}

sub remove_html_shortcuts
{
    my ($key, $location);
    $key = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\\';
    $key .= Win32::IsWin95() ? 'Programs' : 'Common Programs';

    Get(HKEY_LOCAL_MACHINE, $key, \$location)
	|| warn 'Read of shortcut dir failed: '. Win32::FormatMessage(Win32::GetLastError()) ."\n";

    $location .= '/ActiveState ActivePerl';
    unlink("$location/Online Documentation.lnk");
    unlink($location);
}

sub Get
{
    my ($root, $key, $data) = @_;

    if (defined $$data) {warn "\$data set in Get!"}
    my $hkey;
    my $type;
    $key =~ s#(.*)\\(.*)$#$1#;
    my $value = $2;

    Win32API::Registry::RegOpenKeyEx($root, $key, 0, KEY_READ, $hkey)
	|| return undef;

    Win32API::Registry::RegQueryValueEx( $hkey, $value, [], $type, $$data, [])
	|| return undef;

    return 1;
}

sub Set
{
    my ($root, $key, $data, $type) = @_;
    my $hkey;
    $key =~ s#(.*)\\(.*)$#$1#;
    my $value = $2;

    Win32API::Registry::RegCreateKeyEx($root, $key, 0, '', REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, [], $hkey, [])
	|| return undef;

    if (defined $data) {
	my $olddata;

	if (! $type and Win32API::Registry::RegQueryValueEx($hkey, $value, [], $type, $olddata)) {
	    $type = REG_SZ;
	    warn "assuming type REG_SZ\n";
	}
	Win32API::Registry::RegSetValueEx($hkey, $value, 0, $type, $data, 0)
	    || return undef;
    }
    else {
	Win32API::Registry::RegDeleteValue($hkey, $value)
	    || return undef;
    }
    Win32API::Registry::RegCloseKey($hkey)
	|| return undef;

    return 1;
}

sub can_write {
    my $d = shift;
    my $ok = 0;
    my $file = $d;
    if (-d $d) {
	$file = "$d/foozle.$$";
    }
    $ok = open(TEST, ">", $file);
    close TEST;
    unlink($file) if $ok;
    return $ok;
}

__END__
:endofperl
