view release on metacpan or  search on metacpan

lib/Acme/Gtk2/Ex/Builder.pm  view on Meta::CPAN

use 5.010;
use strict;
use warnings;
package Acme::Gtk2::Ex::Builder;
BEGIN {
  $Acme::Gtk2::Ex::Builder::VERSION = '0.008';
}
# ABSTRACT: Funny Gtk2 Interface Design Module

use base qw( Exporter );

our @EXPORT  = qw(
    build
    contain
    info
    on
    prop
    set
    widget
);

sub find {
    my $self   = shift;
    my $id     = shift;
    my $widget = shift;
 
    if ($widget) {
        $self->{_widget}{$id} = $widget;
    }
 
    return $self->{_widget}{$id};
}
 
sub _current {
    my $self = shift;
    my $up   = shift || 0;
    $self->{_current}[-1 - $up];
}
 
sub _current_push {
    my $self   = shift;
    my $widget = shift;
    push @{ $self->{_current} }, $widget;
}
 
sub _current_pop {
    my $self = shift;
    pop @{ $self->{_current} };
}
 
sub contain (&) { @_ }
 
sub build (&) {
    my $code = shift;
 
    my $self = bless {
        _info    => {},
        _widget  => {},
        _current => [],
    }, __PACKAGE__;
 
    no strict 'subs';
    no warnings 'redefine';
 
    local *_widget = sub ($&) {
        my $class  = shift;
        my $_code  = shift;
        my @params = @_;
 
        my $widget;
        if (ref($class) && $class->isa("Gtk2::Widget")) {
            $widget = $class;
        }
        else {
            $widget = "Gtk2::$class"->new(@params);
        }
 
        if ($self->_current && ref($self->_current) ne __PACKAGE__) {
            given (ref $self->_current) {
                when (/Gtk2::VBox|Gtk2::HBox/) {
                    $self->_current->pack_start($widget, 0, 0, 1);
                }
                default {
                    $self->_current->add($widget);
                }
            };
        }
 
        $self->_current_push( $widget );
 
        local *_info = sub {
            my $key    = shift;
            my @values = @_;
 
            given ($key) {
                when ('id') {
                    $self->find($values[0], $self->_current);
                }
                when ('packing') {
                    given (ref $self->_current(1)) {
                        when (/Gtk2::VBox|Gtk2::HBox/) {
                            $self->_current(1)->set_child_packing($self->_current, @values);
                        }
                    }
                }
                default {
                }
            }
            $self->{_info}{$self->_current}{$key} = \@values;
        };
 
        local *_on = sub {
            my $signal = shift;
            my $_code  = shift;
            my $data   = shift;