view release on metacpan or  search on metacpan

ptkdb.pm  view on Meta::CPAN

    my ($f, $line) = ($subStack->[$i]->{filename}, $subStack->[$i]->{line}) ; # make copies of the values for use in 'sub'
    $self->{stack_menu}->command(-label => $str, -command => sub { $self->goto_sub_from_stack($f, $line) ; } ) ;
  }
} # end of refresh_stack_menu

no strict ;

sub get_state {
  my ($self, $fname) = @_ ;
  my ($val) ;
  local($files, $expr_list, $eval_saved_text, $main_win_geometry) ;
  
  do "$fname"  ;

  if( $@ ) {
    $self->DoAlert($@) ;
    return ( undef ) x 4 ; # return a list of 4 undefined values
  }

  return ($files, $expr_list, $eval_saved_text, $main_win_geometry) ;
} # end of get_state

use strict ;

sub restoreStateFile {
  my ($self, $fname) = @_ ;
  local(*F) ;
  my ($saveCurFile, $s, @n, $n) ;

  if (!(-e $fname && -r $fname)) {
    $self->DoAlert("$fname does not exist") ;
    return ;
  }

  my ($files, $expr_list, $eval_saved_text, $main_win_geometry) = $self->get_state($fname) ;
  my ($f, $brks) ;

  return unless defined $files || defined $expr_list ;

  &DB::restore_breakpoints_from_save($files) ;

  #
  # This should force the breakpoints to be restored
  #
  $saveCurFile = $self->{current_file} ;

  @$self{ 'current_file', 'expr_list', 'eval_saved_text' } =
      ( ""             , $expr_list,  $eval_saved_text) ;

  $self->set_file($saveCurFile, $self->{current_line}) ;

  $self->{'event'} = 'update' ;

  if ( $main_win_geometry && $self->{'main_window'} ) { 
    # restore the height and width of the window
    $self->{main_window}->geometry( $main_win_geometry ) ;
  }
} # end of retstoreState

sub updateEvalWindow {
  my ($self, @result) = @_ ;
  my ($leng, $str, $d) ;

  $leng = 0 ;
  for( @result ) {
    if( $self->{hexdump_evals} ) {
      # eventually put hex dumper code in here
			
			$self->{eval_results}->insert('end', hexDump($_)) ;

    }
    elsif( !$Devel::ptkdb::DataDumperAvailable || !$Devel::ptkdb::useDataDumperForEval ) {
      $str = "$_\n" ;
    }
    else {
      $d = Data::Dumper->new([ $_ ]) ;
      $d->Indent($Devel::ptkdb::eval_dump_indent) ;
      $d->Terse(1) ;
      if( Data::Dumper->can('Dumpxs') ) { 
        $str = $d->Dumpxs( $_ ) ;
      }
      else {
        $str = $d->Dump( $_ ) ;
      }
    }
    $leng += length $str ;
    $self->{eval_results}->insert('end', $str) ;
  }
} # end of updateEvalWindow


##
## converts non printable chars to '.' for a string
##
sub printablestr {
    return join "", map { (ord($_) >= 32 && ord($_) < 127) ? $_ : '.' } split //, $_[0] ;
}

##
## hex dump utility function
##
sub hexDump {
    my(@retList) ;
    my($width) = 8 ;
    my($offset) ;
    my($len, $fmt, $n, @elems) ;

    for( @_ ) {
	my($str) ;
	$len = length $_ ;
	
	while($len) {
	    $n = $len >= $width ? $width : $len ;

	    $fmt = "\n%04X  " . ("%02X " x $n ) . ( '   ' x ($width - $n) ) . " %s" ;
	    @elems = map ord, split //, (substr $_, $offset, $n) ;
	    $str .= sprintf($fmt, $offset, @elems, printablestr(substr $_, $offset, $n)) ;
	    $offset += $width ;

	    $len -= $n ;

ptkdb.pm  view on Meta::CPAN

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

sub set_stop_on_warning {

  if( $DB::ptkdb::stop_on_warning ) {
    
    return if $DB::ptkdb::warn_sig_save == \&stop_on_warning_cb ; # prevents recursion

    $DB::ptkdb::warn_sig_save = $SIG{'__WARN__'} if $SIG{'__WARN__'} ;
    $SIG{'__WARN__'} = \&stop_on_warning_cb ;
     }
  else {
    ##
    ## Restore any previous warning signal
    ##
    local($^W) = 0 ;
    $SIG{'__WARN__'} = $DB::ptkdb::warn_sig_save ;
  }
} # end of set_stop_on_warning

1 ; # end of Devel::ptkdb

package DB ;

use vars '$VERSION', '$header' ;

$VERSION = '1.1091' ;
$header = "ptkdb.pm version $DB::VERSION";
$DB::window->{current_file} = "" ;

#
# Here's the clue...
# eval only seems to eval the context of
# the executing script while in the DB
# package.  When we had updateExprs in the Devel::ptkdb
# package eval would turn up an undef result.
#

sub updateExprs {
  my ($package) = @_ ;
  #
  # Update expressions
  # 
 $DB::window->deleteAllExprs() ;
  my ($expr, @result);

  foreach $expr ( @{$DB::window->{'expr_list'}} ) {
    next if length $expr == 0 ;

    @result = &DB::dbeval($package, $expr->{'expr'}) ;

    if(  @result == 1 ) {
      $DB::window->insertExpr([ $result[0] ], $DB::window->{'data_list'}, $result[0], $expr->{'expr'}, $expr->{'depth'}) ;
      }
    else {
      $DB::window->insertExpr([ \@result ], $DB::window->{'data_list'}, \@result, $expr->{'expr'}, $expr->{'depth'}) ;
      }
  }

} # end of updateExprs

no strict ; # turning strict off (shame shame) because we keep getting errrs for the local(*dbline)

#
# returns true if line is breakable
#
use Carp ;
sub checkdbline($$) { 
  my ($fname, $lineno) = @_ ;

  return 0 unless $fname; # we're getting an undef here on 'Restart...'

  local($^W) = 0 ; # spares us warnings under -w
  local(*dbline) = $main::{'_<' . $fname} ;

  my $flag = $dbline[$lineno] != 0 ;

  return $flag;
  
} # end of checkdbline

#
# sets a breakpoint 'through' a magic 
# variable that perl is able to interpert
#
sub setdbline($$$) {
  my ($fname, $lineno, $value) = @_ ;
  local(*dbline) = $main::{'_<' . $fname};

  $dbline{$lineno} = $value ;
} # end of setdbline

sub getdbline($$) {
  my ($fname, $lineno) = @_ ;
  local(*dbline) = $main::{'_<' . $fname};
  return $dbline{$lineno} ;
} # end of getdbline

sub getdbtextline {