@rem = '--*-Perl-*--
@echo off
if "%OS%" == "Windows_NT" goto WinNT
perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
:WinNT
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
#line 15
##########################################################################
# PROGRAM    DebuggerSetup.pl
# AUTHOR     DaveS@ActiveState.com
#            DougL@ActiveState.com
# ORIG       August 11, 2000
# COPYRIGHT  Copyright, (c) 2000 ActiveState Tool Corp
#            All Rights Reserved
##########################################################################
# REVISION HISTORY
#
# 11/08/2000 Original - based on PerlSockSetup by DougL
##########################################################################

use strict;
use warnings;
use Config;
use Getopt::Long;
use Win32;
eval "use Win32::Service";
use Win32API::Registry (':ALL');

my $version = "1.0";
my $localDB = "BEGIN {require '". Win32::GetShortPathName ($Config{installbin}) ."\\PerlDB.pl'}";
my $stockDB = "BEGIN  {require q<". Win32::GetShortPathName ($Config{installbin}) ."\\PerlDB.pl> }";
my $remoteDB= "BEGIN {require '". Win32::GetShortPathName ($Config{installprivlib}) ."\\perl5db.pl'}";
my $dirty = 0;

my $usage = <<"EOT";
Usage: DebuggerSetup [-local] [-remote] [-ip=x.x.x.x] [-port[=portnumber]] [-help]

where
  -local        debugger is setup to only debug local scripts. Can't be
                used with the -remote flag.

  -remote       debugger is setup to debug local and remote scripts. Can't
                be used with the -local flag.

  -ip[=x.x.x.x] this is the IP address of the computer running the GUI part of
                the ActiveState Perl debugger. An empty value listens on all
                IP addresses.

  -port[=port]  this is the port number that the GUI part of the ActiveState
                Perl debugger is listening on. (Default 2000)

  -help         display this message.

DebuggerSetup -l
  -runs the the ActiveState Perl debugger in local mode

DebuggerSetup -r -i=192.168.1.3 -p
  -debugger in remote mode, listening on IP address 192.168.1.3, port 2000
EOT

my %opts;

Getopt::Long::Configure("ignore_case", "auto_abbrev");

GetOptions(\%opts, 'ip:s', 'port:s', 'remote', 'local', 'help|?') ||
    ($opts{help}=1);

if ($opts{remote} and $opts{local}) {
    print "Conflicting options. Only -remote or -local may be set.\n";
    $opts{help}=1;
}

if ($opts{help}) {
    print $usage;
    exit;
}

if ($opts{remote}) {
    Remote();
    $dirty|=1;
}

if ($opts{local}) {
    Local();
    $dirty|=2;
}

if (defined $opts{ip}) {
    IP();
    $dirty|=4;
}

if (defined $opts{port} and $opts{port} eq '') {$opts{port}=2000} #default to 2000
if ($opts{port}) {
    Port();
    $dirty|=8;
}

#now print out current config
print "Current debugger config:\n";

my $curDB;
Get(HKEY_LOCAL_MACHINE, 'Software\Perl\PERL5DB', \$curDB)
    || die "Unable to read current config. It may not exist!\n";
#Read HKLM\Software\Perl\PERL5DB\PERL5DB failed: '. Win32::FormatMessage(Win32::GetLastError()) ."\n";

if ($curDB eq $localDB or $curDB eq $stockDB) {
    print "Debugger is set to local mode.\n";
} elsif ($curDB eq $remoteDB or $curDB eq '') {
    print "Debugger is set to remote mode.\n";
    my $IP;
    Get(HKEY_LOCAL_MACHINE, 'Software\ActiveState\PerlSock\1.0\Debugger\IP', \$IP)
	|| die 'Read IP failed.'. Win32::FormatMessage(Win32::GetLastError()) ."\n";
    my $Port;
    Get(HKEY_LOCAL_MACHINE, 'Software\ActiveState\PerlSock\1.0\Debugger\Port', \$Port)
	|| die 'Read Port failed.'. Win32::FormatMessage(Win32::GetLastError()) ."\n";

    if (! $IP) {
	$IP = (gethostbyname('localhost'))[0];
    }

    if ($IP eq '127.0.0.1' or $IP =~ /localhost/i) {
	print <<here; 
*** ATTENTION ***
The debugger will only accept connections from the local machine, which is
useful for debugging of PerlApp, PerlCOM, PerlCtrl, and PerlSvc.
If you wish to debug Perl processes from remote machines, please rerun
DebuggerSetup with the -i option.
*** ATTENTION ***
here
    }
    print "Debugger is listening for connections to: $IP:$Port\n\n";
    print "Set the PERLDB_OPTS environment variable on the remote machine like this:\n";
    print "\tPERLDB_OPTS=RemotePort=$IP:$Port\n";
} 
else {
    print "Debugger is in an unknown mode.\n";
}

if ( (($dirty & 4) or ($dirty & 8)) and Win32::IsWinNT()) {
    my %status;
    my $ok = Win32::Service::GetStatus( '', 'PerlSock', \%status );

    $ok || die "Unable to enumerate services: $!\n";

    if ($status{'CurrentState'} == 4 ) {
	$ok = Win32::Service::StopService('', 'PerlSock');
	sleep 2; # StopService needs some time to finish before the StartService below
	$ok || die "Unable to stop PerlSock (PDK Debugger listener): $!\n";
    }

    $ok = Win32::Service::StartService('', 'PerlSock');

    $ok || die "Unable to start PerlSock (PDK Debugger listener): $!\n";
}
elsif (($dirty & 4) or ($dirty & 8)) {
    print "The settings for PerlSock (PDK Debugger listener) have changed.\n",
	  "Please either restart PerlSock (PDK Debugger listener)\n",
	  "or reboot your computer.\n";
}

#Subs below
sub Local
{
    Set(HKEY_LOCAL_MACHINE, 'Software\Perl\PERL5DB', $localDB)
	|| die 'Error setting Perl5DB: '. Win32::FormatMessage(Win32::GetLastError()) ."\n";
    print "Setting Local mode.\n";
}

sub Remote
{
    my $data;
    Set(HKEY_LOCAL_MACHINE, 'Software\Perl\PERL5DB', $remoteDB)
	|| die 'Error setting Perl5DB: '. Win32::FormatMessage(Win32::GetLastError()) ."\n";
    print "Setting Remote mode.\n";
}

sub IP
{
    Set(HKEY_LOCAL_MACHINE, 'SOFTWARE\ActiveState\PerlSock\1.0\Debugger\IP', $opts{ip})
	|| die 'Error setting PerlSock IP: '. Win32::FormatMessage(Win32::GetLastError()) ."\n";
    print "Setting IP address: ". $opts{ip} ."\n";
}

sub Port
{
    Set(HKEY_LOCAL_MACHINE, 'SOFTWARE\ActiveState\PerlSock\1.0\Debugger\Port', $opts{port})
	|| die 'Error setting PerlSock Port: '. Win32::FormatMessage(Win32::GetLastError()) ."\n";
    print "Setting Port: ". $opts{port} ."\n";
}

sub SetPERL5DB
{
    my $entry = shift;

    print 'Trying to set HKCU\Software\Perl\PERL5DB registry entry ... ';
    if (Set(HKEY_LOCAL_MACHINE, 'Software\Perl\PERL5DB', $entry)) {
	print "Success!\n";
    } else {
	print "Failed!\n";
	print 'Error: '. Win32::FormatMessage(Win32::GetLastError()) ."\n\n";
	print "You need access to modify the registry.\n";
	return undef;
    }
    return 1;
}

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) = @_;
    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 ($type, $olddata);

	if (!Win32API::Registry::RegQueryValueEx($hkey, $value, [], $type, $olddata)) {
	    $type = REG_SZ;
	}
	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;
}

__END__
:endofperl
