view release on metacpan or  search on metacpan

tkdb.pm  view on Meta::CPAN

sub retrieve_text_expr {
  my($self, $x, $y) = @_ ;
  my $txt = $self->{'text'} ;

  my ($idx, $col) = $txt->index("\@$x,$y") =~ /^(\d*)\.(\d*)$/;

  my $offset = $Devel::tkdb::linenumber_length + 1 ; # line number text + 1 space

  return undef if $col < $offset ; # no posting

  $col -= $offset ;

  local(*dbline) = $main::{'_<' . $self->{current_file}} ;   

  return undef if( !defined $dbline[$idx] || $dbline[$idx] == 0 ) ; # no executable text, no real variable(?)

  my $data = $dbline[$idx] ;

  # if we're sitting over white space, leave
  my $len = length $data ;
  return unless $data && $col && $len > 0 ;

  return if substr($data, $col, 1) =~ /\s/ ;

  # walk backwards till we find some whitespace

  $col = $len if $len < $col ;
  while( --$col >= 0 ) {
    last if  substr($data, $col, 1) =~ /[\s\$\@\%]/ ;
  }

  substr($data, $col) =~ /^([\$\@\%]\w+)/ ;

  return $1 ;
}

#
# after DB::eval get's us a result
#
sub code_motion_eval {
    my ($self, @result) = @_;
    my $d = new Data::Dumper([]);
    $d->Terse(1);
    $d->Indent(2);
    $d->Values( [ $#result == 0 ? @result : \@result ]); 
    my $str = $d->Dump();
    chomp($str) ;
    # Cut the string down to 1024 characters to keep from overloading the balloon window
    $self->{'expr_ballon_msg'} = "$self->{'balloon_expr'} = " . substr $str, 0, 1024 ;
} # end of code motion eval

#
# Subroutine called when we enter DB::DB()
# In other words when the target script 'stops'
# in the Debugger
#
sub EnterActions {
  my($self) = @_ ;

  # $self->{'main_window'}->Unbusy() ;
}

#
# Subroutine called when we return from DB::DB()
# When the target script resumes.  
#
sub LeaveActions {
  my($self) = @_ ;

  # $self->{'main_window'}->Busy() ;
}


sub BEGIN {
  $Devel::tkdb::scriptName = $0 ;
  @Devel::tkdb::script_args = @ARGV ; # copy args
}

##
## Save the ptkdb state file and restart the debugger
##
sub DoRestart {
  my $fname = $ENV{'TMP'} || $ENV{'TMPDIR'} || $ENV{'TMP_DIR'} || $ENV{'TEMP'} || $ENV{'HOME'};
  $fname .= '/' if $fname;
  $fname = "" unless $fname;

  $fname .= "ptkdb_restart_state$$" ;

  # print "saving temp state file $fname\n" ;

  &DB::save_state_file($fname) ;

  $ENV{'PTKDB_RESTART_STATE_FILE'} = $fname ;

  ##
  ## build up the command to do the restart
  ##

  $fname = "perl -w -d:tkdb $Devel::tkdb::scriptName @Devel::tkdb::script_args" ;

  # print "$$ doing a restart with $fname\n" ;

  exec $fname ;

} # end of DoRestart

##
## Enables/Disables the feature where we stop
## if we've encountered a perl warning such as:
## "Use of uninitialized value at undef_warn.pl line N"
##

sub stop_on_warning_cb {
  &$DB::tkdb::warn_sig_save() if $DB::tkdb::warn_sig_save ; # call any previously registered warning
 $DB::window->DoAlert(@_) ;
 $DB::single = 1 ; # forces debugger to stop next time
}

sub set_stop_on_warning {