view release on metacpan or  search on metacpan

GTK.pm  view on Meta::CPAN

package Data::TreeDumper::Renderer::GTK ;

use 5.006;
use strict;
use warnings;

require Exporter;
use AutoLoader qw(AUTOLOAD);

our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw();

our $VERSION = '0.03';

use Data::TreeDumper ;

use Gtk3 -init;
use Glib ':constants';

use base qw(Gtk3::TreeView Exporter);

sub new 
{
my $class = shift;
my %args = (data => undef, @_);

my $self = bless Gtk3::TreeView->new, $class;

$self->insert_column_with_attributes(0, 'Data', Gtk3::CellRendererText->new, text => 0);
$self->set_data ($args{data}, $args{dumper_setup}) if exists $args{data} ;
$self->set_title ($args{title});

$self->signal_connect
	(
	button_press_event => 
		sub 
		{
		my ($widget, $event) = @_;
		if ($event->button == 3) {
			_do_context_menu ($widget, $event);
			return TRUE;
		}
		
		return FALSE;
		}
	);


return $self;
}

sub _do_context_menu 
{
	my ($self, $event) = @_;
	my $menu = Gtk3::Menu->new;
	foreach my $method ('expand_all', 'collapse_all') {
		my $label = join ' ', map { ucfirst $_ } split /_/, $method;
		my $item = Gtk3::MenuItem->new ($label);
		$menu->append ($item);
		$item->show;
		$item->signal_connect (activate => sub {
				       $self->$method;
				       });
	}
	$menu->popup (undef, undef, undef, undef, $event->button, $event->time);
}

sub set_data 
{
my ($self, $data, $dumper_setup) = @_;

my $model = Gtk3::TreeStore->new ('Glib::String');

DumpTree
	(
	  $data
	, 'GTK-perl data dump'
	, %$dumper_setup
	, RENDERER => 
		{
		  NODE  => \&RenderNode
		 
		# data needed by the renderer
		, PREVIOUS_LEVEL => 0
		, MODEL => $model
		, PARENT => [Gtk3::TreePath->new()]
		}
	) ;

$self->set_model ($model);
}

sub set_title 
{
	my ($self, $title) = @_;
	
	if (defined $title and length $title) {
		$self->get_column (0)->set_title ($title);
		$self->set_headers_visible (TRUE);
	} else {
		$self->set_headers_visible (FALSE);
	}
}


#-------------------------------------------------------------------------------------------

sub RenderNode
{
my
	(
	  $element
	, $level
	, $is_terminal
	, $previous_level_separator
	, $separator
	, $element_name
	, $element_value