view release on metacpan or  search on metacpan

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

                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
    {
    my ($class, $location, $condition) = @_ ;

    $condition ||= '1';
    my $subname ;
    my $filename ;
    ($location, $subname, $filename) = DB::_find_subline($location) if ($location =~ /\D/);

    return (0, "Subroutine not found.") unless $location ;
    return (0) if (!$location) ;

    local *dbline = "::_<$filename" if ($filename) ;
    for (my $line = $location; $line <= $location + 10 && $location < @dbline; $line++)
        {
        if ($dbline[$line] != 0)
            {
            $dbline{$line+0} =~ s/^[^\0]*/$condition/;
            return (1, undef, $line, $filename) ;
            }
        }

    return (0, "Line $location for sub $subname is not breakable.") if ($subname) ;
    return (0, "Line $location is not breakable.") ;
    }

# ---------------------------------------------------------------------------
# abs path no dereference
# copied from package Cwd::Ext and added directory argument
sub abs_path_nd {
   my $abs_path = shift;
   my $dir      = shift ;
   return $abs_path if $abs_path=~m{^/$};

   unless( $abs_path=~/^\// ){
      if ($dir) {
          $abs_path = $dir."/$abs_path";
      }
      else {
          require Cwd;
          $abs_path = Cwd::cwd()."/$abs_path";
      }
   }

    my @elems = split m{/}, $abs_path;
    my $ptr = 1;
    while($ptr <= $#elems){
        if($elems[$ptr] eq ''      ){
            splice @elems, $ptr, 1;
        }

        elsif($elems[$ptr] eq '.'  ){
            splice @elems, $ptr, 1;
        }

        elsif($elems[$ptr] eq '..' ){
            if($ptr < 2){
                splice @elems, $ptr, 1;
            }
            else {
                $ptr--;
                splice @elems, $ptr, 2;
            }
        }
        else {
            $ptr++;
        }
    }

    $#elems ? join q{/}, @elems : q{/};
}

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

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

    my $breakpoints  = $params -> {breakpoints} ;
    my $filename     = $params -> {filename} ;
    my $real_filename = $params -> {dbg_filename} || $filename ;

    Class::Refresh -> refresh if ($refresh) ;

    if ($filename)
        {
        my %seen ;
        while (!defined $main::{'_<' . $real_filename} && -l $real_filename)
            {
            my $dir = File::Basename::dirname ($real_filename) ;
            $real_filename = readlink ($real_filename) ;
            last if (!$real_filename) ;
            $real_filename = abs_path_nd ($real_filename, $dir) ;
            last if ($seen{$real_filename}++) ;
            }

        if (!defined $main::{'_<' . $real_filename})
            {
            $postponed_breakpoints{$filename} = $breakpoints ;
            foreach my $bp (@$breakpoints)
                {
                $bp -> [6] = $breakpoint_id++ ;
                }
            return { breakpoints => $breakpoints }
            }