view release on metacpan or  search on metacpan

lib/Plack/Middleware/DBGp.pm  view on Meta::CPAN

sub _trap_connection_warnings {
    return if $_[0] =~ /^Unable to connect to Unix socket: /;
    return if $_[0] =~ /^Unable to connect to remote host: /;
    return if $_[0] =~ /^Running program outside the debugger/;

    print STDERR $_[0];
}

sub import {
    my ($class, %args) = @_;

    die "Specify either 'remote_host' or 'client_socket'"
        unless $args{remote_host} || $args{client_socket};

    $args{debug_client_path} //= do {
        require Devel::Debug::DBGp;

        Devel::Debug::DBGp->debugger_path;
    };

    $autostart = $args{autostart} // 1;
    $idekey = $args{ide_key};
    $cookie_expiration = $args{cookie_expiration} // 3600;

    my %options = (
          Xdebug         => 1,
          KeepRunning    => 1,
          ConnectAtStart => ($args{debug_startup} ? 1 : 0),
        ( LogFile        => $args{log_path} ) x !!$args{log_path},
    );

    if (!$args{remote_host}) {
        my $error;
        my ($user, $dbgp_client_dir) = @args{qw(user client_dir)};
        my $group = getgrnam($)) || (split / /, $))[0];

        if (!$user || !$dbgp_client_dir) {
            # pass through and hope for the best
        } elsif (-d $dbgp_client_dir) {
            my ($mode, $uid, $gid) = (stat($dbgp_client_dir))[2, 4, 5];
            my $user_id = getpwnam($user) || die "Can't retrieve the UID for $user";

            $error = sprintf "invalid UID %d, should be %d", $uid, $user_id
                unless $uid == $user_id;
            $error = sprintf "invalid GID %d, should be %d", $gid, $)
                unless $gid == $);
            $error = sprintf "invalid permissions bits %04o, should be 0770", $mode & 0777
                unless ($mode & 0777) == 0770;
        } else {
            $error = "directory not found";
        }

        if ($error) {
            print STDERR <<"EOT";
There was the following issue with the DBGp client directory '$dbgp_client_dir': $error

You can fix it by running:
\$ sudo sh -c 'rm -rf $dbgp_client_dir &&
      mkdir $dbgp_client_dir &&
      chmod 2770 $dbgp_client_dir &&
      chown $user:$group $dbgp_client_dir'
EOT
            exit 1;
        }

        $options{RemotePath} = $args{client_socket};
    } else {
        $options{RemotePort} = $args{remote_host};
    }

    $ENV{PERLDB_OPTS} =
        join " ", map +(sprintf "%s=%s", $_, $options{$_}),
                      sort keys %options;

    if ($args{enbugger}) {
        require Enbugger;

        Enbugger->VERSION(2.014);
        Enbugger->load_source;
    }

    my $inc_path = $args{debug_client_path};
    unshift @INC, ref $inc_path ? @$inc_path : $inc_path;
    {
        local $SIG{__WARN__} = \&_trap_connection_warnings;
        require 'perl5db.pl';
    }

    $^P = DEBUG_PREPARE_FLAGS;

    require Plack::Middleware;
    require Plack::Request;
    require Plack::Response;
    require Plack::Util;

    @ISA = qw(Plack::Middleware);
}

sub reopen_dbgp_connection {
    local $SIG{__WARN__} = \&_trap_connection_warnings;
    DB::connectOrReconnect();
    DB::enable() if DB::isConnected();
}

sub close_dbgp_connection {
    DB::answerLastContinuationCommand('stopped');
    DB::disconnect();
    DB::disable();
    # this works around uWSGI bug fixed by
    # https://github.com/unbit/uwsgi/commit/c6f61719106908b82ba2714fd9d2836fb1c27f22
    $^P = DEBUG_OFF;
}

sub call {
    my($self, $env) = @_;

    my ($stop_session, $start_session, $debug_idekey);
    if ($autostart) {
        $ENV{DBGP_IDEKEY} = $idekey if defined $idekey;

        reopen_dbgp_connection();