#
# We include DB package from perl core here, to be able to modify it...
#

package DB;

# "private" globals

my ($running, $ready, $deep, $usrctxt, $evalarg,
    @stack, @saved, @skippkg, @clients);
my $preeval = {};
my $posteval = {};
my $ineval = {};

####
#
# Globals - must be defined at startup so that clients can refer to
# them right after a C<require DB;>
#
####

BEGIN {

  # these are hardcoded in perl source (some are magical)

  $DB::sub = '';        # name of current subroutine
  %DB::sub = ();        # "filename:fromline-toline" for every known sub
  $DB::single = 0;      # single-step flag (set it to 1 to enable stops in BEGIN/use)
  $DB::signal = 0;      # signal flag (will cause a stop at the next line)
  $DB::trace = 0;       # are we tracing through subroutine calls?
  @DB::args = ();       # arguments of current subroutine or @ARGV array
  @DB::dbline = ();     # list of lines in currently loaded file
  %DB::dbline = ();     # actions in current file (keyed by line number)
  @DB::ret = ();        # return value of last sub executed in list context
  $DB::ret = '';        # return value of last sub executed in scalar context

  # other "public" globals

  $DB::package = '';    # current package space
  $DB::filename = '';   # current filename
  $DB::subname = '';    # currently executing sub (fully qualified name)
  $DB::lineno = '';     # current line number

  $DB::VERSION = $DB::VERSION = '1.07';

  # initialize private globals to avoid warnings

  $running = 1;         # are we running, or are we stopped?
  @stack = (0);
  @clients = ();
  $deep = 1000;
  $ready = 0;
  @saved = ();
  @skippkg = ();
  $usrctxt = '';
  $evalarg = '';

  # scan args for stdin redirect
  for (my $i=0; $i <= $#ARGV; $i++) {
    if ($ARGV[$i] eq "<" && $i < $#ARGV) {
      # open stdin from file
      open STDIN, "<", $ARGV[$i+1] or die "open stdin";
      # remove from ARGV
      splice @ARGV, $i, 2;
    }
  }
}

####
# entry point for all subroutine calls
#
sub sub {

  # this is important, othwise return values might be corrupted...
  return &$DB::sub if (!$DB::single) ;

  push(@stack, $DB::single);
  $DB::single &= 1;
  $DB::single |= 4 if $#stack == $deep;
  if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
    &$DB::sub;
    $DB::single |= pop(@stack);
    $DB::ret = undef;
  }
  elsif (wantarray) {
    @DB::ret = &$DB::sub;
    $DB::single |= pop(@stack);
    @DB::ret;
  }
  else {
    $DB::ret = &$DB::sub;
    $DB::single |= pop(@stack);
    $DB::ret;
  }
}

####
# this is called by perl for every statement
#
sub DB {
  return unless $ready;
  &save;
  ($DB::package, $DB::filename, $DB::lineno) = caller;

  return if @skippkg and grep { $_ eq $DB::package } @skippkg;

  $usrctxt = "package $DB::package;";		# this won't let them modify, alas
  local(*DB::dbline) = "::_<$DB::filename";

  my ($stop, $action);
  if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
    if ($stop eq '1') {
      $DB::signal |= 1;
    }
    else {
      $stop = 0 unless $stop;			# avoid un_init warning
      $evalarg = "\$DB::signal |= do { $stop; }"; &eval;
      $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/;    # clear any temp breakpt
    }
  }
  if ($DB::single || $DB::trace || $DB::signal) {
    $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
    DB->loadfile($DB::filename, $DB::lineno);
  }
  $evalarg = $action, &eval if $action;
  if ($DB::single || $DB::signal) {
    _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
    $DB::single = 0;
    $DB::signal = 0;
    $running = 0;

    &eval if ($evalarg = DB->prestop);
    my $c;
    for $c (@clients) {
      # perform any client-specific prestop actions
      &eval if ($evalarg = $c->cprestop);

      # Now sit in an event loop until something sets $running
      do {
    $c->idle;                     # call client event loop; must not block
    if ($running == 2) {          # client wants something eval-ed
      &eval if ($evalarg = $c->evalcode);
      $running = 0;
    }
      } until $running;

      # perform any client-specific poststop actions
      &eval if ($evalarg = $c->cpoststop);
    }
    &eval if ($evalarg = DB->poststop);
  }
  ($@, $!, $,, $/, $\, $^W) = @saved;
  ();
}

####
# this takes its argument via $evalarg to preserve current @_
#
sub eval {
  ($@, $!, $,, $/, $\, $^W) = @saved;
  eval "$usrctxt $evalarg; &DB::save";
  _outputall($@) if $@;
}

###############################################################################
#         no compile-time subroutine call allowed before this point           #
###############################################################################

use strict;                # this can run only after DB() and sub() are defined

sub save {
  @saved = ($@, $!, $,, $/, $\, $^W);
  $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}

sub catch {
  for (@clients) { $_->awaken; }
  $DB::signal = 1;
  $ready = 1;
}

####
#
# Client callable (read inheritable) methods defined after this point
#
####

sub register {
  my $s = shift;
  $s = _clientname($s) if ref($s);
  push @clients, $s;
}

sub done {
  my $s = shift;
  $s = _clientname($s) if ref($s);
  @clients = grep {$_ ne $s} @clients;
  $s->cleanup;
#  $running = 3 unless @clients;
  exit(0) unless @clients;
}

sub _clientname {
  my $name = shift;
  "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
  return $1;
}

sub next {
  my $s = shift;
  $DB::single = 2;
  $running = 1;
}

sub step {
  my $s = shift;
  $DB::single = 1;
  $running = 1;
}

sub cont {
  my $s = shift;
  my $i = shift;
  $s->set_tbreak($i) if $i;
  for ($i = 0; $i <= $#stack;) {
    $stack[$i++] &= ~1;
  }
  $DB::single = 0;
  $running = 1;
}

####
# XXX caller must experimentally determine $i (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub ret {
  my $s = shift;
  my $i = shift;      # how many levels to get to DB sub
  $i = 0 unless defined $i;
  $i -= $#stack-$i if ($#stack-$i < 0) ;
  $stack[$#stack-$i] |= 1;
  $DB::single = 0;
  $running = 1;
}

####
# XXX caller must experimentally determine $start (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub backtrace {
  my $self = shift;
  my $start = shift;
  my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
  $start = 1 unless $start;
  for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
    @a = @DB::args;
    for (@a) {
      s/'/\\'/g;
      s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
      s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
      s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
    }
    $w = $w ? '@ = ' : '$ = ';
    $a = $h ? '(' . join(', ', @a) . ')' : '';
    $e =~ s/\n\s*\;\s*\Z// if $e;
    $e =~ s/[\\\']/\\$1/g if $e;
    if ($r) {
      $s = "require '$e'";
    } elsif (defined $r) {
      $s = "eval '$e'";
    } elsif ($s eq '(eval)') {
      $s = "eval {...}";
    }
    $f = "file '$f'" unless $f eq '-e';
    push @ret, "$w&$s$a from $f line $l";
    last if $DB::signal;
  }
  return @ret;
}

sub _outputall {
  my $c;
  for $c (@clients) {
    $c->output(@_);
  }
}

sub trace_toggle {
  my $s = shift;
  $DB::trace = !$DB::trace;
}


####
# without args: returns all defined subroutine names
# with subname args: returns a listref [file, start, end]
#
sub subs {
  my $s = shift;
  if (@_) {
    my(@ret) = ();
    while (@_) {
      my $name = shift;
      push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
    if exists $DB::sub{$name};
    }
    return @ret;
  }
  return keys %DB::sub;
}

####
# first argument is a filename whose subs will be returned
# if a filename is not supplied, all subs in the current
# filename are returned.
#
sub filesubs {
  my $s = shift;
  my $fname = shift;
  $fname = $DB::filename unless $fname;
  return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
}

####
# returns a list of all filenames that DB knows about
#
sub files {
  my $s = shift;
  my(@f) = grep(m|^_<|, keys %main::);
  return map { substr($_,2) } @f;
}

####
# returns reference to an array holding the lines in currently
# loaded file
#
sub lines {
  my $s = shift;
  return \@DB::dbline;
}

####
# loadfile($file, $line)
#
sub loadfile {
  my $s = shift;
  my($file, $line) = @_;
  if (!defined $main::{'_<' . $file}) {
    my $try;
    if (($try) = grep(m|^_<.*$file|, keys %main::)) {
      $file = substr($try,2);
    }
  }
  if (defined($main::{'_<' . $file})) {
    my $c;
#    _outputall("Loading file $file..");
    *DB::dbline = "::_<$file";
    $DB::filename = $file;
    for $c (@clients) {
#      print "2 ", $file, '|', $line, "\n";
      $c->showfile($file, $line);
    }
    return $file;
  }
  return undef;
}

sub lineevents {
  my $s = shift;
  my $fname = shift;
  my(%ret) = ();
  my $i;
  $fname = $DB::filename unless $fname;
  local(*DB::dbline) = "::_<$fname";
  for ($i = 1; $i <= $#DB::dbline; $i++) {
    $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})]
      if defined $DB::dbline{$i};
  }
  return %ret;
}

sub set_break {
  my $s = shift;
  my $i = shift;
  my $cond = shift;
  $i ||= $DB::lineno;
  $cond ||= '1';
  $i = _find_subline($i) if ($i =~ /\D/);
  $s->output("Subroutine not found.\n") unless $i;
  if ($i) {
    if ($DB::dbline[$i] == 0) {
      $s->output("Line $i not breakable.\n");
    }
    else {
      $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
    }
  }
}

sub set_tbreak {
  my $s = shift;
  my $i = shift;
  $i = _find_subline($i) if ($i =~ /\D/);
  $s->output("Subroutine not found.\n") unless $i;
  if ($i) {
    if ($DB::dbline[$i] == 0) {
      $s->output("Line $i not breakable.\n");
    }
    else {
      $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
    }
  }
}

sub _find_subline {
  my $name = shift;
  $name =~ s/\'/::/;
  $name = "${DB::package}\:\:" . $name if $name !~ /::/;
  $name = "main" . $name if substr($name,0,2) eq "::";
  my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
  if ($from) {
    local *DB::dbline = "::_<$fname";
    ++$from while $DB::dbline[$from] == 0 && $from < $to;
    return wantarray?($from, $name, $fname):$from;
  }
  return undef;
}

sub clr_breaks {
  my $s = shift;
  my $i;
  if (@_) {
    while (@_) {
      $i = shift;
      $i = _find_subline($i) if ($i =~ /\D/);
      $s->output("Subroutine not found.\n") unless $i;
      if (defined $DB::dbline{$i}) {
        $DB::dbline{$i} =~ s/^[^\0]+//;
        if ($DB::dbline{$i} =~ s/^\0?$//) {
          delete $DB::dbline{$i};
        }
      }
    }
  }
  else {
    for ($i = 1; $i <= $#DB::dbline ; $i++) {
      if (defined $DB::dbline{$i}) {
        $DB::dbline{$i} =~ s/^[^\0]+//;
        if ($DB::dbline{$i} =~ s/^\0?$//) {
          delete $DB::dbline{$i};
        }
      }
    }
  }
}

sub set_action {
  my $s = shift;
  my $i = shift;
  my $act = shift;
  $i = _find_subline($i) if ($i =~ /\D/);
  $s->output("Subroutine not found.\n") unless $i;
  if ($i) {
    if ($DB::dbline[$i] == 0) {
      $s->output("Line $i not actionable.\n");
    }
    else {
      $DB::dbline{$i} =~ s/\0[^\0]*//;
      $DB::dbline{$i} .= "\0" . $act;
    }
  }
}

sub clr_actions {
  my $s = shift;
  my $i;
  if (@_) {
    while (@_) {
      my $i = shift;
      $i = _find_subline($i) if ($i =~ /\D/);
      $s->output("Subroutine not found.\n") unless $i;
      if ($i && $DB::dbline[$i] != 0) {
    $DB::dbline{$i} =~ s/\0[^\0]*//;
    delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
      }
    }
  }
  else {
    for ($i = 1; $i <= $#DB::dbline ; $i++) {
      if (defined $DB::dbline{$i}) {
    $DB::dbline{$i} =~ s/\0[^\0]*//;
    delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
      }
    }
  }
}

sub prestop {
  my ($client, $val) = @_;
  return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
}

sub poststop {
  my ($client, $val) = @_;
  return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
}

#
# "pure virtual" methods
#

# 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))
        {
        next if ($key eq '_') ;
        next if ($key =~ /^_</) ;
        next if ($key =~ /::$/) ;
        next if ($key eq 'stab') ;
        next if (!$specials && (SPECIALS -> {$key} || ($key !~ /^[a-zA-Z_]/))) ;
        next if ($specials && (!SPECIALS -> {$key} && ($key =~ /^[a-zA-Z_]/))) ;

        local(*entry) = $val;
        $key =~ s/([\0-\x1f])/'^'.chr(ord($1)+0x40)/eg ;

        $vars{"\$$key"} = [\$entry, 'eg:\\$' . $package . $key] if (defined $entry) ;
        $vars{"\@$key"} = [\@entry, 'eg:\\@' . $package . $key] if (@entry) ;
        $vars{"\%$key"} = [\%entry, 'eg:\\%' . $package . $key] if (%entry) ;
        #$vars{"\&$key"} = \&entry if (defined &entry) ;
        my $fileno;
        $vars{"Handle:$key"} = [\"fileno=$fileno"] if (defined ($fileno = eval{fileno(*entry)})) ;
        }

    return \%vars ;
    }

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

sub get_var_eval
    {
    my ($self, $name, $varsrc, $prefix) = @_ ;

    # use Data::Dump qw{pp} ;
    # print STDERR "eval ", pp([$name, $varsrc]), "\n" ;
    my %vars ;

    $prefix ||= $varsrc?'el:':'eg:' ;
    my $refexpr ;
    my $pre ;
    my $post ;
    $refexpr = $name ;
    my $ref = eval ($refexpr) ;
    if ($@)
        {
        $vars{'ERROR'} = [$@] ;
        }
    #print STDERR "name=$name ref=$ref refref=", ref ($ref), "reftype=", reftype ($ref), "\n", pp($ref), "\n" ;
    if (ref ($ref) eq 'REF')
        {
        $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 ;
    }

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

sub get_vars
    {
    my ($self, $varsrc, $vars, $array) = @_ ;

    foreach my $k (sort { $array?$a <=> $b:$a cmp $b } keys %$varsrc)
        {
        my $key = $k ;
        my $val = $varsrc -> {$k}[0] ;
        my $ref = $varsrc -> {$k}[1] ;
        $key =~ s/([\0-\x1f])/'^'.chr(ord($1)+0x40)/eg ;
        #print STDERR "k=$k val=$val ref=$ref refref=", ref ($val), "reftype=", reftype ($ref), "\n" ;

        if (ref ($val) eq 'REF')
            {
            $val = $$val ;
            #print STDERR "deref ----> ref val=$val ref=$ref refref=", ref ($val), "reftype=", reftype ($ref), "\n" ;
            }
        my $obj = '' ;
        $obj = blessed ($val) . ' ' if (blessed ($val)) ;

        if (reftype ($val) eq 'SCALAR')
            {
            push @$vars,
                {
                name  => $key,
                value => $obj . $self -> get_scalar ($$val),
                type  => 'Scalar',
                } ;
            }

        if (reftype ($val) eq 'ARRAY')
            {
            my $display = $obj . '[' ;
            my $n       = 1 ;
            foreach (@$val)
                {
                $display .= ',' if ($n > 1) ;
                $display .= $self -> get_scalar ($_) ;
                if ($n++ >= $max_display)
                    {
                    $display .= ',...' ;
                    last ;
                    }
                }
            $display .= ']' ;

            push @$vars,
                {
                name  => $key,
                value => $display,
                type  => 'Array',
                var_ref => $ref,
                indexedVariables => scalar (@$val),
                } ;
            }

        if (reftype ($val) eq 'HASH')
            {
            my $display = $obj . '{' ;
            my $n       = 1 ;
            my $iterator = Hash::SafeKeys::save_iterator_state($val);
            foreach (sort keys %$val)
                {
                $display .= ',' if ($n > 1) ;
                $display .= "$_=>" . $self -> get_scalar ($val->{$_}) ;
                if ($n++ >= $max_display / 2)
                    {
                    $display .= ',...' ;
                    last ;
                    }
                }
            $display .= '}' ;

            push @$vars,
                {
                name  => $key,
                value => $display,
                type  => 'Hash',
                var_ref => $ref,
                namedVariables => scalar (keys %$val),
                } ;
            Hash::SafeKeys::restore_iterator_state($val, $iterator);
            }

        if ($key =~ /^Handle/)
            {
            push @$vars,
                {
                name => $key,
                value => $$val,
                type  => 'Filehandle',
                } ;
            }
        }
    }

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

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
            {
            return
                {
                name => "ERROR",
                value => "Cannot set variable if reference is of type " . reftype ($ref) ,
                }  ;
            }
        }
    else
        {
        return
            {
            name => "ERROR",
            value => "Invalid type: $type",
            }  ;
        }

    $$expr_ref = $refexpr . '=' . $$expr_ref ;

    return ;
    }


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

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
    {
    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 }
            }
        }

    local *dbline = "::_<$real_filename" if ($real_filename) ;
    if ($real_filename)
        {
        # Switch the magical hash temporarily.
        local *DB::dbline = "::_<$real_filename";
        $class -> clr_breaks () ;
        $class -> clr_actions () ;
        }

    foreach my $bp (@$breakpoints)
        {
        my $line      = $bp -> [0] ;
        my $condition = $bp -> [1] ;
        ($bp -> [2], $bp -> [3], $bp -> [4], $bp -> [5]) = $class -> _set_breakpoint ($line, $condition) ;
        $bp -> [5] = $filename if ($filename) ;
        }
    return { breakpoints_set => 1, breakpoints => $breakpoints, ($filename ne $real_filename?(real_filename => $real_filename, req_filename => $filename):()) };
    }

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

package DB
    {
    use vars qw{@dbline %dbline $dbline} ;

    sub postponed
        {
        my ($arg) = @_ ;

        return if (!$loaded) ;

        # If this is a subroutine...
        if (ref(\$arg) ne 'GLOB')
            {
            return ;
            }
        # Not a subroutine. Deal with the file.
        local *dbline = $arg ;
        my $filename = $dbline;
        my %seen ;
        my $pp_filename = $filename ;
        while (!exists $postponed_breakpoints{$pp_filename} && -l $pp_filename)
            {
            my $dir = File::Basename::dirname ($pp_filename) ;
            $pp_filename = readlink ($pp_filename) ;
            last if (!$pp_filename) ;
            $pp_filename = Perl::LanguageServer::DebuggerInterface::abs_path_nd ($pp_filename, $dir) ;
            last if ($seen{$pp_filename}++) ;
            }

        #Perl::LanguageServer::DebuggerInterface -> _send ({ command => 'di_loadedfile', arguments => { session_id => $session, reason => 'new', source => { path => $filename}}}) ;

        if (exists $postponed_breakpoints{$pp_filename})
            {
            my $ret = Perl::LanguageServer::DebuggerInterface -> req_breakpoint ({ breakpoints => $postponed_breakpoints{$pp_filename}, filename => $pp_filename, dbg_filename => $filename }) ;
            if ($ret -> {breakpoints_set})
                {
                delete $postponed_breakpoints{$pp_filename} ;
                Perl::LanguageServer::DebuggerInterface -> _send ({ command => 'di_breakpoints',
                                                    arguments => { session_id => $session, %$ret}}) ;
                }
            }
        }
    }

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

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

    my $filename    = $params -> {filename} ;
    my $source = join("", @{$main::{'_<'.$filename}});
    $source =~ s/\n;$//;
	  
    return { content => $source };
    }

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

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

    my $line        = $params -> {line} ;
    my $end_line    = $params -> {end_line} || $line ;
    my $filename    = $params -> {filename} ;
    my $real_filename = $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}++) ;
        }

    return { breakpoints => [] } if (!defined $main::{'_<' . $real_filename}) ;

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

    # Switch the magical hash temporarily.
    local *dbline = "::_<$real_filename";

    my @bp ;
    for (my $i = $line; $i <= $end_line; $i++)
        {
        if ($dbline[$line] != 0)
            {
            push @bp, { line => $line } ;
            }
        }

    return { breakpoints => \@bp };
    }


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

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

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

    @evalresult = () ;
    $class -> cont ;

    return ;
    }

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

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

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

    @evalresult = () ;
    $class -> step ;

    return ;
    }

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

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

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

    @evalresult = () ;
    $class -> ret (2) ;

    return ;
    }

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

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

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

    @evalresult = () ;
    $class -> next ;

    return ;
    }


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

sub _send
    {
    my ($class, $result) = @_ ;

    $result -> {type} = 'dbgint' ;

    my $outdata = $json -> encode ($result) ;
    use bytes ;
    my $len  = length($outdata) ;
    my $wrdata = "Content-Length: $len\r\nContent-Type: application/vscode-jsonrpc; charset=utf-8\r\n\r\n$outdata" ;
    $socket -> syswrite ($wrdata) ;
    if ($debug)
        {
        $wrdata =~ s/\r//g ;
        $class -> logger ($wrdata, "\n") ;
        }
    }


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

sub _recv
    {
    my ($class) = @_ ;

    $class -> logger ("wait for input\n") if ($debug) ;

    my $line ;
    my $cnt ;
    my $buffer ;
    my $data ;
    my %header ;
    header:
    while (1)
        {
        $cnt = sysread ($socket, $buffer, 8192, length ($buffer)) ;
        die "read_error reading headers ($!)" if ($cnt < 0) ;
        return if ($cnt == 0) ;

        while ($buffer =~ s/^(.*?)\R//)
            {
            $line = $1 ;
            $class -> logger ("line=<$line>\n") if ($debug) ;
            last header if ($line eq '') ;
            $header{$1} = $2 if ($line =~ /(.+?):\s*(.+)/) ;
            }
        }

    my $len = $header{'Content-Length'} ;
    my $data ;
    $class -> logger ("len=$len len buffer=", length ($buffer), "\n")  if ($debug) ;
    while ($len > length ($buffer))
        {
        $cnt = sysread ($socket, $buffer, $len - length ($buffer), length ($buffer)) ;
        die "read_error reading data ($!)" if ($cnt < 0) ;
        return if ($cnt == 0) ;
        }
    if ($len == length ($buffer))
        {
        $data = $buffer ;
        $buffer = '' ;
        }
    elsif ($len < length ($buffer))
        {
        $data   = substr ($buffer, 0, $len) ;
        $buffer = substr ($buffer, $len) ;
        }
    else
        {
        die "to few data bytes" ;
        }
    $class -> logger ("read data=", $data, "\n") if ($debug) ;
    $class -> logger ("read header=", "%header", "\n") if ($debug) ;

    my $cmddata = $json -> decode ($data) ;
    my $cmd = 'req_' . $cmddata -> {command} ;
    if ($class -> can ($cmd))
        {
        my $result = $class -> $cmd ($cmddata) ;
        $class -> _send ({ command => 'di_response', seq => $cmddata -> {seq}, arguments => $result}) ;
        return ;
        }
    die "unknown cmd $cmd" ;
    }


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

sub awaken
    {
    my ($class) = @_ ;
    $class -> logger ("enter awaken\n") if ($debug) ;

    $break_reason = 'pause' ;
    #$class -> _send ({ command => 'di_break', arguments => { session_id => $session, reason => 'pause'}}) ;
    }

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

sub init
    {
    my ($class) = @_ ;

    $class -> logger ("enter init\n") if ($debug) ;

    $refresh = ($ENV{PLSDI_OPTIONS} =~ /reload_modules/)?1:0 ;
    if ($refresh)
        {
        require Class::Refresh ;
        Class::Refresh -> refresh ;
        }

    my $remote ;
    my $port ;
    ($remote, $port) = split /:/, $ENV{PLSDI_REMOTE} ;
    if ($remote =~ m/^([0-9.]+)$/) {
      $remote = $1; # untaint
    }
    if ($port =~ m/^(\d+)$/) {
      $port = $1; # untaint
    }

    $socket = IO::Socket::INET->new(PeerAddr => $remote,
                                    PeerPort => $port,
                                    Proto    => 'tcp')
            or die "Cannot connect to $remote:$port ($!)";

    $class -> ready (1) ;
    }

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

sub stop
    {
    my ($class) = @_ ;
    $class -> logger ("enter stop @_\n") if ($debug) ;

    }

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

sub idle
    {
    my ($class) = @_ ;
    $class -> logger ("enter idle @_\n") if ($debug) ;

    my $cmd = $class -> _recv () ;

    }

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

sub cleanup
    {
    my ($class) = @_ ;
    $class -> logger ("enter cleanup @_\n") if ($debug) ;

    }

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

sub output
    {
    my ($class) = @_ ;
    $class -> logger ("enter output @_\n") if ($debug) ;

    }

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

sub showfile
    {
    my ($class, $filename, $line) = @_ ;
    $class -> logger ("enter showfile @_\n") if ($debug) ;

    #$class -> _send ({ command => 'di_showfile', arguments => { session_id => $session, reason => 'new', source => { path => $filename}}}) ;
    }

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

sub evalcode
    {
    my ($class) = @_ ;
    $class -> logger ("enter evalcode @_\n") if ($debug) ;

    }

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

sub cprestop
    {
    my ($class) = @_ ;
    $class -> logger ("enter cprestop @_\n") if ($debug) ;

    @evalresult = () ;
    my $tid = defined ($Coro::current)?$Coro::current+0:1 ;
    $class -> _send ({ command => 'di_break',
                       arguments =>
                        {
                        thread_ref => $tid,
                        session_id => $session,
                        ($break_reason?(reason => $break_reason):()),
                        }}) ;
    $break_reason = undef ;
    }

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

sub cpoststop
    {
    my ($class) = @_ ;
    $class -> logger ("enter cpoststop @_\n") if ($debug) ;
    }


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

$loaded = 1 ;

1 ;
