view release on metacpan or  search on metacpan

tcltkdb.pm  view on Meta::CPAN

    $self->DoAlert($str, "About ptkdb") ;
} # end of DoAbout

#
# return 1 if succesfully set,
# return 0 if otherwise
#
sub SetBreakPoint {
  my ($self, $isTemp) = @_ ;
  my $dbw = $DB::window ;
  my $lineno = $dbw->get_lineno();
  my $expr = $dbw->clear_entry_text() ;
  local($^W) = 0 ;

  if( !&DB::checkdbline($DB::window->{current_file}, $lineno + $self->{'line_offset'}) ) {
    $dbw->DoAlert("line $lineno in $DB::window->{current_file} is not breakable") ;
    return 0 ;
  }

  if( !$isTemp ) {
    $dbw->insertBreakpoint($DB::window->{current_file}, $lineno, 1, $expr) ;
    return 1 ;
  }
  else {
    $dbw->insertTempBreakpoint($DB::window->{current_file}, $lineno) ;
    return 1 ;
  }

  return 0 ;
} # end of SetBreakPoint

sub UnsetBreakPoint {
  my ($self) = @_ ;
  my $lineno = $self->get_lineno();

  $self->removeBreakpoint($DB::window->{current_file}, $lineno) ;
} # end of UnsetBreakPoint

sub balloon_post {
  my $self = $DB::window ;
  my $txt = $DB::window->{'text'} ;

  return 0 if ($self->{'expr_ballon_msg'} eq "") || ($self->{'balloon_expr'} eq "") ; # don't post for an empty string

  return $self->{'balloon_coord'} ;
}

sub balloon_motion {
  my ($txt, $x, $y) = @_ ;
  my ($offset_x, $offset_y) = ($x + 4, $y + 4) ;
  my $self = $DB::window ;
  my $txt2 = $self->{'text'} ;
  my $data ;

  $self->{'balloon_coord'} = "$offset_x,$offset_y" ;

  $x -= $txt->rootx ;
  $y -= $txt->rooty ;
  #
  # Post an event that will cause us to put up a popup
  #

  if ($txt2->_tagRangesSel) { # check to see if 'sel' tag exists (return undef value)
    $data = $txt2->get("sel.first", "sel.last") ; # get the text between the 'first' and 'last' point of the sel (selection) tag
  }
  else {
    $data = $DB::window->retrieve_text_expr($x, $y) ;
  }

  if( !$data ) {
    $self->{'balloon_expr'} = "" ;
    return 0 ; 
  }

  return 0 if ($data eq $self->{'balloon_expr'}) ; # nevermind if it's the same expression

  $self->{'event'} = 'balloon_eval' ;
  $self->{'balloon_expr'} = $data ;

  return 1 ; # ballon will be canceled and a new one put up(maybe)
} # end of balloon_motion

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

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

  my $offset = $Devel::tcltkdb::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