view release on metacpan or  search on metacpan

lib/Perl/LanguageServer/DebuggerInterface.pm  view on Meta::CPAN

#

# client-specific pre/post-stop actions.
sub cprestop {}
sub cpoststop {}

# client complete startup
sub awaken {}

sub skippkg {
  my $s = shift;
  push @skippkg, @_ if @_;
}

sub evalcode {
  my ($client, $val) = @_;
  if (defined $val) {
    $running = 2;    # hand over to DB() to evaluate in its context
    $ineval->{$client} = $val;
  }
  return $ineval->{$client};
}

sub ready {
  my $s = shift;
  return $ready = 1;
}

# stubs

sub init {}
sub stop {}
sub idle {}
sub cleanup {}
sub output {}

#
# client init
#
for (@clients) { $_->init }

$SIG{'INT'} = \&DB::catch;

# disable this if stepping through END blocks is desired
# (looks scary and deconstructivist with Swat)
END { $ready = 0 }


##############################################################################

package Perl::LanguageServer::DebuggerInterface ;

#use DB;

our @ISA = qw(DB);

use strict ;

use IO::Socket ;
use JSON ;
use PadWalker ;
use Scalar::Util qw{blessed reftype looks_like_number};
use Hash::SafeKeys;
#use Data::Dump qw{pp} ;
use File::Basename ;
use vars qw{@dbline %dbline $dbline} ;

our $max_display = 5 ;
our $debug = 0 ;
our $session = $ENV{PLSDI_SESSION} || 1 ;
our $socket ;
our $json = JSON -> new -> utf8(1) -> ascii(1) ;
our @evalresult ;
our %postponed_breakpoints ;
our $breakpoint_id = 1 ;
our $loaded = 0 ;
our $break_reason ;
our $refresh ;

__PACKAGE__  -> register  ;
__PACKAGE__  -> init  ;

# ---------------------------------------------------------------------------

sub logger
    {
    my $class = shift ;
    print STDERR @_ ;
    }

# ---------------------------------------------------------------------------

use constant SPECIALS => { _ => 1, INC => 1, ARGV => 1, ENV => 1, ARGVOUT => 1, SIG => 1,
                            STDIN => 1, STDOUT => 1, STDERR => 1,
                            stdin => 1, stdout => 1, stderr => 1} ;

use vars qw{%entry @entry $entry %stab} ;

# ---------------------------------------------------------------------------

sub get_globals
    {
    my ($self, $package) = @_ ;

    my %vars ;

    my $specials = $package?0:1 ;
    $package ||= 'main' ;
    $package .= "::" unless $package =~ /::$/;
no strict ;
    *stab = *{"main::"};
    while ($package =~ /(\w+?::)/g)
        {
        *stab = ${stab}{$1};
        }
use strict ;
    my $key ;
    my $val ;

    while (($key, $val) = each (%stab))
        {

lib/Perl/LanguageServer/DebuggerInterface.pm  view on Meta::CPAN

        {
        $ref = $$ref ;
        #print STDERR "deref ----> ref val=$refexpr ref=$ref refref=", ref ($ref), "reftype=", reftype ($ref), "\n" ;
        $pre = '${' ;
        $post = '}' ;
        }
    if (reftype ($ref) eq 'ARRAY')
        {
        my $n = 0 ;
        foreach my $entry (@$ref)
            {
            $vars{"$n"} = [\$entry, $prefix . $pre . '(' . $refexpr . ')' . $post . '->[' . $n . ']' ] ;
            $n++ ;
            }
        }
    elsif (reftype ($ref) eq 'HASH')
        {
        my $iterator = Hash::SafeKeys::save_iterator_state($ref);
        foreach my $entry (sort keys %$ref)
            {
            $vars{"$entry"} = [\$ref -> {$entry}, $prefix . $pre . '(' . $refexpr . ')' . $post . "->{'" . $entry . "'}" ] ;
            }
        Hash::SafeKeys::restore_iterator_state($ref, $iterator);
        }
    else
        {
        $vars{'$'} = [$ref] ;
        }

    return \%vars ;
    }

# ---------------------------------------------------------------------------

sub get_arguments
    {
    my ($self, $frame) = @_ ;

    my $vars  ;
    my %varsrc ;
    eval
        {
        my @args = _get_caller_args ($frame+2) ;
        $varsrc{"\@_"} =    [\@args, "ea:\$varsrc->{'\@_'}[0]"] ;
        $varsrc{"\@ARGV"} = [\@main::ARGV, 'eg:\\@main::ARGV'] ;
        } ;
    $self -> logger ($@) if ($@) ;
    return (\%varsrc) ;
    }

# ---------------------------------------------------------------------------

sub get_locals
    {
    my ($self, $frame) = @_ ;

    my $vars  ;
    my %varsrc ;
    eval
        {
        $vars = PadWalker::peek_my ($frame) ;
        foreach my $var (keys %$vars)
            {
            $varsrc{$var} =
                [
                $vars->{$var},
                "el:\$varsrc->{'$var'}"
                ] ;
            }
        } ;
    $self -> logger ($@) if ($@) ;
    return (\%varsrc, $vars) ;
    }

# ---------------------------------------------------------------------------

sub _get_caller_args
    {
    my ($caller) = @_ ;

    local @DB::args ;

    my @caller_args ;
        {
        package DB;

        my @call_info = caller ($caller) ;
        #use Data::Dump qw{pp} ;
        #print STDERR "db::args after caller $caller ", pp(\@DB::args), "\n" ;
        @caller_args = @DB::args ;
        }

    return @caller_args ;
    }

# ---------------------------------------------------------------------------

sub _eval_replace
    {
    my ($___di_vars, $___di_sigil, $___di_var, $___di_suffix, $___di_frame) = @_ ;

    #print STDERR "sigil = $___di_sigil var = $___di_var suffix = $___di_suffix\n" ;

    if ($___di_var eq '_')
        {
        my @args = _get_caller_args ($___di_frame + 3) ;
        $___di_vars -> {'@_'} = \@args ;
        }
    #use Data::Dump qw{pp} ;
    #print STDERR "vars ", pp ($___di_vars),"\n" ;
    if ($___di_suffix)
        {
        return "\$___di_vars->{'\%$___di_var'}{" if ($___di_suffix eq '{' && exists $___di_vars->{"\%$___di_var"}) ;
        return "\$___di_vars->{'\@$___di_var'}[" if (exists $___di_vars->{"\@$___di_var"});
        }
    else
        {
        return "\$\#\{\$___di_vars->{'\@$1'}}" if (($___di_var =~ /^#(.+)/) && exists $___di_vars->{"\@$1"}) ;
        #print STDERR "v = $___di_var  1 = $1\n" ;
        return "$___di_sigil\{\$___di_vars->{'$___di_sigil$___di_var'}}" if (exists $___di_vars->{"$___di_sigil$___di_var"}) ;
        }

    return "$___di_sigil$___di_var$___di_suffix" ;
    }

# ---------------------------------------------------------------------------

sub get_eval_result
    {
    my ($self, $frame, $package, $expression) = @_;

    my $___di_vars = PadWalker::peek_my ($frame) ;

    $expression =~ s/([\%\@\$])(#?\w+)\s*([\[\{])?/_eval_replace($___di_vars, $1, $2, $3, $frame)/eg ;

    my $code = "package $package ; no strict ; $expression";
    my %vars ;
    #print STDERR "frame=$frame code = $code\n" ;


    my @result = eval $code;
    if ($@)
        {
        $vars{'ERROR'} = [$@] ;
        }
    else
        {
        if (@result < 2)
            {
            if (ref ($result[0]) eq 'REF')
                {
                push @evalresult, $result[0] ;
                }
            else
                {
                push @evalresult, \$result[0] ;
                }
            }
        elsif ($expression =~ /^\s*\\?\s*\%/)
            {
            push @evalresult, { @result } ;
            }
        else
            {
            push @evalresult, \@result ;
            }
        $vars{'eval'} = [$evalresult[-1], 'eg:$Perl::LanguageServer::DebuggerInterface::evalresult[' . $#evalresult . ']'] ;
        }

    return \%vars ;
    }

# ---------------------------------------------------------------------------

 sub get_scalar
    {
    my $ret = eval
        {
        my ($self, $val) = @_ ;

        return 'undef' if (!defined ($val)) ;
        my $obj = '' ;
        $obj = blessed ($val) . ' ' if (blessed ($val)) ;
        return $obj . '[..]' if (ref ($val) eq 'ARRAY') ;
        return $obj . '{..}' if (ref ($val) eq 'HASH') ;
        my $isnum = looks_like_number ($val);
        $obj . ($isnum?$val:"'$val'") ;
        } ;
    return $@ if ($@) ;
    return $ret ;
    }