r36791 - in /branches/upstream/libwx-perl-datawalker-perl: ./ current/ current/lib/ current/lib/Wx/ current/lib/Wx/Perl/ current/lib/Wx/Perl/DataWalker/ current/script/ current/t/
ryan52-guest at users.alioth.debian.org
ryan52-guest at users.alioth.debian.org
Sat May 30 09:22:19 UTC 2009
Author: ryan52-guest
Date: Sat May 30 09:22:14 2009
New Revision: 36791
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=36791
Log:
[svn-inject] Installing original source of libwx-perl-datawalker-perl
Added:
branches/upstream/libwx-perl-datawalker-perl/
branches/upstream/libwx-perl-datawalker-perl/current/
branches/upstream/libwx-perl-datawalker-perl/current/Changes
branches/upstream/libwx-perl-datawalker-perl/current/MANIFEST
branches/upstream/libwx-perl-datawalker-perl/current/META.yml
branches/upstream/libwx-perl-datawalker-perl/current/Makefile.PL
branches/upstream/libwx-perl-datawalker-perl/current/lib/
branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/
branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/
branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker/
branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker.pm
branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker/CurrentLevel.pm
branches/upstream/libwx-perl-datawalker-perl/current/script/
branches/upstream/libwx-perl-datawalker-perl/current/script/dataWalker.pl
branches/upstream/libwx-perl-datawalker-perl/current/t/
branches/upstream/libwx-perl-datawalker-perl/current/t/Wx-Perl-DataWalker.t
Added: branches/upstream/libwx-perl-datawalker-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/Changes?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/Changes (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/Changes Sat May 30 09:22:14 2009
@@ -1,0 +1,8 @@
+Revision history for Perl extension Wx::Perl::DataWalker.
+
+0.02 Sun Mar 29 12:05 2009
+ - use overload::StrVal() to disable overloading where appropriate
+
+0.01 Sat Mar 21 14:40 2009
+ - original version
+
Added: branches/upstream/libwx-perl-datawalker-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/MANIFEST?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/MANIFEST (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/MANIFEST Sat May 30 09:22:14 2009
@@ -1,0 +1,8 @@
+Changes
+lib/Wx/Perl/DataWalker.pm
+lib/Wx/Perl/DataWalker/CurrentLevel.pm
+Makefile.PL
+MANIFEST This list of files
+script/dataWalker.pl
+t/Wx-Perl-DataWalker.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libwx-perl-datawalker-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/META.yml?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/META.yml (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/META.yml Sat May 30 09:22:14 2009
@@ -1,0 +1,24 @@
+--- #YAML:1.0
+name: Wx-Perl-DataWalker
+version: 0.02
+abstract: Perl extension for blah blah blah
+author:
+ - Steffen Mueller <smueller at cpan.org>
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ Class::XSAccessor: 0.06
+ Devel::Size: 0.71
+ Scalar::Util: 0
+ Wx: 0.88
+ YAML::XS: 0.32
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.48
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
Added: branches/upstream/libwx-perl-datawalker-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/Makefile.PL?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/Makefile.PL (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/Makefile.PL Sat May 30 09:22:14 2009
@@ -1,0 +1,17 @@
+use 5.008001;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'Wx::Perl::DataWalker',
+ VERSION_FROM => 'lib/Wx/Perl/DataWalker.pm', # finds $VERSION
+ PREREQ_PM => {
+ 'Wx' => '0.88',
+ 'YAML::XS' => '0.32',
+ 'Scalar::Util' => '0',
+ 'Devel::Size' => '0.71',
+ 'Class::XSAccessor' => '0.06',
+ }, # e.g., Module::Name => 1.1
+ ABSTRACT_FROM => 'lib/Wx/Perl/DataWalker.pm', # retrieve abstract from module
+ AUTHOR => 'Steffen Mueller <smueller at cpan.org>',
+);
Added: branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker.pm?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker.pm (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker.pm Sat May 30 09:22:14 2009
@@ -1,0 +1,242 @@
+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__
+
+=head1 NAME
+
+Wx::Perl::DataWalker - Perl extension for blah blah blah
+
+=head1 SYNOPSIS
+
+ # alternatively, see the dataWalker.pl script in this distribution!
+ use Wx::Perl::DataWalker;
+
+ my $data_to_browse = {
+ # complex data structure.
+ # Good test: \%::
+ };
+
+ package MyWalkerDialog;
+ our @ISA = qw(Wx::App);
+
+ sub OnInit {
+ my $self = shift;
+
+ my $frame = Wx::Perl::DataWalker->new(
+ {data => $data_to_browse},
+ undef, -1,
+ "dataWalker",
+ );
+ $self->SetTopWindow($frame);
+ $frame->Show(1);
+ $frame->SetSize(500,500);
+
+ return 1;
+ }
+
+ package main;
+ my $app = MyWalkerDialog->new();
+ $app->MainLoop();
+
+
+=head1 DESCRIPTION
+
+C<Wx::Perl::DataWalker> implements a C<Wx::Frame> subclass that
+shows a relatively simple Perl data structure browser.
+After opening such a frame and supplying it with a reference to an
+essentially arbitrary data structure, you can visually browse it
+by double-clicking references.
+
+So far, there is no tree view but only a display of the current level of the
+data structure. You can traverse back up the structure with a I<back> button.
+
+Optionally, C<Wx::Perl::DataWalker> displays the (approximate!) size of the
+data structure using C<Devel::Size>.
+
+=head1 SEE ALSO
+
+L<Wx>, L<Devel::Size>
+
+L<Padre::Plugin::DataWalker>
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller at cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009 by Steffen Mueller
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
Added: branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker/CurrentLevel.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker/CurrentLevel.pm?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker/CurrentLevel.pm (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/lib/Wx/Perl/DataWalker/CurrentLevel.pm Sat May 30 09:22:14 2009
@@ -1,0 +1,424 @@
+package Wx::Perl::DataWalker::CurrentLevel;
+use 5.008001;
+use strict;
+use warnings;
+
+use Scalar::Util qw(blessed reftype weaken);
+use Wx;
+
+our $VERSION = '0.01';
+our @ISA = qw(Wx::ListCtrl);
+
+use constant {
+ DISPLAY_UNINITIALIZED => 0,
+ DISPLAY_SCALAR => 1,
+ DISPLAY_ARRAY => 2,
+ DISPLAY_HASH => 3,
+ DISPLAY_GLOB => 4,
+};
+
+use constant GLOB_THINGS => [qw(NAME PACKAGE SCALAR ARRAY HASH CODE IO GLOB FORMAT)];
+
+use Class::XSAccessor
+ getters => {
+ parent => 'parent',
+ },
+ accessors => {
+ show_size => 'show_size',
+ show_recur_size => 'show_recur_size',
+ };
+
+require overload;
+
+sub new {
+ my $class = shift;
+ my ($parent, $id, $pos, $size) = @_;
+ my $self = $class->SUPER::new(
+ $parent, $id, $pos||Wx::wxDefaultPosition, $size||Wx::wxDefaultSize, Wx::wxLC_REPORT|Wx::wxLC_VIRTUAL
+ );
+ $self->{parent} = $parent;
+ weaken($self->{parent});
+
+ # Double-click a function name
+ Wx::Event::EVT_LIST_ITEM_ACTIVATED( $self, $self,
+ sub {
+ $self->on_list_item_activated($_[1]);
+ }
+ );
+
+ my $imglist = $self->get_icon_list();
+ $self->AssignImageList($imglist, Wx::wxIMAGE_LIST_SMALL);
+
+ $self->{show_size} = 0;
+ $self->{show_recur_size} = 0;
+ $self->{display_mode} = DISPLAY_UNINITIALIZED;
+ $self->set_data('');
+
+ return $self;
+}
+
+sub refresh {
+ my $self = shift;
+ $self->set_data($self->{data});
+}
+
+sub set_data {
+ my $self = shift;
+ my $data = shift;
+
+ my $reftype = reftype($data);
+ return() if defined $reftype and $reftype eq 'CODE';
+
+ $self->{data} = $data;
+ delete $self->{hash_cache};
+
+ if (!$reftype) {
+ $self->_set_scalar();
+ }
+ elsif ($reftype eq 'HASH') {
+ $self->_set_hash();
+ }
+ elsif ($reftype eq 'ARRAY') {
+ $self->_set_array();
+ }
+ elsif ($reftype eq 'GLOB') {
+ $self->_set_glob();
+ }
+ else {
+ $self->_set_scalar();
+ }
+
+ $self->_set_width;
+ return(1);
+}
+
+#####################################
+# display methods
+
+sub OnGetItemText {
+ my $self = shift;
+ my $itemno = shift;
+ my $colno = shift;
+ my $data = $self->{data};
+
+ if ($self->{display_mode} == DISPLAY_SCALAR) {
+ $colno == 0 and return reftype($data)||'';
+ $colno == 1 and return blessed($data)||'';
+ $colno == 2 and $self->show_size() and return $self->calc_size($$data);
+ return defined($$data) ? overload::StrVal($$data) : 'undef';
+ }
+ elsif ($self->{display_mode} == DISPLAY_ARRAY) {
+ $colno == 0 and return $itemno;
+ my $item = $data->[$itemno];
+ $colno == 1 and return reftype($item)||'';
+ $colno == 2 and return blessed($item)||'';
+ $colno == 3 and $self->show_size() and return $self->calc_size($item);
+ return defined($item) ? overload::StrVal($item) : 'undef';
+ }
+ elsif ($self->{display_mode} == DISPLAY_HASH) {
+ my $key = $self->{hash_cache}[$itemno];
+ $colno == 0 and return $key;
+ my $item = $data->{$key};
+ $colno == 1 and return reftype($item)||'';
+ $colno == 2 and return blessed($item)||'';
+ $colno == 3 and $self->show_size() and return $self->calc_size($item);
+ return defined($item) ? overload::StrVal($item) : 'undef';
+ }
+ elsif ($self->{display_mode} == DISPLAY_GLOB) {
+ $colno == 0 and return GLOB_THINGS->[$itemno];
+ my $item = *{$data}{GLOB_THINGS->[$itemno]};
+ $colno == 1 and return reftype($item)||'';
+ $colno == 2 and return blessed($item)||'';
+ $colno == 3 and $self->show_size() and return $self->calc_size($item);
+ return defined($item) ? overload::StrVal($item) : 'undef';
+ }
+
+}
+
+
+{
+ # this is an optimization explicitly allowed according to the wx docs.
+ my $undef_attr = Wx::ListItemAttr->new();
+ $undef_attr->SetTextColour(Wx::Colour->new("gray"));
+
+ sub OnGetItemAttr {
+ my $self = shift;
+ my $itemno = shift;
+ my $data = $self->{data};
+
+ # colour the undef's gray!
+ if ($self->{display_mode} == DISPLAY_SCALAR) {
+ return defined($$data) ? undef : $undef_attr;
+ }
+ elsif ($self->{display_mode} == DISPLAY_ARRAY) {
+ my $item = $data->[$itemno];
+ return defined($item) ? undef : $undef_attr;
+ }
+ elsif ($self->{display_mode} == DISPLAY_HASH) {
+ my $key = $self->{hash_cache}[$itemno];
+ my $item = $data->{$key};
+ return defined($item) ? undef : $undef_attr;
+ }
+ elsif ($self->{display_mode} == DISPLAY_GLOB) {
+ my $item = *{$data}{GLOB_THINGS->[$itemno]};
+ return defined($item) ? undef : $undef_attr;
+ }
+ }
+}
+
+
+sub OnGetItemImage {
+ my $self = shift;
+ my $itemno = shift;
+ my $data = $self->{data};
+
+ if ($self->{display_mode} == DISPLAY_SCALAR) {
+ return $self->ref_to_icon(reftype($$data));
+ }
+ elsif ($self->{display_mode} == DISPLAY_ARRAY) {
+ my $item = $data->[$itemno];
+ return $self->ref_to_icon(reftype($item));
+ }
+ elsif ($self->{display_mode} == DISPLAY_HASH) {
+ my $key = $self->{hash_cache}[$itemno];
+ my $item = $data->{$key};
+ return $self->ref_to_icon(reftype($item));
+ }
+ elsif ($self->{display_mode} == DISPLAY_GLOB) {
+ my $item = *{$data}{GLOB_THINGS->[$itemno]};
+ return $self->ref_to_icon(reftype($item));
+ }
+ return(-1);
+}
+
+
+sub calc_size {
+ my $self = shift;
+ my $data = shift;
+
+ return(
+ $self->show_recur_size() ? Devel::Size::total_size(\$data) : Devel::Size::size($data)
+ );
+}
+
+######################
+# setup the display data type
+
+sub _set_scalar {
+ my $self = shift;
+ $self->{display_mode} = DISPLAY_SCALAR;
+ $self->ClearAll();
+ $self->SetItemCount(1);
+
+ # reverse insert for extensibility
+ $self->InsertColumn(0, "Value");
+ $self->InsertColumn(0, "Size") if $self->show_size();
+ $self->InsertColumn(0, "Class");
+ $self->InsertColumn(0, "RefType");
+ return();
+}
+
+sub _set_hash {
+ my $self = shift;
+
+ $self->{display_mode} = DISPLAY_HASH;
+ $self->ClearAll();
+ $self->SetItemCount(scalar keys %{$self->{data}});
+ $self->{hash_cache} = [sort keys %{$self->{data}}];
+ $self->InsertColumn(0, "Value");
+ $self->InsertColumn(0, "Size") if $self->show_size();
+ $self->InsertColumn(0, "Class");
+ $self->InsertColumn(0, "RefType");
+ $self->InsertColumn(0, "Key");
+ return();
+}
+
+sub _set_array {
+ my $self = shift;
+
+ $self->{display_mode} = DISPLAY_ARRAY;
+ $self->ClearAll();
+ $self->SetItemCount(scalar @{$self->{data}});
+ $self->InsertColumn(0, "Value");
+ $self->InsertColumn(0, "Size") if $self->show_size();
+ $self->InsertColumn(0, "Class");
+ $self->InsertColumn(0, "RefType");
+ $self->InsertColumn(0, "Index");
+ return();
+}
+
+
+sub _set_glob {
+ my $self = shift;
+ $self->{display_mode} = DISPLAY_GLOB;
+ $self->ClearAll();
+ $self->SetItemCount(scalar @{GLOB_THINGS()});
+ $self->InsertColumn(0, "Value");
+ $self->InsertColumn(0, "Size") if $self->show_size();
+ $self->InsertColumn(0, "Class");
+ $self->InsertColumn(0, "RefType");
+ $self->InsertColumn(0, "THING");
+ return();
+}
+
+
+sub _set_width {
+ my $self = shift;
+# Can't work in virtual mode...
+# foreach my $col (0..$cols-1) {
+# $self->SetColumnWidth( $col, Wx::wxLIST_AUTOSIZE );
+# $self->SetColumnWidth( $col, 70 ) if $self->GetColumnWidth( $col ) < 70;
+# }
+
+ my $widths;
+ my $size = $self->show_size();
+ for ($self->{display_mode}) {
+ if ($_ == DISPLAY_SCALAR) {
+ $widths = [80, 90, $size?(100):(), 200];
+ }
+ elsif ($_ == DISPLAY_ARRAY) {
+ my $chars = length(scalar(@{$self->{data}}));
+ $chars = 6 if $chars < 6;
+ $widths = [$chars*11, 80, 90, $size?(100):(), 200];
+ }
+ elsif ($_ == DISPLAY_HASH) {
+ $widths = [100, 80, 90, $size?(100):(), 200];
+ }
+ elsif ($_ == DISPLAY_GLOB) {
+ $widths = [100, 80, 90, $size?(100):(), 200];
+ }
+ }
+ return() unless $widths;
+
+ my $cols = $self->GetColumnCount();
+ foreach my $col (0..$cols-1) {
+ $self->SetColumnWidth( $col, $widths->[$col] );
+ }
+
+}
+
+
+
+###################################
+# event handlers
+
+sub on_list_item_activated {
+ my $self = shift;
+ my $event = shift;
+
+ my $row = $event->GetIndex();
+ #my $col = $event->GetColumn();
+
+ my $key;
+ for ($self->{display_mode}) {
+ $_ == DISPLAY_SCALAR and $key = undef, last;
+ $_ == DISPLAY_ARRAY and $key = $row, last;
+ $_ == DISPLAY_HASH and $key = $self->{hash_cache}[$row], last;
+ $_ == DISPLAY_GLOB and $key = GLOB_THINGS->[$row], last;
+ }
+
+ $self->parent->go_down($key);
+}
+
+
+###################################
+# icon storage
+
+{
+ my %icons = (
+ 'array' => <<'HERE',
+iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A
+/wD/oL2nkwAAAU1JREFUOMud0z1IllEYxvGfJPU2CE2FVENEFKQRGURbW7MEOjs1RGs01iBRi63R
+GO2tJUpTS1FDGBGCS5EfQ4RU9qFXy20d5PUtvOAM5zrX+Z/7fs552KJwLNwJL8Nq+BWWwnS4GgZ0
+U9gT7taG9BjL4dLWzZ0wU4Gf4X64EPaF3eFQGA+zDehyC7hX5ocwoofCRFX5IwwJZ8JGWAun/IfC
+jTrwQXv6VBM4HubCSji/WXazfrC8ReFdTUaawOOm1xddAJ3yvgnfa9JpAl/LOxvOdQGMl/eqH33l
+79qm5fVm436M4VZZt4WFop1ugtNNC8+7vIUv4cpm+GGZkw3gRHgTFusjroX3Bb4eBtsruViA1XDU
+ThSeFORtOLITwIEwX5DP4WYYDntrDIVr4XU4uR1kMDz9x4/0LBzuVUlfGA2PwsewHj7VwxrL3yv/
+o99l+f7MpBeL2gAAAABJRU5ErkJggg==
+HERE
+ 'scalar' => <<'HERE',
+iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A
+/wD/oL2nkwAAAMlJREFUOMulkysOwkAURU+LxIADjWMBSBy2LAAP1SwAywZIMKwC2SBI2AACNB9P
+QoIAEpKLeU0qWmZKJ3mZN5m5531mBhxDoF/7IRVHWBB1KNgI7rZ+CNaCAR4pxwIVmQ/gaodXgrb5
+TUEkSHwAbxM1fJqYB9ga4CiYm98VBL6AjmCfU/9ZMPaFBIK+YGbiUwY0LVuSbJ6kmfwLqBvg4xLs
+BCNBKwXYdS7NvzgjZuyV08zYBegJFoKD4GmimyARRGXrr1X9jc5X+AVi1ZMjWoXKsgAAAABJRU5E
+rkJggg==
+HERE
+ 'hash' => <<'HERE',
+iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A
+/wD/oL2nkwAAAOtJREFUOMvNk7FqAlEQRU8iWW20sEm37NcIgn+hEfINC1aBZbEUY8g/CP6OiE3U
+TohbJ3DT3MBj2V0tfdV9M+8OM4d5cBdHEAneBRfBt2AheCq9GQm2gqiqQCaQ4EXwav0W5DuCvWBQ
+18HBpr7g2foryM8E66YRfm16ELSsf5xLBGdB3FTgFHTQtz46txGk1yDObRoLJta5YCjYCbqCpQFf
+DDyiBOlTUPjBStCzeViCPLXOrnWVCjYVkP9HPDSZY4NLKiA/hpDrCqwFs+B+vLkDwcBL0wlieRXk
+upXeCkaleFvwYciFdfs+PuIfzS2y8qBa0XcAAAAASUVORK5CYII=
+HERE
+ 'code' => <<'HERE',
+iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A
+/wD/oL2nkwAAAOlJREFUOMvNk61OQ0EYRE8ABalAFIcAUxJwON4ARQIKAQ7NO+BBIkgwBFLZpL7B
+oRBIRA0IDA0YuOEvHMyImyb3plR13Tc7czY72YWJW8K8cC4MhE/hRtj6D6ArKBwJc8KO8DFqeEb4
+CmC2pO+NClhKWGF73A4eAngRVsYpsBD6gTwKi0Oeb+GpCnCS4HKpzHuhmf0p4Ue4rAIMEppOoe3M
+t0JDWM28UQUoYmiUTjyLdi1cCFd1HfRi3h3Sj6MXwkIdYF14F56FzVyjKRxG/xXuhFYdZE3oCK95
+VH3hVGgJB4G8CfuT8fn+ANlvk1fzzFNCAAAAAElFTkSuQmCC
+HERE
+ 'glob' => <<'HERE',
+iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A
+/wD/oL2nkwAAAKFJREFUOMvN0k1OAlEQBODvifE+spnhOh7DxJXEJazhRKBbuAPhCMaZcvMWhAw/
+xgX0rrrS3VWV5u4r5Bz/8N8Dj0fXpvjBR+F7QM0TXjEqvA3JXYY+bEJzaCE0td+H5TnPk/AVujAL
+CfOKP0N7TXAlvIRdXbCruPwlxFzAJ6faKrWr0q+3cCHENmwrvzhlYY93jAvrQ6KwwnPl9/fzibev
+X+/lWAPE64K3AAAAAElFTkSuQmCC
+HERE
+ 'empty' => <<'HERE',
+iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A
+/wD/oL2nkwAAABJJREFUOMtjYBgFo2AUjAIIAAAEEAABhT+qcgAAAABJRU5ErkJggg==
+HERE
+ );
+
+ my %ref_to_icon = (
+ qw(
+ SCALAR 1
+ ARRAY 2
+ HASH 3
+ CODE 4
+ GLOB 5
+ REF 1
+ )
+ );
+
+ sub get_icon_list {
+ my $self = shift;
+ _icons_to_objects();
+
+ my $imglist = Wx::ImageList->new(16, 16, 0, 0);
+
+ $imglist->Add( $icons{$_} ) foreach qw(empty scalar array hash code glob);
+
+ return $imglist;
+ }
+
+ sub ref_to_icon {
+ my $self = shift;
+ my $reftype = shift;
+ return(0) if not $reftype;
+ my $icon_no = $ref_to_icon{$reftype};
+ return defined($icon_no) ? $icon_no : 0;
+ }
+
+ sub _icons_to_objects {
+ return if !values(%icons) or ref((values %icons)[0]);
+
+ require MIME::Base64;
+ my $handler = Wx::PNGHandler->new();
+ Wx::Image::AddHandler($handler);
+ foreach my $icon_name (keys %icons) {
+ my $str = MIME::Base64::decode_base64($icons{$icon_name});
+ open my $fh, '<', \$str or die $!;
+ my $img = Wx::Image->new($fh, Wx::wxBITMAP_TYPE_PNG);
+ close $fh;
+ $icons{$icon_name} = Wx::Bitmap->new($img);
+ }
+ }
+}
+
+1;
+__END__
+
Added: branches/upstream/libwx-perl-datawalker-perl/current/script/dataWalker.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/script/dataWalker.pl?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/script/dataWalker.pl (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/script/dataWalker.pl Sat May 30 09:22:14 2009
@@ -1,0 +1,69 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Wx;
+use Wx::Perl::DataWalker;
+use YAML::XS;
+use Getopt::Long qw(GetOptions);
+
+sub usage {
+ my $msg = shift;
+ warn("$msg\n\n") if defined $msg;
+
+ warn <<HERE;
+Usage: $0 --eval '{foo => "bar", baz => []}'
+ $0 --yaml YAMLFILE
+HERE
+ exit(1);
+}
+
+my $eval;
+my $yamlfile;
+GetOptions(
+ 'h|help' => \&usage,
+ 'e|eval=s' => \$eval,
+ 'y|yaml=s' => \$yamlfile,
+);
+
+if (1!=grep {defined $_} ($eval, $yamlfile)) {
+ usage("You need to supply exactly one of the --eval or --yaml options");
+}
+
+my $data;
+if (defined $eval) {
+ $data = eval "$eval";
+ if ($@) {
+ usage("Could not eval your expression: $@");
+ }
+}
+elsif (defined $yamlfile) {
+ usage("Could not find YAML input file '$yamlfile'") unless -f $yamlfile;
+ $data = YAML::XS::LoadFile($yamlfile)
+}
+else {
+ die "Should not happen";
+}
+
+package MyApp;
+our @ISA = qw(Wx::App);
+
+sub OnInit {
+ my $self = shift;
+
+ my $frame = Wx::Perl::DataWalker->new(
+ {data => $data},
+ undef, -1,
+ "dataWalker",
+ );
+ $self->SetTopWindow($frame);
+ $frame->Show(1);
+ $frame->SetSize(500,500);
+
+ return 1;
+}
+
+
+package main;
+my $app = MyApp->new();
+$app->MainLoop();
+
Added: branches/upstream/libwx-perl-datawalker-perl/current/t/Wx-Perl-DataWalker.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwx-perl-datawalker-perl/current/t/Wx-Perl-DataWalker.t?rev=36791&op=file
==============================================================================
--- branches/upstream/libwx-perl-datawalker-perl/current/t/Wx-Perl-DataWalker.t (added)
+++ branches/upstream/libwx-perl-datawalker-perl/current/t/Wx-Perl-DataWalker.t Sat May 30 09:22:14 2009
@@ -1,0 +1,6 @@
+use strict;
+use warnings;
+use Test::More tests => 1;
+BEGIN { use_ok('Wx::Perl::DataWalker') };
+
+
More information about the Pkg-perl-cvs-commits
mailing list