Devel-ptkdb
view release on metacpan or search on metacpan
use Tk ;
#
# If you've loaded this file via a browser
# select "Save As..." from your file menu
#
# ptkdb Perl Tk perl Debugger
#
# Copyright 1998, 2003, Andrew E. Page
# All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of either:
#
# a) the GNU General Public License as published by the Free
# Software Foundation; either version 1, or (at your option) any
# later version, or
#
# b) the "Artistic License" which comes with this Kit.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
# the GNU General Public License or the Artistic License for more details.
#
####################################
### Sample .Xresources for ptkdb ###
####################################
# /*
# * Perl Tk Debugger XResources.
# * Note... These resources are subject to change.
# *
# * Use 'xfontsel' to select different fonts.
# *
# * Append these resource to ~/.Xdefaults | ~/.Xresources
# * and use xrdb -override ~/.Xdefaults | ~/.Xresources
# * to activate them.
# */
# /* Set Value to se to place scrollbars on the right side of windows
# CAUTION: extra whitespace at the end of the line is causing
# failures with Tk800.011.
# */
# ptkdb*scrollbars: sw
#
# /* controls where the code pane is oriented, down the left side, or across the top */
# /* values can be set to left, right, top, bottom */
# ptkdb*codeside: left
# /*
# * Background color for the balloon
# * CAUTION: For certain versions of Tk trailing
# * characters after the color produces an error
# */
# ptkdb.frame2.frame1.rotext.balloon.background: green
# ptkdb.frame2.frame1.rotext.balloon.font: fixed /* Hot Variable Balloon Font */
#
#
# ptkdb.frame*font: fixed /* Menu Bar */
# ptkdb.frame.menubutton.font: fixed /* File menu */
# ptkdb.frame2.frame1.rotext.font: fixed /* Code Pane */
# ptkdb.notebook.datapage.frame1.hlist.font: fixed /* Expression Notebook Page */
#
# ptkdb.notebook.subspage*font: fixed /* Subroutine Notebook Page */
# ptkdb.notebook.brkptspage*entry.font: fixed /* Delete Breakpoint Buttons */
# ptkdb.notebook.brkptspage*button.font: fixed /* Breakpoint Expression Entries */
# ptkdb.notebook.brkptspage*button1.font: fixed /* Breakpoint Expression Entries */
# ptkdb.notebook.brkptspage*checkbutton.font: fixed /* Breakpoint Checkbuttons */
# ptkdb.notebook.brkptspage*label.font: fixed /* Breakpoint "Cond" label */
#
# ptkdb.toplevel.frame.textundo.font: fixed /* Eval Expression Entry Window */
# ptkdb.toplevel.frame1.text.font: fixed /* Eval Expression Results Window */
# ptkdb.toplevel.button.font: fixed /* "Eval..." Button */
# ptkdb.toplevel.button1.font: fixed /* "Clear Eval" Button */
# ptkdb.toplevel.button2.font: fixed /* "Clear Results" Button */
# ptkdb.toplevel.button3.font: fixed /* "Clear Dismiss" Button */
#
#
# /*
# * Background color for where the debugger has stopped
# */
# ptkdb*stopcolor: blue
#
# /*
# * Background color for set breakpoints
# */
# ptkdb*breaktagcolor: red
#
# /*
# * Font for where the debugger has stopped
# */
# ptkdb*stopfont: -*-fixed-bold-*-*-*-*-*-*-*-*-*-*-*
#
# /*
# * Background color for the search tag
# */
# ptkdb*searchtagcolor: green
use strict ;
use vars qw($VERSION @dbline %dbline);
#
# This package is the main_window object
# for the debugger. We start with the Devel::
# prefix because we want to install it with
# the DB:: package that is required to be in a Devel/
# subdir of a directory in the @INC set.
#
package Devel::ptkdb ;
##
## do this check once, rather than repeating the string comparison again and again
##
my $isWin32 = $^O eq 'MSWin32' ;
=head1 NAME
Line numbers are presented on the left side of the window. Lines that
have lines through them are not breakable. Lines that are plain text
are breakable. Clicking on these line numbers will insert a
breakpoint on that line and change the line number color to
$ENV{'PTKDB_BRKPT_COLOR'} (Defaults to Red). Clicking on the number
again will remove the breakpoint. If you disable the breakpoint with
the controls on the BrkPt notebook page the color will change to
$ENV{'PTKDB_DISABLEDBRKPT_COLOR'}(Defaults to Green).
=item Cursor Motion
If you place the cursor over a variable (i.e. $myVar, @myVar, or
%myVar) and pause for a second the debugger will evaluate the current
value of the variable and pop a balloon up with the evaluated
result. I<This feature is not available with Tk400.>
If Data::Dumper(standard with perl5.00502)is available it will be used
to format the result. If there is an active selection, the text of
that selection will be evaluated.
=back
=head1 Notebook Pane
=over 2
=item Exprs
This is a list of expressions that are evaluated each time the
debugger stops. The results of the expresssion are presented
heirarchically for expression that result in hashes or lists. Double
clicking on such an expression will cause it to collapse; double
clicking again will cause the expression to expand. Expressions are
entered through B<Enter Expr> entry, or by Alt-E when text is
selected in the code pane.
The B<Quick Expr> entry, will take an expression, evaluate it, and
replace the entries contents with the result. The result is also
transfered to the 'clipboard' for pasting.
=item Subs
Displays a list of all the packages invoked with the script
heirarchially. At the bottom of the heirarchy are the subroutines
within the packages. Double click on a package to expand
it. Subroutines are listed by their full package names.
=item BrkPts
Presents a list of the breakpoints current in use. The pushbutton
allows a breakpoint to be 'disabled' without removing it. Expressions
can be applied to the breakpoint. If the expression evaluates to be
'true'(results in a defined value that is not 0) the debugger will
stop the script. Pressing the 'Goto' button will set the text pane
to that file and line where the breakpoint is set. Pressing the
'Delete' button will delete the breakpoint.
=back
=head1 Menus
=head2 File Menu
=over
=item About...
Presents a dialog box telling you about the version of ptkdb. It
recovers your OS name, version of perl, version of Tk, and some other
information
=item Open
Presents a list of files that are part of the invoked perl
script. Selecting a file from this list will present this file in the
text window.
=item Save Config...
Requires Data::Dumper. Prompts for a filename to save the
configuration to. Saves the breakpoints, expressions, eval text and
window geometry. If the name given as the default is used and the
script is reinvoked, this configuration will be reloaded
automatically.
B<NOTE:> You may find this preferable to using
=item Restore Config...
Requires Data::Dumper. Prompts for a filename to restore a configuration saved with
the "Save Config..." menu item.
=item Goto Line...
Prompts for a line number. Pressing the "Okay" button sends the window to the line number entered.
item Find Text...
Prompts for text to search for. Options include forward search,
backwards search, and regular expression searching.
=item Quit
Causes the debugger and the target script to exit.
=back
=head2 Control Menu
=over
=item Run
The debugger allows the script to run to the next breakpoint or until the script exits.
item Run To Here
Runs the debugger until it comes to wherever the insertion cursor
in text window is placed.
=item Set Breakpoint
Sets a breakpoint on the line at the insertion cursor.
item Clear Breakpoint
Remove a breakpoint on the at the insertion cursor.
=item Clear All Breakpoints
Removes all current breakpoints
=item Step Over
Causes the debugger to step over the next line. If the line is a
subroutine call it steps over the call, stopping when the subroutine
returns.
=item Step In
Causes the debugger to step into the next line. If the line is a
subroutine call it steps into the subroutine, stopping at the first
executable line within the subroutine.
=item Return
Runs the script until it returns from the currently executing
subroutine.
=item Restart
Saves the breakpoints and expressions in a temporary file and restarts
the script from the beginning. CAUTION: This feature will not work
properly with debugging of CGI Scripts.
=item Stop On Warning
When C<-w> is enabled the debugger will stop when warnings such as, "Use
of uninitialized value at undef_warn.pl line N" are encountered. The debugger
will stop on the NEXT line of execution since the error can't be detected
until the current line has executed.
This feature can be turned on at startup by adding:
$DB::ptkdb::stop_on_warning = 1 ;
to a .ptkdbrc file
=back
=head2 Data Menu
=over
=item Enter Expression
When an expression is entered in the "Enter Expression:" text box,
selecting this item will enter the expression into the expression
list. Each time the debugger stops this expression will be evaluated
and its result updated in the list window.
=item Delete Expression
Deletes the highlighted expression in the expression window.
=item Delete All Expressions
Delete all expressions in the expression window.
=item Expression Eval Window
Pops up a two pane window. Expressions of virtually unlimitted length
can be entered in the top pane. Pressing the 'Eval' button will cause
the expression to be evaluated and its placed in the lower pane. If
Data::Dumper is available it will be used to format the resulting
text. Undo is enabled for the text in the upper pane.
HINT: You can enter multiple expressions by separating them with commas.
=item Use Data::Dumper for Eval Window
Enables or disables the use of Data::Dumper for formatting the results
of expressions in the Eval window.
=back
=head2 Stack Menu
Maintains a list of the current subroutine stack each time the
debugger stops. Selecting an item from this menu will set the text in
the code window to that particular subourtine entry point.
=head2 Bookmarks Menu
Maintains a list of bookmarks. The booksmarks are saved in ~/.ptkdb_bookmarks
=over
=item Add Bookmark
Adds a bookmark to the bookmark list.
=back
=head1 Options
Here is a list of the current active XResources options. Several of
these can be overridden with environmental variables. Resources can be
added to .Xresources or .Xdefaults depending on your X configuration.
To enable these resources you must either restart your X server or use
the xrdb -override resFile command. xfontsel can be used to select
fonts.
/*
* Perl Tk Debugger XResources.
* Note... These resources are subject to change.
*
* Use 'xfontsel' to select different fonts.
*
* Append these resource to ~/.Xdefaults | ~/.Xresources
* and use xrdb -override ~/.Xdefaults | ~/.Xresources
* to activate them.
*/
/* Set Value to se to place scrollbars on the right side of windows
CAUTION: extra whitespace at the end of the line is causing
failures with Tk800.011.
sw -> puts scrollbars on left, se puts scrollars on the right
*/
ptkdb*scrollbars: sw
/* controls where the code pane is oriented, down the left side, or across the top */
/* values can be set to left, right, top, bottom */
ptkdb*codeside: left
/*
* Background color for the balloon
* CAUTION: For certain versions of Tk trailing
* characters after the color produces an error
*/
ptkdb.frame2.frame1.rotext.balloon.background: green
ptkdb.frame2.frame1.rotext.balloon.font: fixed /* Hot Variable Balloon Font */
ptkdb.frame*font: fixed /* Menu Bar */
ptkdb.frame.menubutton.font: fixed /* File menu */
ptkdb.frame2.frame1.rotext.font: fixed /* Code Pane */
ptkdb.notebook.datapage.frame1.hlist.font: fixed /* Expression Notebook Page */
ptkdb.notebook.subspage*font: fixed /* Subroutine Notebook Page */
ptkdb.notebook.brkptspage*entry.font: fixed /* Delete Breakpoint Buttons */
ptkdb.notebook.brkptspage*button.font: fixed /* Breakpoint Expression Entries */
ptkdb.notebook.brkptspage*button1.font: fixed /* Breakpoint Expression Entries */
ptkdb.notebook.brkptspage*checkbutton.font: fixed /* Breakpoint Checkbuttons */
ptkdb.notebook.brkptspage*label.font: fixed /* Breakpoint Checkbuttons */
ptkdb.toplevel.frame.textundo.font: fixed /* Eval Expression Entry Window */
ptkdb.toplevel.frame1.text.font: fixed /* Eval Expression Results Window */
ptkdb.toplevel.button.font: fixed /* "Eval..." Button */
ptkdb.toplevel.button1.font: fixed /* "Clear Eval" Button */
ptkdb.toplevel.button2.font: fixed /* "Clear Results" Button */
ptkdb.toplevel.button3.font: fixed /* "Clear Dismiss" Button */
/*
* Background color for where the debugger has stopped
*/
ptkdb*stopcolor: blue
/*
* Background color for set breakpoints
*/
ptkdb*breaktagcolor*background: yellow
ptkdb*disabledbreaktagcolor*background: white
/*
* Font for where the debugger has stopped
*/
ptkdb*stopfont: -*-fixed-bold-*-*-*-*-*-*-*-*-*-*-*
/*
* Background color for the search tag
*/
ptkdb*searchtagcolor: green
=head1 Environmental Variables
=over 4
=item PTKDB_BRKPT_COLOR
Sets the background color of a set breakpoint
=item PTKDB_DISABLEDBRKPT_COLOR
Sets the background color of a disabled breakpoint
=item PTKDB_CODE_FONT
Sets the font of the Text in the code pane.
=item PTKDB_CODE_SIDE
Sets which side the code pane is packed onto. Defaults to 'left'.
Can be set to 'left', 'right', 'top', 'bottom'.
Overrides the Xresource ptkdb*codeside: I<side>.
&set_stop_on_warning() ;
}
#
# Constructor for our Devel::ptkdb
#
sub new {
my($type) = @_ ;
my($self) = {} ;
bless $self, $type ;
# Current position of the executing program
$self->{DisableOnLeave} = [] ; # List o' Widgets to disable when leaving the debugger
$self->{current_file} = "" ;
$self->{current_line} = -1 ; # initial value indicating we haven't set our line/tag
$self->{window_pos_offset} = 10 ; # when we enter how far from the top of the text are we positioned down
$self->{search_start} = "0.0" ;
$self->{fwdOrBack} = 1 ;
$self->{BookMarksPath} = $ENV{'PTKDB_BOOKMARKS_PATH'} || "$ENV{'HOME'}/.ptkdb_bookmarks" || '.ptkdb_bookmarks' ;
$self->{'expr_list'} = [] ; # list of expressions to eval in our window fields: {'expr'} The expr itself {'depth'} expansion depth
$self->{'brkPtCnt'} = 0 ;
$self->{'brkPtSlots'} = [] ; # open slots for adding breakpoints to the table
$self->{'main_window'} = undef ;
$self->{'user_window_init_list'} = [] ;
$self->{'user_window_DB_entry_list'} = [] ;
$self->{'subs_list_cnt'} = 0 ;
$self->setup_main_window() ;
return $self ;
} # end of new
sub setup_main_window {
my($self) = @_ ;
# Main Window
$self->{main_window} = MainWindow->new() ;
$self->{main_window}->geometry($ENV{'PTKDB_GEOMETRY'} || "800x600") ;
$self->setup_options() ; # must be done after MainWindow and before other frames are setup
$self->{main_window}->bind('<Control-c>', \&DB::dbint_handler) ;
#
# Bind our 'quit' routine to a close command from the window manager (Alt-F4)
#
$self->{main_window}->protocol('WM_DELETE_WINDOW', sub { $self->close_ptkdb_window() ; } ) ;
# Menu bar
$self->setup_menu_bar() ;
#
# setup Frames
#
# Setup our Code, Data, and breakpoints
$self->setup_frames() ;
}
#
# Check for changes to the bookmarks and quit
#
sub DoQuit {
my($self) = @_ ;
$self->save_bookmarks($self->{BookMarksPath}) if $Devel::ptkdb::DataDumperAvailable && $self->{'bookmarks_changed'};
$self->{main_window}->destroy if $self->{main_window} ;
$self->{main_window} = undef if defined $self->{main_window} ;
exit ;
}
#
# This supports the File -> Open menu item
# We create a new window and list all of the files
# that are contained in the program. We also
# pick up all of the perlTk files that are supporting
# the debugger.
#
sub DoOpen {
my $self = shift ;
my ($topLevel, $listBox, $frame, $selectedFile, @fList) ;
#
# subroutine we call when we've selected a file
#
my $chooseSub = sub { $selectedFile = $listBox->get('active') ;
print "attempting to open $selectedFile\n" ;
$DB::window->set_file($selectedFile, 0) ;
destroy $topLevel ;
} ;
#
# Take the list the files and resort it.
# we put all of the local files first, and
# then list all of the system libraries.
#
@fList = sort {
# sort comparison function block
my $fa = substr($a, 0, 1) ;
my $fb = substr($b, 0, 1) ;
return $a cmp $b if ($fa eq '/') && ($fb eq '/') ;
return -1 if ($fb eq '/') && ($fa ne '/') ;
return 1 if ($fa eq '/' ) && ($fb ne '/') ;
# We have menu items/features that are not available if the Data::DataDumper module
# isn't present. For any feature that requires it we add this option list.
#
my @dataDumperEnableOpt = ( state => 'disabled' ) unless $Devel::ptkdb::DataDumperAvailable ;
$self->{menu_bar} = $mw->Frame(-relief => 'raised', -borderwidth => '1')->pack(-side => 'top', -fill => 'x') ;
$mb = $self->{menu_bar} ;
# file menu in menu bar
$items = [ [ 'command' => 'About...', -command => sub { $self->DoAbout() ; } ],
[ 'command' => 'Bug Report...', -command => \&DoBugReport ],
"-",
[ 'command' => 'Open', -accelerator => 'Alt+O',
-underline => 0,
-command => sub { $self->DoOpen() ; } ],
[ 'command' => 'Save Config...',
-underline => 0,
-command => \&DB::SaveState,
@dataDumperEnableOpt ],
[ 'command' => 'Restore Config...',
-underline => 0,
-command => \&DB::RestoreState,
@dataDumperEnableOpt ],
[ 'command' => 'Goto Line...',
-underline => 0,
-accelerator => 'Alt-g',
-command => sub { $self->GotoLine() ; },
@dataDumperEnableOpt ] ,
[ 'command' => 'Find Text...',
-accelerator => 'Ctrl-f',
-underline => 0,
-command => sub { $self->FindText() ; } ],
[ 'command' => "Tabs...", -command => \&do_tabs ],
"-",
[ 'command' => 'Close Window and Run', -accelerator => 'Alt+W',
-underline => 6, -command => sub { $self->close_ptkdb_window ; } ],
[ 'command' => 'Quit...', -accelerator => 'Alt+Q',
-underline => 0,
-command => sub { $self->DoQuit } ]
] ;
$mw->bind('<Alt-g>' => sub { $self->GotoLine() ; }) ;
$mw->bind('<Control-f>' => sub { $self->FindText() ; }) ;
$mw->bind('<Control-r>' => \&Devel::ptkdb::DoRestart) ;
$mw->bind('<Alt-q>' => sub { $self->{'event'} = 'quit' } ) ;
$mw->bind('<Alt-w>' => sub { $self->close_ptkdb_window ; }) ;
$self->{file_menu_button} = $mb->Menubutton(-text => 'File',
-underline => 0,
-menuitems => $items
)->pack(-side =>, 'left',
-anchor => 'nw',
-padx => 2) ;
# Control Menu
my $runSub = sub { $DB::step_over_depth = -1 ; $self->{'event'} = 'run' } ;
my $runToSub = sub { $DB::window->{'event'} = 'run' if $DB::window->SetBreakPoint(1) ; } ;
my $stepOverSub = sub { &DB::SetStepOverBreakPoint(0) ;
$DB::single = 1 ;
$DB::window->{'event'} = 'step' ;
} ;
my $stepInSub = sub {
$DB::step_over_depth = -1 ;
$DB::single = 1 ;
$DB::window->{'event'} = 'step' ; } ;
my $returnSub = sub {
&DB::SetStepOverBreakPoint(-1) ;
$self->{'event'} = 'run' ;
} ;
$items = [ [ 'command' => 'Run', -accelerator => 'Alt+r', -underline => 0, -command => $runSub ],
[ 'command' => 'Run To Here', -accelerator => 'Alt+t', -underline => 5, -command => $runToSub ],
'-',
[ 'command' => 'Set Breakpoint', -underline => 4, -command => sub { $self->SetBreakPoint ; }, -accelerator => 'Ctrl-b' ],
[ 'command' => 'Clear Breakpoint', -command => sub { $self->UnsetBreakPoint } ],
[ 'command' => 'Clear All Breakpoints', -underline => 6, -command => sub {
$DB::window->removeAllBreakpoints($DB::window->{current_file}) ;
&DB::clearalldblines() ;
} ],
'-',
[ 'command' => 'Step Over', -accelerator => 'Alt+N', -underline => 0, -command => $stepOverSub ],
[ 'command' => 'Step In', -accelerator => 'Alt+S', -underline => 5, -command => $stepInSub ],
[ 'command' => 'Return', -accelerator => 'Alt+U', -underline => 3, -command => $returnSub ],
'-',
[ 'command' => 'Restart...', -accelerator => 'Ctrl-r', -underline => 0, -command => \&Devel::ptkdb::DoRestart ],
'-',
[ 'checkbutton' => 'Stop On Warning', -variable => \$DB::ptkdb::stop_on_warning, -command => \&set_stop_on_warning ]
] ; # end of control menu items
$self->{control_menu_button} = $mb->Menubutton(-text => 'Control',
-underline => 0,
-menuitems => $items,
)->pack(-side =>, 'left',
-padx => 2) ;
$mw->bind('<Alt-r>' => $runSub) ;
$mw->bind('<Alt-t>', $runToSub) ;
$mw->bind('<Control-b>', sub { $self->SetBreakPoint ; }) ;
for( @Devel::ptkdb::step_over_keys ) {
$mw->bind($_ => $stepOverSub );
}
for( @Devel::ptkdb::step_in_keys ) {
$mw->bind($_ => $stepInSub );
}
for( @Devel::ptkdb::return_keys ) {
$mw->bind($_ => $returnSub );
}
# Data Menu
$items = [ [ 'command' => 'Enter Expression', -accelerator => 'Alt+E', -command => sub { $self->EnterExpr() } ],
[ 'command' => 'Delete Expression', -accelerator => 'Ctrl+D', -command => sub { $self->deleteExpr() } ],
[ 'command' => 'Delete All Expressions', -command => sub {
$self->deleteAllExprs() ;
$self->{'expr_list'} = [] ; # clears list by dropping ref to it, replacing it with a new one
} ],
'-',
[ 'command' => 'Expression Eval Window...', -accelerator => 'F8', -command => sub { $self->setupEvalWindow() ; } ],
[ 'checkbutton' => "Use DataDumper for Eval Window?", -variable => \$Devel::ptkdb::useDataDumperForEval, @dataDumperEnableOpt ]
] ;
$self->{data_menu_button} = $mb->Menubutton(-text => 'Data', -menuitems => $items,
-underline => 0,
)->pack(-side => 'left',
-padx => 2) ;
$mw->bind('<Alt-e>' => sub { $self->EnterExpr() } ) ;
$mw->bind('<Control-d>' => sub { $self->deleteExpr() } );
$mw->bind('<F8>', sub { $self->setupEvalWindow() ; }) ;
#
# Stack menu
#
$self->{stack_menu} = $mb->Menubutton(-text => 'Stack',
-underline => 2,
)->pack(-side => 'left',
-padx => 2) ;
#
# Bookmarks menu
#
$self->{bookmarks_menu} = $mb->Menubutton(-text => 'Bookmarks',
-underline => 0,
@dataDumperEnableOpt
)->pack(-side => 'left',
-padx => 2) ;
$self->setup_bookmarks_menu() ;
#
# Windows Menu
#
my($bsub) = sub { $self->{'text'}->focus() } ;
my($csub) = sub { $self->{'quick_entry'}->focus() } ;
my($dsub) = sub { $self->{'entry'}->focus() } ;
$items = [ [ 'command' => 'Code Pane', -accelerator => 'Alt+0', -command => $bsub ],
[ 'command' => 'Quick Entry', -accelerator => 'F9', -command => $csub ],
[ 'command' => 'Expr Entry', -accelerator => 'F11', -command => $dsub ]
] ;
$mb->Menubutton(-text => 'Windows', -menuitems => $items
)->pack(-side => 'left',
-padx => 2) ;
$mw->bind('<Alt-0>', $bsub) ;
$mw->bind('<F9>', $csub) ;
$mw->bind('<F11>', $dsub) ;
#
# Bar for some popular controls
#
$self->{button_bar} = $mw->Frame()->pack(-side => 'top') ;
$self->{stepin_button} = $self->{button_bar}->Button(-text, => "Step In", @Devel::ptkdb::button_font,
-command => $stepInSub) ;
$self->{stepin_button}->pack(-side => 'left') ;
$self->{stepover_button} = $self->{button_bar}->Button(-text, => "Step Over", @Devel::ptkdb::button_font,
-command => $stepOverSub) ;
$self->{stepover_button}->pack(-side => 'left') ;
$self->{return_button} = $self->{button_bar}->Button(-text, => "Return", @Devel::ptkdb::button_font,
-command => $returnSub) ;
$self->{return_button}->pack(-side => 'left') ;
$self->{run_button} = $self->{button_bar}->Button(-background => 'green', -text, => "Run", @Devel::ptkdb::button_font,
-command => $runSub) ;
$self->{run_button}->pack(-side => 'left') ;
$self->{run_to_button} = $self->{button_bar}->Button(-text, => "Run To", @Devel::ptkdb::button_font,
-command => $runToSub) ;
$self->{run_to_button}->pack(-side => 'left') ;
$self->{breakpt_button} = $self->{button_bar}->Button(-text, => "Break", @Devel::ptkdb::button_font,
-command => sub { $self->SetBreakPoint ; } ) ;
$self->{breakpt_button}->pack(-side => 'left') ;
push @{$self->{DisableOnLeave}}, @$self{'stepin_button', 'stepover_button', 'return_button', 'run_button', 'run_to_button', 'breakpt_button'} ;
} # end of setup_menu_bar
sub edit_bookmarks {
my ($self) = @_ ;
my ($top) = $self->{main_window}->Toplevel(-title => "Edit Bookmarks") ;
my $list = $top->Scrolled('Listbox', -selectmode => 'multiple')->pack(-side => 'top', -fill => 'both', -expand => 1) ;
my $deleteSub = sub {
my $cnt = 0 ;
for( $list->curselection ) {
$list->delete($_ - $cnt++) ;
}
} ;
my $okaySub = sub {
$self->{'bookmarks'} = [ $list->get(0, 'end') ] ; # replace the bookmarks
} ;
my $frm = $top->Frame()->pack(-side => 'top', -fill => 'x', -expand => 1 ) ;
# Subroutine called when the 'okay' button is pressed
#
sub FindSearch {
my ($self, $entry, $btn, $regExp) = @_ ;
my (@switches, $result) ;
my $txt = $entry->get() ;
return if $txt eq "" ;
push @switches, "-forward" if $self->{fwdOrBack} eq "forward" ;
push @switches, "-backward" if $self->{fwdOrBack} eq "backward" ;
if( $regExp ) {
push @switches, "-regexp" ;
}
else {
push @switches, "-nocase" ; # if we're not doing regex we may as well do caseless search
}
$result = $self->{'text'}->search(@switches, $txt, $self->{search_start}) ;
# untag the previously found text
$self->{'text'}->tagRemove('search_tag', @{$self->{search_tag}}) if defined $self->{search_tag} ;
if( !$result || $result eq "" ) {
# No Text was found
$btn->flash() ;
$btn->bell() ;
delete $self->{search_tag} ;
$self->{'search_start'} = "0.0" ;
}
else { # text found
$self->{'text'}->see($result) ;
# set the insertion of the text as well
$self->{'text'}->markSet('insert' => $result) ;
my $len = length $txt ;
if( $self->{fwdOrBack} ) {
$self->{search_start} = "$result +$len chars" ;
$self->{search_tag} = [ $result, $self->{search_start} ] ;
}
else {
# backwards search
$self->{search_start} = "$result -$len chars" ;
$self->{search_tag} = [ $result, "$result +$len chars" ] ;
}
# tag the newly found text
$self->{'text'}->tagAdd('search_tag', @{$self->{search_tag}}) ;
} # end of text found
$entry->selectionRange(0, 'end') if $entry->can('selectionRange') ;
} # end of FindSearch
#
# Support for the Find Text... Menu command
#
sub FindText {
my ($self) = @_ ;
my ($top, $entry, $rad1, $rad2, $chk, $regExp, $frm, $okayBtn) ;
#
# if we already have the Find Text Window
# open don't bother openning another, bring
# the existing one to the front.
#
if( $self->{find_window} ) {
$self->{find_window}->raise() ;
$self->{find_text}->focus() ;
return ;
}
$self->{search_start} = $self->{'text'}->index('insert') if( $self->{search_start} eq "" ) ;
#
# Subroutine called when the 'Dismiss' button
# is pushed.
#
my $dismissSub = sub {
$self->{'text'}->tagRemove('search_tag', @{$self->{search_tag}}) if defined $self->{search_tag} ;
$self->{search_start} = "" ;
destroy {$self->{find_window}} ;
delete $self->{search_tag} ;
delete $self->{find_window} ;
} ;
#
# Construct a dialog that has an entry field, forward, backward, regex option, okay and cancel buttons
#
$top = $self->{main_window}->Toplevel(-title => "Find Text?") ;
$self->{find_text} = $top->Entry()->pack(-side => 'top', -fill => 'both', -expand => 1) ;
$frm = $top->Frame()->pack(-side => 'top', -fill => 'both', -expand => 1) ;
$self->{fwdOrBack} = 'forward' ;
$rad1 = $frm->Radiobutton(-text => "Forward", -value => 1, -variable => \$self->{fwdOrBack}) ;
$rad1->pack(-side => 'left', -fill => 'both', -expand => 1) ;
$rad2 = $frm->Radiobutton(-text => "Backward", -value => 0, -variable => \$self->{fwdOrBack}) ;
$rad2->pack(-side => 'left', -fill => 'both', -expand => 1) ;
$regExp = 0 ;
$chk = $frm->Checkbutton(-text => "RegExp", -variable => \$regExp) ;
$chk->pack(-side => 'left', -fill => 'both', -expand => 1) ;
# Okay and cancel buttons
# Bind a double click on the mouse button to the same action
# as pressing the Okay button
$okayBtn = $top->Button( -text => "Okay", -command => sub { $self->FindSearch($self->{find_text}, $okayBtn, $regExp) ; },
@Devel::ptkdb::button_font,
)->pack(-side => 'left', -fill => 'both', -expand => 1) ;
$self->{find_text}->bind('<Return>', sub { $self->FindSearch($self->{find_text}, $okayBtn, $regExp) ; }) ;
# stack so that we can update our 'Stack' menu when we stop.
#
# Refs: Progamming Perl 2nd Edition, Larry Wall, O'Reilly & Associates, Chapter 8
#
#
sub sub {
my ($result, @result) ;
#
# See NOTES(1)
#
$DB::subroutine_depth += 1 unless $DB::on ;
$DB::single = 0 if ( ($DB::step_over_depth < $DB::subroutine_depth) && ($DB::step_over_depth >= 0) && !$DB::on) ;
if( wantarray ) {
#
# array context
#
no strict ; # otherwise perl gripes about calling the sub by the reference
@result = &$DB::sub ; # call the subroutine by name
use strict ;
$DB::subroutine_depth -= 1 unless $DB::on ;
$DB::single = 1 if ($DB::step_over_depth >= $DB::subroutine_depth && !$DB::on) ;
return @result ;
}
elsif(defined wantarray) {
#
# scalar context
#
no strict ;
$result = &$DB::sub ;
use strict ;
$DB::subroutine_depth -= 1 unless $DB::on ;
$DB::single = 1 if ($DB::step_over_depth >= $DB::subroutine_depth && !$DB::on) ;
return $result ;
} else {
#
# void context
#
no strict ;
&$DB::sub ;
use strict ;
$DB::subroutine_depth -= 1 unless $DB::on ;
$DB::single = 1 if ($DB::step_over_depth >= $DB::subroutine_depth && !$DB::on) ;
return $result ;
return ;
}
} # end of sub
1 ; # return true value
# ptkdb.pm,v
# Revision 1.15 2004/03/31 02:08:40 aepage
# fixes for various lacks of backwards compatiblity in Tk804
# Added a 'bug report' item to the File Menu.
#
# Revision 1.14 2003/11/20 01:59:40 aepage
# version fix
#
# Revision 1.12 2003/11/20 01:46:45 aepage
# Hex Dumper and correction of some parameters for Tk804.025_beta6
#
# Revision 1.11 2003/06/26 13:42:49 aepage
# fix for chars at the end of win32 platforms.
#
# Revision 1.10 2003/05/12 14:38:34 aepage
# win32 pushback
#
# Revision 1.9 2003/05/12 13:46:46 aepage
# optmization of win32 line fixing
#
# Revision 1.8 2003/05/11 23:42:20 aepage
# fix to remove stray win32 chars
#
# Revision 1.7 2003/05/11 23:15:26 aepage
# email address changes, fixes for perl 5.8.0
#
# Revision 1.6 2002/11/28 19:17:43 aepage
# Changed many options to widgets and pack from bareword or 'bareword'
# to -bareword to support Tk804.024(Devel).
#
# Revision 1.5 2002/11/25 23:47:03 aepage
# A perl debugger package is required to define a subroutine name 'sub'.
# This routine is a 'proxy' for handling subroutine calls and allows the
# debugger pacakage to track subroutine depth so that it can implement
# 'step over', 'step in' and 'return' functionality. It must also
# handle the same context as the proxied routine; it must return a
# scalar where a scalar was being expected, an array where an array is
# being expected and a void where a void was being expected. Ptkdb was
# not handling the case for void. 99.9% of the time this will have no
# ill effects although it is being handled incorrectly. Ref Programming
# Perl 3rd Edition pg 827
#
# Revision 1.4 2002/10/24 17:07:10 aepage
# fix for warning for undefined value assigend to typeglob during restart
#
# Revision 1.3 2002/10/20 23:49:51 aepage
#
# changed email address to aepage@ptkdb.sourceforge.net
#
# localized $^W in dbeval
#
# fix for instances where there is no code in a package.
#
# Initialized $self->{'subs_list_cnt'} in the new constructor to 0 to
# prevent warnings with -w.
#
( run in 1.046 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )