view release on metacpan or  search on metacpan

tkdb.pm  view on Meta::CPAN

  for (my $i = 0 ; $subStack->[$i] ; $i++) {

    my $str = defined $subStack->[$i+1] ? "$subStack->[$i+1]->{name}" : "MAIN" ;

    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->set_file($f, $line); } );
  }
} # end of refresh_stack_menu

no strict ;

sub get_state {
  my ($self, $fname) = @_ ;
  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) = @_ ;

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

  return unless defined $files || defined $expr_list ;

  &DB::restore_breakpoints_from_save($files) ;

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

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

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

  if ( $main_win_geometry && $self->{'main_window'} ) { 
    # restore the height and width of the window
    $self->{main_window}->geometry( $main_win_geometry ) ;
  }
  $self->{int}->SetVar('event','update');

} # end of retstoreState

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

  for (@result) {
    if( $self->{hexdump_evals} ) {
      # eventually put hex dumper code in here
      $self->{eval_results}->insert('end', hexDump($_)) ;
    } else {
      my $d = Data::Dumper->new([$_]);
      $d->Indent(2);
      $d->Terse(1);
      $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 = 0;

    for (@_) {
	my $str = '';
	my $len = length $_ ;

	while($len) {
	    my $n = $len >= $width ? $width : $len ;

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

	    $len -= $n;
	} # while

	push @retList, $str;
    } # for

    return $retList[0] unless wantarray ;
    return @retList ;
} # end of hd


sub setupEvalWindow {
  my($self) = @_;
  $self->{eval_window}->focus(), return if exists $self->{eval_window} ; # already running this window?

tkdb.pm  view on Meta::CPAN

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

  if( $DB::tkdb::stop_on_warning ) {

    return if $DB::tkdb::warn_sig_save == \&stop_on_warning_cb ; # prevents recursion

    $DB::tkdb::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::tkdb::warn_sig_save ;
  }
} # end of set_stop_on_warning

# end of Devel::tkdb

package DB;

use vars '@dbline', '%dbline';

our $VERSION = '2.0';

#
# 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::tkdb
# package eval would turn up an undef result.
#

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

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

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

    my $r = (@result==1?$result[0]:\@result);
    $DB::window->insertExpr([$r], $r, $expr->{'expr'}, $expr->{'depth'},'root');
  }
} # 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
#
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 {
  my ($fname, $lineno) = @_ ;
  local(*dbline) = $main::{'_<' . $fname};
  return $dbline[$lineno] ;
} # end of getdbline


sub cleardbline($$;&) {