lib/Language/Befunge/Debugger.pm

   1 #
   2 # This file is part of Language::Befunge.
   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;
  10
  11 use strict;
  12 use warnings;
  13
  14 use Language::Befunge;
  15 use Language::Befunge::Vector;
  16 use Tk; # should come before POE
  17 use Tk::Dialog;
  18 use Tk::TableMatrix;
  19 use POE;
  20
  21
  22 our $VERSION = '0.0.1';
  23
  24 #--
  25 # constructor
  26
  27 sub spawn {
  28     POE::Session->create(
  29         inline_states => {
  30             _start     => \&_on_start,
  31             # gui
  32             _b_next     => \&_on_b_next,
  33             _b_quit     => \&_on_b_quit,
  34             _tm_click   => \&_on_tm_click,
  35         },
  36         args => \@ARGV,
  37     );
  38 }
  39
  40 #--
  41 # private events
  42
  43 sub _on_start {
  44     my ($k, $h, $s, $file) = @_[ KERNEL, HEAP, SESSION, ARG0 ];
  45
  46     #-- load befunge file
  47     # FIXME: barf unless file exists
  48     my $bef = $h->{bef} = Language::Befunge->new( $file );
  49     $bef->set_ips( [ Language::Befunge::IP->new($bef->get_dimensions) ] );
  50     $bef->set_retval(0);
  51
  52
  53     #-- create gui
  54
  55     my $fh1 = $poe_main_window->Frame->pack(-fill=>'both', -expand=>1);
  56     my $tm = $fh1->Scrolled( 'TableMatrix',
  57         -scrollbars => 'osoe',
  58         -cols       => 80,
  59         -rows       => 25,
  60         -colwidth   => 3,
  61         -state      => 'disabled',
  62         -command    => sub { _get_cell_value($h->{bef}->get_torus,@_[1,2]) },
  63         -browsecmd  => $s->postback('_tm_click'),
  64     )->pack(-side=>'left', -fill=>'both', -expand=>1);
  65     $h->{w}{tm} = $tm;
  66
  67     # buttons
  68     my $fv = $fh1-> Frame->pack(-fill=>'x');
  69     my $fh11 = $fv->Frame->pack;
  70     my $b_quit = $fh11->Button(
  71         -text    => 'Quit',
  72         -command => $s->postback('_b_quit'),
  73     )->pack(-side=>'left');
  74     my $b_restart = $fh11->Button(
  75         -text    => 'Restart',
  76         -command => $s->postback('_b_restart'),
  77     )->pack(-side=>'left');
  78     my $fh12 = $fv->Frame->pack;
  79     my $b_pause = $fh12->Button(
  80         -text    => '||',
  81         -command => $s->postback('_b_pause'),
  82     )->pack(-side=>'left');
  83     my $b_next = $fh12->Button(
  84         -text    => '>',
  85         -command => $s->postback('_b_next'),
  86     )->pack(-side=>'left');
  87     my $b_continue = $fh12->Button(
  88         -text    => '>>',
  89         -command => $s->postback('_b_continue'),
  90     )->pack(-side=>'left');
  91
  92     # current position
  93     my $vec = Language::Befunge::Vector->new_zeroes(2);
  94     my $val = $h->{bef}->get_torus->get_value($vec);
  95     my $chr = chr $val;
  96     my $l_curpos = $h->{w}{l_curpos} = $poe_main_window->Label(
  97         -text    => "Position: (0,0) $chr (ord=$val)",
  98         -justify => 'left',
  99         -anchor  => 'w'
 100     )->pack(-fill=>'x', -expand=>1);
 101
 102     # stack
 103     my $l_stack = $h->{w}{l_stack} = $poe_main_window->Label(
 104         -text    => 'Stack = []',
 105         -justify => 'left',
 106         -anchor  => 'w'
 107     )->pack(-fill=>'x', -expand=>1);
 108
 109     #FIXME: lists of ips
 110
 111     #-- various initializations
 112     $tm->tagCell( 'current', '0,0' );
 113     $tm->tagConfigure( 'current', -bg => 'red' );
 114     # FIXME: color decay
 115 }
 116
 117 #--
 118 # gui events
 119
 120 sub _on_b_next {
 121     my ($h) = $_[HEAP];
 122
 123     my $bef = $h->{bef};
 124     my $tm  = $h->{w}{tm};
 125
 126     if ( scalar @{ $bef->get_ips } == 0 ) {
 127         # no more ip - end of program
 128         return;
 129     }
 130
 131     # update gui
 132     # FIXME: tag delete
 133
 134     # advance next ip
 135     my $ip = shift @{ $bef->get_ips };
 136     $bef->set_curip($ip);
 137     $bef->process_ip;
 138
 139     # update gui
 140     my $vec = $ip->get_position;
 141     my $val = $bef->get_torus->get_value($vec);
 142     my $chr = chr $val;
 143     my ($curx, $cury) = $vec->get_all_components;
 144     $tm->see("$cury,$curx");
 145     $tm->tagCell( 'current', "$cury,$curx" );
 146     # FIXME: more than 1 ip = different colors
 147     my $stack = $ip->get_toss;
 148     $h->{w}{l_stack} ->configure( -text => "Stack = [@$stack]" );
 149     $h->{w}{l_curpos}->configure( -text => "Position: ($curx,$cury) $chr (ord=$val)" );
 150
 151
 152     # end of tick: no more ips to process
 153     if ( scalar @{ $bef->get_ips } == 0 ) {
 154         $bef->set_ips( $bef->get_newips );
 155         $bef->set_newips( [] );
 156     }
 157
 158
 159 }
 160
 161 sub _on_b_quit {
 162     $poe_main_window->destroy;
 163     #exit;
 164 }
 165
 166 sub _on_tm_click {
 167     my ($h, $arg) = @_[HEAP, ARG1];
 168     my ($old, $new) = @$arg;
 169     my ($x,$y) = split /,/, $new;
 170     my $vec = Language::Befunge::Vector->new(2, $y, $x);
 171     my $val = $h->{bef}->get_torus->get_value($vec);
 172     my $chr = chr $val;
 173     $poe_main_window->Dialog( -text => "($x,$y) = $val = '$chr'" )->Show;
 174 }
 175
 176
 177 #--
 178 # private subs
 179
 180 sub _get_cell_value {
 181     my ($torus, $row, $col) = @_;
 182     my $v = Language::Befunge::Vector->new(2, $col, $row);
 183     return chr( $torus->get_value($v) );
 184 }
 185
 186
 187 1;
 188
 189 __END__
 190
 191
 192 =head1 NAME
 193
 194 Language::Befunge::Debugger - a graphical debugger for Language::Befunge
 195
 196
 197
 198 =head1 SYNOPSYS
 199
 200     $ jqbefdb
 201
 202
 203
 204 =head1 DESCRIPTION
 205
 206 CPANPLUS::Dist::Mdv is a distribution class to create mandriva packages
 207 from CPAN modules, and all its dependencies. This allows you to have
 208 the most recent copies of CPAN modules installed, using your package
 209 manager of choice, but without having to wait for central repositories
 210 to be updated.
 211
 212 You can either install them using the API provided in this package, or
 213 manually via rpm.
 214
 215 Some of the bleading edge CPAN modules have already been turned into
 216 mandriva packages for you, and you can make use of them by adding the
 217 cooker repositories (main & contrib).
 218
 219 Note that these packages are built automatically from CPAN and are
 220 assumed to have the same license as perl and come without support.
 221 Please always refer to the original CPAN package if you have questions.
 222
 223
 224
 225 =head1 CLASS METHODS
 226
 227 =head2 Language::Befunge::Debugger->spawn;
 228
 229 Create a
 230
 231
 232
 233 =head1 BUGS
 234
 235 Please report any bugs or feature requests to C<< <
 236 language-befunge-debugger at rt.cpan.org> >>, or through the web
 237 interface at
 238 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Language-Befunge-Debugger>.
 239 I will be notified, and then you'll automatically be notified of
 240 progress on your bug as I make changes.
 241
 242
 243
 244 =head1 SEE ALSO
 245
 246 L<Language::Befunge>, L<POE>, L<Tk>.
 247
 248
 249 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt> -
 250 feel free to join us.
 251
 252
 253 You can also look for information on this module at:
 254
 255 =over 4
 256
 257 =item * AnnoCPAN: Annotated CPAN documentation
 258
 259 L<http://annocpan.org/dist/Language-Befunge-Debugger>
 260
 261 =item * CPAN Ratings
 262
 263 L<http://cpanratings.perl.org/d/Language-Befunge-Debugger>
 264
 265 =item * RT: CPAN's request tracker
 266
 267 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Language-Befunge-Debugger>
 268
 269 =back
 270
 271
 272
 273 =head1 AUTHOR
 274
 275 Jerome Quelin, C<< <jquelin at cpan.org> >>
 276
 277
 278
 279 =head1 COPYRIGHT & LICENSE
 280
 281 Copyright (c) 2007 Jerome Quelin, all rights reserved.
 282
 283 This program is free software; you can redistribute it and/or modify
 284 it under the same terms as Perl itself.
 285
 286
 287 =cut
 288