lib/Language/Befunge/Debugger/Breakpoints.pm

   1 #
   2 # This file is part of Language::Befunge::Debugger.
   3 # Copyright (c) 2007 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8
   9 package Language::Befunge::Debugger::Breakpoints;
  10
  11 use strict;
  12 use warnings;
  13
  14 use List::MoreUtils qw[ firstidx ];
  15 use Readonly;
  16 use Tk; # should come before POE
  17 use Tk::Dialog;
  18 use Tk::FBox;
  19 use Tk::TableMatrix;
  20 use Tk::ToolBar;
  21 use POE;
  22
  23
  24 #--
  25 # constructor
  26
  27 #
  28 # my $id = Language::Befunge::Debugger::Breakpoints->spawn( %opts );
  29 #
  30 # create a new debugger gui for a befunge script. refer to the embedded
  31 # pod for an explanation of the supported options.
  32 #
  33 sub spawn {
  34     my ($class, %opts) = @_;
  35
  36     my $session = POE::Session->create(
  37         inline_states => {
  38             _start     => \&_on_start,
  39             _stop      => sub { print "ouch!\n" },
  40             # public events
  41             breakpoint_add         => \&_do_breakpoint_add,
  42             visibility_toggle      => \&_do_visibility_toggle,
  43             # private events
  44             # gui events
  45             _b_breakpoint_remove   => \&_on_b_breakpoint_remove,
  46         },
  47         args => \%opts,
  48     );
  49     return $session->ID;
  50 }
  51
  52
  53 #--
  54 # public events
  55
  56 #
  57 # breakpoint_add( $brkpt );
  58 #
  59 # Add $brkpt to the list of breakpoints.
  60 #
  61 sub _do_breakpoint_add {
  62     my ($h, $brkpt) = @_[HEAP, ARG0];
  63
  64     my @elems = $h->{list}->get(0, 'end');
  65     push @elems, $brkpt;
  66
  67     $h->{list}->delete(0, 'end');
  68     $h->{list}->insert(0, sort @elems);
  69     $h->{list}->selectionSet( firstidx { $_ eq $brkpt } $h->{list}->get(0, 'end') );
  70     $h->{but_remove}->configure(-state => 'normal' );
  71 }
  72
  73
  74 #
  75 # visibility_toggle();
  76 #
  77 # Request window to be hidden / shown depending on its previous state.
  78 #
  79 sub _do_visibility_toggle {
  80     my ($h) = $_[HEAP];
  81
  82     my $method = $h->{mw}->state eq 'normal' ? 'withdraw' : 'deiconify';
  83     $h->{mw}->$method;
  84 }
  85
  86
  87 #--
  88 # private events
  89
  90 #
  91 # _on_start( \%opts );
  92 #
  93 # session initialization. %opts is received from spawn();
  94 #
  95 sub _on_start {
  96     my ($k, $h, $from, $s, $opts) = @_[KERNEL, HEAP, SENDER, SESSION, ARG0];
  97
  98     #-- create gui
  99
 100     my $top = $opts->{parent}->Toplevel(-title => 'Breakpoints');
 101     $h->{mw}   = $top;
 102     $h->{list} = $top->Listbox->pack;
 103     $h->{but_remove} = $top->Button(
 104         -text    => 'Remove',
 105         -state   => 'disabled',
 106         -width   => 6,
 107         -command => $s->postback('_b_breakpoint_remove')
 108     )->pack(-side=>'left',-fill=>'x',-expand=>1);
 109     $top->Button(
 110         -text    => 'Close',
 111         -width   => 6,
 112         -command => $s->postback('visibility_toggle')
 113     )->pack(-side=>'left',-fill=>'x',-expand=>1);
 114
 115     # trap some events
 116     $top->protocol( WM_DELETE_WINDOW => $s->postback('visibility_toggle') );
 117     $top->bind( '<F8>', $s->postback('visibility_toggle') );
 118
 119
 120     $top->update;               # force redraw
 121     $top->resizable(0,0);
 122     my ($maxw,$maxh) = $top->geometry =~ /^(\d+)x(\d+)/;
 123     $top->maxsize($maxw,$maxh); # bug in resizable: minsize in effet but not maxsize
 124
 125
 126     # -- other inits
 127     $h->{parent_session} = $from->ID;
 128     # initial breakpoint?
 129     $k->yield('breakpoint_add', $opts->{breakpoint}) if exists $opts->{breakpoint};
 130 }
 131
 132
 133 #--
 134 # gui events
 135
 136 #
 137 # _b_breakpoint_remove();
 138 #
 139 # called when the user wants to remove a breakpoint.
 140 #
 141 sub _on_b_breakpoint_remove {
 142     my ($k, $h) = @_[KERNEL, HEAP];
 143     my ($idx) = $h->{list}->curselection;
 144     return unless defined $idx;
 145     my $brkpt = $h->{list}->get($idx);
 146     $h->{list}->delete($idx);
 147     $k->post( $h->{parent_session}, 'breakpoint_remove', $brkpt );
 148
 149     $h->{but_remove}->configure(-state=>'disabled') if $h->{list}->index('end') == 0;
 150 }
 151
 152
 153 1;
 154
 155 __END__
 156
 157
 158 =head1 NAME
 159
 160 Language::Befunge::Debugger::Breakpoints - a window listing breakpoints
 161
 162
 163
 164 =head1 SYNOPSYS
 165
 166     my $id = Language::Befunge::Debugger::Breakpoints->spawn(%opts);
 167     $kernel->post( $id, 'visibility_toggle' );
 168
 169
 170
 171 =head1 DESCRIPTION
 172
 173 LBD::Breakpoints implements a POE session, creating a Tk window listing
 174 the breakpoints set in a debugger session. The window can be hidden at
 175 will.
 176
 177
 178
 179 =head1 CLASS METHODS
 180
 181 =head2 my $id = Language::Befunge::Debugger::Breakpoints->spawn( %opts );
 182
 183 Create a window listing breakpoints, and return the associated POE
 184 session ID. One can pass the following options:
 185
 186 =over 4
 187
 188 =item parent => $mw
 189
 190 A Tk window that will be the parent of the toplevel window created. This
 191 parameter is mandatory.
 192
 193
 194 =item breakpoint => $brkpt
 195
 196 An optional breakpoint to be added during session creation.
 197
 198
 199 =back
 200
 201
 202 =head1 PUBLIC EVENTS
 203
 204 The newly created POE session accepts the following events:
 205
 206
 207 =over 4
 208
 209 =item breakpoint_add( $brkpt )
 210
 211 Add a breakpoint in the list of breakpoints.
 212
 213
 214 =item visibility_toggle()
 215
 216 Request the window to be hidden or restaured, depending on its previous
 217 state. Note that closing the window is actually interpreted as hiding
 218 the window.
 219
 220
 221 =back
 222
 223
 224
 225 =head1 SEE ALSO
 226
 227 L<Language::Befunge::Debugger>.
 228
 229
 230
 231 =head1 AUTHOR
 232
 233 Jerome Quelin, C<< <jquelin at cpan.org> >>
 234
 235
 236
 237 =head1 COPYRIGHT & LICENSE
 238
 239 Copyright (c) 2007 Jerome Quelin, all rights reserved.
 240
 241 This program is free software; you can redistribute it and/or modify
 242 it under the same terms as Perl itself.
 243
 244
 245 =cut
 246