File Coverage

blib/lib/Tickit/Builder.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Tickit::Builder;
# ABSTRACT: Define Tickit widget structures
use strict;
use warnings FATAL => 'all';
use Tickit;
use Data::Dump qw();
use Module::Load qw();

our $VERSION = '0.001';

=head1 NAME

Tickit::Builder - widget layout definition from Perl structure or file

=head1 VERSION

version 0.001

=head1 SYNOPSIS

 use Tickit::Async;
 use Tickit::Builder;
 my $layout = Tickit::Builder->new;
 $layout->run({
	widget => {
		type => 'VBox',
		children => [
			{ widget => { type => "Menu", bg => 'blue', children => [
				{ widget => { type => "Menu::Item", text => "File" } },
				{ widget => { type => "Menu::Item", text => "Edit" } },
				{ widget => { type => "Menu::Spacer", text => " " }, expand => 1 },
				{ widget => { type => "Menu::Item", text => "Help" } },
			] }},
			{ widget => { type => "HBox", text => "Static entry", children => [
				{ widget => { type => "VBox", children => [
					{ widget => { type => "Static", text => "Left panel" } },
				] }, expand => 0.15 },
				{ widget => { type => "VBox", children => [
					{ widget => { type => "Frame", style => 'single', children => [
						{ widget => { type => "Static", text => "Centre bit", fg => 'yellow' }, expand => 1 },
					] }, expand => 1 },
					{ widget => { type => "VBox", children => [
						{ widget => { type => "Static", text => "lower panel" } },
					] } },
				] }, expand => 0.85 },
			] }, expand => 1 },
			{ widget => { type => "Static", text => "Status bar", bg => 0x04, fg => 'white', } },
		],
	}
 });

=head1 DESCRIPTION

Very basic helper class for reading a widget layout definition and instantiating the required
objects. Intended to be used with the web-based or Tickit-based layout editor.

=head1 METHODS

=cut

=head2 new

Instantiate a new L object. Takes no parameters.

=cut

sub new {
	bless {}, shift;
}

=head2 report

Debug output.

=cut

sub report {
	my $self = shift;
	my $msg = shift;
	my @args = @_;
	foreach my $item (@args) {
		while(my $ref = ref $item) {
			if($ref eq 'CODE') {
				$item = $_->();
			} elsif(grep $ref eq $_, qw(ARRAY HASH)) {
				$item = Data::Dump::dump($item);
			} else {
				$item = "$item";
			}
		}
	}
	if(@args) {
		my $txt = join ' ', scalar(localtime), sprintf $msg, @args;
		print "$txt\n";
	} else {
		printf("%s %s\n", scalar(localtime), $msg);
	}
}

=head2 parse_widget

Parse a widget definition from a hashref.

=cut

sub parse_widget {
	my $self = shift;
	my $spec = shift;
	$self->report("Parsing widget %s", $spec);

	my %args = %$spec;
	my $class = 'Tickit::Widget::' . delete $args{type};
	my $children = delete $args{children} || [];
	my $kb = delete $args{keybindings} || {};
	my $id = delete $args{id};
	my $classname = delete $args{class};
	Module::Load::load($class);
	die "$class not found" unless $class->can('new');

	# Build up the widget in this object
	my $w;

	# Manual overrides... expect to end up with a lot of these over time :(
	if($class eq 'Tickit::Widget::Scroller::Item::Text') {
		$w = $class->new($args{text});
	} else {
		$w = $class->new(%args);
	}

	# Any nested children entries will be recursed into
	foreach my $child_def (@$children) {
		my %child_spec = %$child_def;
		$self->report("Found child def %s", $child_def);
		my $child = $self->parse_widget(delete $child_spec{widget});
		if($class eq 'Tickit::Widget::Scroller') {
			$w->push($child);
		} else {
			$w->add($child, %child_spec);
		}
	}

	# We'll also support some basic key binding
	foreach my $k (keys %$kb) {
		my $v = $kb->{$k};
		if($w->can('bind_keys')) {
			$self->report('%s is fine for binding', $class);
			$w->bind_keys($k, $v);
		} else {
			$self->report('%s cannot bind', $class);
		}
		$self->report($k . " bind for " . $v);
		my @ks = split ' ', $k;
		# this looks incomplete, perhaps we should be doing something else here?
	}

	if(defined $id) {
		die "ID [$id] was defined already\n" if exists $self->{by_id}{$id};
		Scalar::Util::weaken($self->{by_id}{$id} = $w);
	}
	if(defined $classname) {
		push @{ $self->{by_class}{$classname} }, $w;
		Scalar::Util::weaken($self->{by_class}{$classname}[-1]);
	}
	return $w;
}

=head2 by_id

Returns the widget with the given ID.

=cut

sub by_id { $_[0]->{by_id}{$_[1]} }

=head2 by_class

Returns a list of all widgets matching the given classname.

=cut

sub by_class { @{ $_[0]->{by_class}{$_[1]} } }

=head2 parse

Parse the top-level layout spec (hashref).

=cut

sub parse {
	my $self = shift;
	my $spec = shift;
	$self->report("Parsing %s", $spec);
	my $w;
	if(my $widget_def = $spec->{widget}) {
		$w = $self->parse_widget($widget_def);
	}
	die "no widget" unless $w;
	$w;
}

=head2 apply_layout

Apply the given layout to the L instance.

Takes two parameters:

=over 4

=item * $tickit - a L instance.

=item * $layout - a hashref representing the requested layout.

=back

=cut

sub apply_layout {
	my $self = shift;
	my $tickit = shift;
	my $layout = shift;
	my $root = $self->parse($layout);
	$tickit->set_root_widget($root);
}

=head2 run

Helper method to parse and run the layout definition using L.

=cut

sub run {
	my $self = shift;
	my $spec = shift;
	my $root = $self->parse($spec);

	require Tickit::Async;
	require IO::Async::Loop;
	my $tickit = Tickit::Async->new;
	$tickit->set_root_widget($root);
	my $loop = IO::Async::Loop->new;
	$loop->add($tickit);
	$tickit->run;
}

=head2 parse_file

Parse definition from a file.

=cut

sub parse_file {
	my $self = shift;
	my ($file, $type) = @_;
	$type = 'json' unless $type;
	open my $fh, '<:encoding(utf-8)', $file or die "opening $file - $!";
	my $txt = do { local $/; <$fh> };
	if($type eq 'json') {
		require JSON;
		return JSON->new->decode($txt);
	} else {
		die 'unsupported';
	}
}

1;

__END__