view release on metacpan or  search on metacpan

ptkdb.pm  view on Meta::CPAN

  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) =~ /^([\$\@\%][a-zA-Z0-9_]+)/ ;

  return $1 ;
}

#
# after DB::eval get's us a result
#
sub code_motion_eval {
  my ($self, @result) = @_ ;
  my $str ;

  if( exists $self->{'balloon_dumper'} ) {

    my $d = $self->{'balloon_dumper'} ;

    $d->Reset() ;
    $d->Values( [ $#result == 0 ? @result : \@result ] ) ;      

                  if( $d->can('Dumpxs') ) {
                    $str = $d->Dumpxs() ;
                  }
                  else {
                    $str = $d->Dump() ;
                  }

                  chomp($str) ;
                }
                else {
                  $str = "@result" ;
                }

                #
                # 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() ;

} # end of EnterActions

#
# Subroutine called when we return from DB::DB()
# When the target script resumes.  
#
sub LeaveActions {
  my($self) = @_ ;
  
  #  $self->{'main_window'}->Busy() ;
} # end of LeaveActions


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

}

##
## Save the ptkdb state file and restart the debugger
##
sub DoRestart {
  my($fname) ;

  $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:ptkdb $Devel::ptkdb::scriptName @Devel::ptkdb::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::ptkdb::warn_sig_save() if $DB::ptkdb::warn_sig_save ; # call any previously registered warning
 $DB::window->DoAlert(@_) ;
 $DB::single = 1 ; # forces debugger to stop next time