Ticket #1469: 06-initialize.t

File 06-initialize.t, 2.0 KB (added by bowtie, 16 months ago)
Line 
1#!/usr/bin/env perl
2
3use 5.010;
4use strict;
5use warnings FATAL => 'all';
6
7use English qw( -no_match_vars ); # Avoids regex performance penalty
8local $OUTPUT_AUTOFLUSH = 1;
9
10if ( $OSNAME =~ /Win32/i ) {
11    require Win32::Process;
12    require Win32;
13}
14use constant NORMALPRIORITYCLASS => 0x00000020;
15
16use Test::More tests => 4;
17use Test::Deep;
18
19use File::Temp qw(tempdir);
20my ( $host, $port, $porto, $listen, $reuse_addr );
21SCOPE: {
22    $host  = 'localhost';
23    $port  = 24642;
24    $porto = 'tcp';
25
26    # $listen     = 'SOMAXCONN';
27    $listen     = 1;
28    $reuse_addr = 1;
29    my ( $dir, $pid ) = run_perl5db( 't/eg/05-io.pl', $host, $port );
30    require Debug::Client;
31    ok( my $debugger = Debug::Client->new(
32            host   => $host,
33            port   => $port,
34            porto  => $porto,
35            listen => $listen,
36            reuse  => $reuse_addr
37        ),
38        'initialize with prams'
39    );
40    $debugger->run;
41    ok( $debugger->quit, 'quit with prams' );
42
43    if ( $OSNAME =~ /Win32/i ) {
44        $pid->Kill(0) or die "Cannot kill '$pid'";
45    }
46}
47
48SCOPE: {
49    $host = 'localhost';
50    $port = 24642;
51    my ( $dir, $pid ) = run_perl5db( 't/eg/05-io.pl', $host, $port );
52    require Debug::Client;
53    ok( my $debugger = Debug::Client->new(), 'initialize without prams' );
54    $debugger->run;
55    ok( $debugger->quit, 'quit witout prams' );
56    if ( $OSNAME =~ /Win32/i ) {
57        $pid->Kill(0) or die "Cannot kill '$pid'";
58    }
59}
60
61sub run_perl5db {
62    my ( $file, $host, $port ) = @_;
63    my $dir = tempdir( CLEANUP => 0 );
64    my $path = $dir;
65    my $pid;
66    if ( $OSNAME =~ /Win32/i ) {
67
68        $path = Win32::GetLongPathName($path);
69        local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port";
70
71        Win32::Process::Create(
72            $pid,
73            $EXECUTABLE_NAME,
74            qq(perl -d $file > "$path/out" 2> "$path/err"),
75            1,
76            NORMALPRIORITYCLASS,
77            '.',
78        ) or die Win32::FormatMessage( Win32::GetLastError() );
79
80    } else {
81        $pid = fork();
82        die if not defined $pid;
83        if ( not $pid ) {
84            local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port";
85            sleep 1;
86            exec qq($EXECUTABLE_NAME -d $file > "$path/out" 2> "$path/err");
87            exit 0;
88        }
89    }
90    return ( $dir, $pid );
91}
92
93done_testing();