view release on metacpan or  search on metacpan

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

            }
        }
    }

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

sub get_varsrc
    {
    my ($class, $frame_ref, $package, $type) = @_ ;

    my @vars ;
    my $varsrc ;
    if ($type eq 'l')
        {
        ($varsrc) = $class -> get_locals($frame_ref+3) ;
        }
    elsif ($type eq 'a')
        {
        ($varsrc) = $class -> get_arguments($frame_ref+3) ;
        }
    elsif ($type eq 'g')
        {
        $varsrc = $class -> get_globals($package) ;
        }
    elsif ($type eq 's')
        {
        $varsrc = $class -> get_globals() ;
        }
    elsif ($type =~ /^eg:(.+)/)
        {
        $varsrc = $class -> get_var_eval ($1) ;
        }
    elsif ($type =~ /^el:(.+)/)
        {
        my $name = $1 ;
        my ($dummy, $varlocal) = $class -> get_locals($frame_ref+3) ;
        $varsrc = $class -> get_var_eval ($name, $varlocal) ;
        }
    elsif ($type =~ /^ea:(.+)/)
        {
        my $name = $1 ;
        my ($args, $varlocal) = $class -> get_arguments($frame_ref+3) ;
        $varsrc = $class -> get_var_eval ($name, $args, 'ea:') ;
        }

    use Data::Dump qw{pp} ;
    #print STDERR "vars ", pp ($varsrc),"\n" ;
    return $varsrc ;
    }

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

sub req_vars
    {
    my ($class, $params, $recurse) = @_ ;

    my $thread_ref  = $params -> {thread_ref} ;
    my $tid = defined ($Coro::current)?$Coro::current+0:1 ;
    if ($thread_ref != $tid && !$recurse && ($params -> {type} !~ /^eg:/))
        {
        my $coro  ;
        $coro = $class -> find_coro ($thread_ref) ;
        return { variables => [] } if (!$coro) ;
        my $ret ;
        $coro -> call (sub {
            $ret = $class -> req_vars ($params, $recurse + 1) ;
            }) ;
        return $ret ;
        }

    my $frame_ref   = $params -> {frame_ref} - $recurse ;
    my $package     = $params -> {'package'} ;
    my $type        = $params -> {type} ;
    my $filter      = $params -> {filter} ;
    my @vars ;

    my $varsrc = $class -> get_varsrc ($frame_ref, $package, $type) ;

    eval
        {
        $class -> get_vars ($varsrc, \@vars, $filter) ;
        } ;
    $class -> logger ($@) if ($@) ;

    return { variables => \@vars } ;
    }

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

sub _set_var_expr
    {
    my ($class, $type, $setvar, $expr_ref) = @_ ;

    if (!$type)
        {
        if ($setvar)
            {
            $$expr_ref = $setvar . '=' . $$expr_ref ;
            }
        return ;
        }

    my $refexpr ;
    if ($type =~ /^eg:(.+)/)
        {
        $refexpr = $1 ;
        my $ref = eval ($refexpr) ;
        return
            {
            name => "ERROR",
            value => $@,
            } if ($@) ;
        if (reftype ($ref) eq 'ARRAY')
            {
            $refexpr .= '[' . $setvar . ']' ;
            }
        elsif (reftype ($ref) eq 'HASH')
            {
            $refexpr .= '{' . $setvar . '}' ;
            }
        elsif (reftype ($ref) eq 'SCALAR')
            {
            $refexpr = '${' . $refexpr . '}' ;
            }
        else

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

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

sub req_setvar
    {
    my ($class, $params) = @_ ;

    my $thread_ref  = $params -> {thread_ref} ;
    my $tid = defined ($Coro::current)?$Coro::current+0:1 ;
    return undef if ($thread_ref != $tid) ;

    my $frame_ref   = $params -> {frame_ref} ;
    my $package     = $params -> {'package'} ;
    my $expression  = $params -> {'expression'} ;
    my $setvar      = $params -> {'setvar'} ;
    my $type        = $params -> {'type'} ;
    my @vars ;
    my $resultsrc ;
    my $varref ;
    my $varsrc = $class -> get_varsrc ($frame_ref, $package, $type) ;
    if (!exists $varsrc -> {$setvar})
        {
        return
            {
            name => "ERROR",
            value => "unknown variable: $setvar",
            } ;
        }
    $varref = $varsrc -> {$setvar}[0] ;
    eval
        {
        $resultsrc = $class -> get_eval_result ($frame_ref+2, $package, $expression) ;

        $$varref = ${$resultsrc -> {eval}[0]} ;
        } ;
    return
        {
        name => "ERROR",
        value => $@,
        } if ($@) ;

    return
        {
        name => $setvar,
        value => "$$varref",
        } ;
    }

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

sub req_evaluate
    {
    my ($class, $params, $recurse) = @_ ;

    return undef if ($params -> {'context'} eq 'hover' && ($params -> {'expression'} !~ /^\s*\\?[\$\@\%]/)) ;

    my $thread_ref  = $params -> {thread_ref} ;
    my $tid = defined ($Coro::current)?$Coro::current+0:1 ;
    if ($thread_ref != $tid && !$recurse)
        {
        my $coro  ;
        $coro = $class -> find_coro ($thread_ref) ;
        return undef if (!$coro) ;
        my $ret ;
        $coro -> call (sub {
            $ret = $class -> req_evaluate ($params, $recurse + 1) ;
            }) ;
        return $ret ;
        }

    my $frame_ref   = $params -> {frame_ref} - $recurse ;
    my $package     = $params -> {'package'} ;
    my $expression  = $params -> {'expression'} ;
    my @vars ;
    my $varsrc ;

    eval
        {
        $varsrc = $class -> get_eval_result ($frame_ref+2, $package, $expression) ;

        $class -> get_vars ($varsrc, \@vars) ;
        } ;
    return
        {
        name => "ERROR",
        value => $@,
        } if ($@) ;

    return $vars[0] ;
    }

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

sub req_threads
    {
    my @threads ;

    if (defined &Coro::State::list)
        {
        foreach my $coro (Coro::State::list())
            {
            push @threads,
                {
                name         => $coro->debug_desc,
                thread_ref   => $coro+0,
                } ;
            }
        }
    else
        {
        @threads = { thread_ref => 1, name => 'single'} ;
        }

    return { threads => \@threads } ;
    }

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


sub find_coro
    {
    my ($class, $pid) = @_;

    return if (!defined &Coro::State::list) ;

    if (my ($coro) = grep ($_ == $pid, Coro::State::list()))
        {
        return $coro ;
        }
    else
        {
        $class -> logger ("$pid: no such coroutine\n") ;
        }
    return ;
    }

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

sub req_stack
    {
    my ($class, $params, $recurse) = @_ ;

    my $thread_ref   = $params -> {thread_ref} ;
    my $tid = defined ($Coro::current)?$Coro::current+0:1 ;
    if ($thread_ref != $tid && !$recurse)
        {
        my $coro  ;
        $coro = $class -> find_coro ($thread_ref) ;
        return { stackFrames => [] } if (!$coro) ;
        my $ret ;
        $coro -> call (sub {
            $ret = $class -> req_stack ($params, 1) ;
            }) ;
        return $ret ;
        }

    my $levels       = $params -> {levels} || 999 ;
    my $start_frame  = $params -> {start} || 0 ;
    $start_frame += 3 ;
    my @stack ;
        {
        package DB;

        my $i = 0  ;

        my @frames ;
        while ((my @call_info = caller($i++)))
            {
            my $sub = $call_info[3] ;
            push @frames, \@call_info ;
            $frames[-2][3] = $sub if (@frames > 1);
            }
        $frames[-1][3] = '<main>' if (@frames > 0);

        my $n = @frames + 1 ;
        $i = $n ;
        my $j = -1 ;
        while (my $frame = shift @frames)
            {
            $i-- ;
            $j++ ;
            next if ($start_frame-- > 0) ;
            last if ($levels-- <= 0) ;

            my ($package, $filename, $line, $subroutine, $hasargs) = @$frame ;

            my $sub_name = $subroutine ;
            $sub_name = $1 if ($sub_name =~ /.+::(.+?)$/) ;

            my $frame =
                {
                frame_ref   => $j,
                name        => $sub_name,
                source      => { path => $filename },
                line        => $line,
                column      => 1,
                #moduleId    => $package,
                'package'   => $package,
                } ;
            $j-- if ($sub_name eq '(eval)') ;
            push @stack, $frame ;
            }
        }

    return { stackFrames => \@stack } ;
    }

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

sub _set_breakpoint
    {