File Coverage

blib/lib/Wx/Perl/DataWalker.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Wx::Perl::DataWalker;
use 5.008001;
use strict;
use warnings;

our $VERSION = '0.02';
our @ISA = qw(Wx::Frame);

use Scalar::Util qw(reftype blessed refaddr);
use Devel::Size ();
use Wx ':everything';
use Wx::Event ':everything';
require Wx::Perl::DataWalker::CurrentLevel;

use Class::XSAccessor
  getters => {
    stack        => 'stack',
  },
  accessors => {
    current_head => 'current_head',
  };


sub new {
  my $class = shift;
  my $config = shift;
  my $self = $class->SUPER::new(@_);

  $self->{global_head} = $config->{data} or die "Invalid data";
  my $rtype = reftype($self->{global_head});
  die "top-level display of CODE refs not supported!" if defined $rtype and $rtype eq 'CODE';

  $self->{show_size} = $config->{show_size} || 0;
  $self->{show_recur_size} = $config->{show_recur_size} || 0;

  my $hsizer = Wx::BoxSizer->new(Wx::wxHORIZONTAL);

  # tree view here...
#  $self->{current_level2} = Wx::Button->new(
#    $self, -1, "FOOO",
#    Wx::wxDefaultPosition,
#    Wx::wxDefaultSize,
#  );
#  $hsizer->Add($self->{current_level2}, Wx::wxEXPAND, Wx::wxEXPAND, Wx::wxALL, 2);

  my $buttonsizer = Wx::BoxSizer->new(Wx::wxHORIZONTAL);

  $self->{back_button} = Wx::Button->new( $self, -1, "<--" );
  $self->{reset_button} = Wx::Button->new( $self, -1, "Reset" );
  EVT_BUTTON( $self, $self->{back_button}, sub { $self->go_back(); } );
  EVT_BUTTON( $self, $self->{reset_button}, sub { $self->reset_head(); } );
  $buttonsizer->Add($self->{back_button}, 0, Wx::wxALL|Wx::wxALIGN_CENTER_VERTICAL, 2);
  $buttonsizer->Add($self->{reset_button}, 0, Wx::wxALL|Wx::wxALIGN_CENTER_VERTICAL, 2);

  # show-size radio boxes
  $self->{size_radio_box} = Wx::RadioBox->new(
    $self, -1, "Show approx. size",
    Wx::wxDefaultPosition, Wx::wxDefaultSize,
    [qw(No Yes Total)],
    Wx::wxRA_SPECIFY_COLS,
  );
  EVT_RADIOBOX(
    $self, $self->{size_radio_box}, sub {
      my $flag = $_[1]->GetInt();
      $self->{show_size}       = $flag    ? 1 : 0;
      $self->{show_recur_size} = $flag==2 ? 1 : 0;
      $self->update_size();
    }
  );
  $buttonsizer->Add($self->{size_radio_box}, 0, Wx::wxLEFT|Wx::wxALIGN_CENTER_VERTICAL|Wx::wxALIGN_RIGHT, 10);

  my $vsizer = Wx::BoxSizer->new(Wx::wxVERTICAL);
  $vsizer->Add($buttonsizer, 0, Wx::wxEXPAND|Wx::wxALL, 2);

  # the current level in the tree...
  my $curl = $self->{current_level} = Wx::Perl::DataWalker::CurrentLevel->new( $self, -1, );
  $self->update_size();
  $vsizer->Add($self->{current_level}, Wx::wxEXPAND, Wx::wxEXPAND|Wx::wxALL, 2);

  $hsizer->Add($vsizer, Wx::wxEXPAND, Wx::wxEXPAND|Wx::wxALL, 2);
  $self->SetSizer( $hsizer );
  $hsizer->SetSizeHints( $self );

  $self->reset_head();

  return $self;
}

sub update_size {
  my $self = shift;

  my $curl = $self->{current_level};
  $curl->show_size($self->{show_size});
  $curl->show_recur_size($self->{show_recur_size});
  $curl->refresh();
}

sub go_down {
  my $self = shift;
  my $where = shift;

  my $data = $self->current_head;
  my $target;
  my $reftype = reftype($data);
  if (!$reftype) {
    return();
  }
  elsif ($reftype eq 'SCALAR') {
    $target = $$data;
  }
  elsif ($reftype eq 'HASH') {
    $target = $data->{$where};
  }
  elsif ($reftype eq 'ARRAY') {
    $target = $data->[$where];
  }
  elsif ($reftype eq 'REF') {
    $target = $$data;
  }
  elsif ($reftype eq 'GLOB') {
    $target = *{$data}{$where};
  }
  else {
    return();
  }

  my $treftype = reftype($target);
  if (not $treftype and reftype(\$target) eq 'GLOB') {
    # work around my sucky understanding of GLOBS. Damn you, GLOB, damn you!
#    $self->current_head(\$target);
#    push @{$self->stack}, \$target;
#    $self->{current_level}->set_data(\$target);
#    return(1);
    # with kudos to Yves!
    no strict 'refs';
    $target = \*{"$target"};
    $treftype = reftype($target);
  }
  return() if not $treftype or $treftype eq 'CODE';
  # avoid direct recursion into self
  return() if $treftype eq $reftype and refaddr($target) eq refaddr($data);

  $self->current_head($target);
  push @{$self->stack}, $target;
  $self->{current_level}->set_data($target);
  return(1);
}

sub go_back {
  my $self = shift;
  my $stack = $self->stack;

  return() if @$stack == 1;

  pop(@$stack);
  $self->current_head($stack->[-1]);
  $self->{current_level}->set_data($stack->[-1]);

  return(1);
}


sub reset_head {
  my $self = shift;
  $self->{stack} = [$self->{global_head}];
  $self->current_head($self->{global_head});
  $self->{current_level}->set_data($self->current_head);
}

1;
__END__