File Coverage

blib/lib/XHTML/Instrumented/Entry.pm

Criterion	Covered	Total	%
statement	15	143	10.4
branch	0	64	0.0
condition	0	6	0.0
subroutine	5	24	20.8
pod	19	19	100.0
total	39	256	15.2

use strict;
use warnings;

package
    XHTML::Instrumented::Entry;

use XHTML::Instrumented::Control;
use Params::Validate qw(validate HASHREF);

our @unused;

sub new
{
    my $class = shift;

    my %p =  Params::Validate::validate( @_, {
            args => HASHREF,
            flags => HASHREF,
            tag => 1,
            id => 0,
	    name => 0,
	    data => 0,
	    for => 0,
#	    ids => HASHREF,
	}
    );

    bless({ data => [], %p }, $class);
}

sub copy()
{
    my $self = shift;
    my %p =  Params::Validate::validate( @_, {
            args => 0,
            control => { optional => 1, isa => 'XHTML::Instrumented::Control' },
	    data => 0,
	    extra => 0,
            flags => 0,
            form => 0,
	    id => 0,
            special => 0,
            tag => 0,
	}
    );

    bless({
        date => [],
	%{$self},
	args => {%{$self->{args}}},
	%p
    }, ref($self));
}

sub split_char
{
    '\.';
}

sub child
{
    my $self = shift;
    my %p = Params::Validate::validate(@_,
	{
	    args => 1,
            tag => 1,
	    form => 0,
        }
    );

    my $args = $p{args};
    my $id;
    my $for;
    my @flags;
    if (my $id_full = $args->{id}) {
	($id, @flags) = split($self->split_char, $id_full);
    }
    if (my $id_full = $args->{for}) {
	my @fflags;
	($for, @fflags) = split($self->split_char, $id_full);
    }

    my $ret = ref($self)->new(
        %p,
	flags => { map({ my ($x, @x) = split(':', $_); $x => [@x]} @flags) },
	id => $id,
        name => $args->{name},
	('for' => $for) x!! $for,
    );

    return $ret;
}

sub prepend
{
    my $self = shift;

    for my $child (@_) {
	unshift(@{$self->{data}}, $child);
    }
}

sub id
{
    my $self = shift;
    $self->{id};
}

sub name
{
    my $self = shift;
    $self->{name};
}

# elements that have no id or name can be converted to text here
# or that can happen latter.

sub append
{
    my $self = shift;

    for my $child (@_) {
	push(@{$self->{data}}, $child);
    }

    return;
}

# accesor methods

sub context
{
    my $self = shift;

    die caller;

    $self->{contextu};
}

sub tag
{
    my $self = shift;

    $self->{tag};
}

sub args
{
    my $self = shift;

    %{$self->{args}};
}

sub flags
{
    my $self = shift;

    $self->{flags};
}

# methods

sub are_if
{
    my $self = shift;

    exists $self->{flags}{eq} || exists $self->{flags}{if};
}

sub if
{
    my $self = shift;
    my $ret = 1;

    if (exists $self->{flags}{eq}) {
        $ret = $self->control->eq(@{$self->{flags}{eq}});
    }
    if (exists $self->{flags}{if}) {
	$ret = $self->control->if;
    }

    return $ret;
}

sub control
{
    my $self = shift;

    $self->{control} or die;
}

sub children
{
    my $self = shift;
    my @ret;
    my %p =  Params::Validate::validate( @_, {
            context => { isa => 'XHTML::Instrumented::Context' },
	}
    );

    return @{$self->{data}};
}

# we enter here with the complete parsed datastructure.

sub is_form
{
    my $self = shift;

    $self->{tag} eq 'form';
}

sub is_label
{
    my $self = shift;
    $self->{tag} eq 'label';
}

sub expand
{
    my $self = shift;

    my %p =  Params::Validate::validate( @_, {
            context => { isa => 'XHTML::Instrumented::Context' },
	}
    );
    my $context = $p{context};

    my @ret;
    my $control;

    if ($self->{args}{class}) {

    }

    my $id;

    if ($self->name || $self->id) {
        if ($self->is_form) {
	    if (my $name = $self->name) {
		$control = $context->get_form($name);
		$id = $name;
		if ($control) {
		    $control->{id} = $id;
		    $control->{_ids_} = $self->{_ids_};
		    $control->{_names_} = $self->{_names_};
		}
	    }
	    $context = $context->copy(form => $control);
	    if ($control) {
		die unless $control->is_form;
	    }
	} else {
	    if (my $id = $self->id) {
		$control = $context->get_id($id);
		if ($control->has_name) {
		    $self->{name} = $control->name;
		}
		if (ref $control eq 'XHTML::Instrumented::Control::Dummy') {
		    $control = $context->get_name($id, $control);
		}
	    }
	    if (my $name = $self->name) {
		$control = $context->get_name($name, $control);
	    }
        }
	$control ||= $context->get_id('__dummy__');
    } else {
	$control = $context->get_id('__dummy__');
    }

    $control->set_tag(
	tag => $self->{tag},
	args => $self->{args},
    );
    die unless $control;

    die "no control ($id)" . $control unless UNIVERSAL::isa($control, 'XHTML::Instrumented::Control');

    $self->{control} = $control;

    my $if = $self->if;
    if ($self->{args}{class}) {
	if (grep({ $_ eq ':even'} split('\s', $self->{args}{class}))) {
	    if ($context->{loop}->count % 2 == 0) {
		$if = 0;
	    }
	}
	if (grep({ $_ eq ':odd'} split('\s', $self->{args}{class}))) {
	    if ($context->{loop}->count % 2 == 1) {
		$if = 0;
	    }
	}
    }

    if ($self->are_if) {
	$self->{control} = $control = XHTML::Instrumented::Control::Dummy->new(id_count => $control->{id_count});
    }

    if ($if) {
	if ($self->is_label) {
	    if (my $for = $self->{for}) {
		my $control = $context->get_id($for);
		if ($control->required) {
		    $self->{args}{style} .= "color: red;";
		}
	    }
	}

	my @asdf = $control->to_text(
	    tag => $self->{tag},
	    children => [ $self->children(context => $context->copy(form => $control->form)) ],
	    args => { $self->args },
	    flags => $self->flags,
	    context => $context,
	    (special => $self->{flags}{sp}) x!! defined $self->{flags}{sp},
	);

	for (@asdf) {
	    use Data::Dumper;
	    warn Dumper $control, \@asdf unless defined $_;
	}

	push(@ret, @asdf);
    } else {
	my $tag = $self->{tag};
        push(@ret, "");   # Fixme need verbose flag
    }

    if ($self->{args}{class}) {
	if (grep({ $_ eq ':data'} split('\s', $self->{args}{class}))) {
	    $context->inc_loop;
	}
    }

    join('', @ret);
}

1;
__END__