=head1 NAME

HTML::Tested - Provides HTML widgets with the built-in means of testing.

=head1 SYNOPSIS

	package MyPage;
  	use base 'HTML::Tested';

	__PACKAGE__->make_tested_value('x');

	# Register my own widget
	__PACKAGE__->register_tested_widget('my_widget', 'My::App::Widget');
	__PACKAGE__->make_tested_my_widget('w');


	# Later, in the test for example
	package main;

	my $p = MyPage->construct_somehow;
	$p->x('Hi');
	my $stash = {};

	$p->ht_render($stash);

	# stash contains x => 'Hi'
	# We can pass it to templating mechanism

	# Stash checking function
	my @errors = HTML::Tested::Test->check_stash(
			'MyPage', $stash, { x => 'Hi' });

	# Stash checking function
	my @errors = HTML::Tested::Test->check_text(
			'MyPage', '<html>x</html>', { x => 'Hi' });

=head1 DISCLAIMER
	
This is pre-alpha quality software. Please use it on your own risk.

=head1 INTRODUCTION

Imagine common web programming scenario - you have HTML page packed with
checkboxes, edit boxes, labels etc.

You are probably using some kind of templating mechanism for this page already.
However, your generating routine still has quite a lot of complex code.

Now, being an experienced XP programmer, you face the task of writing test
code for the routine. Note, that your test code can deal with the results on
two levels: we can check the stash that we are going to pass to the templating module
or we can crawl our site and check the resulting text.

As you can imagine both of those scenarios require quite a lot of effort to
get right.

HTML::Tested can help here. It does this by generating stash data from the
widgets that you declare. Its testing code can check the existence of those
widgets both in the stash and in the text of the page.

=cut

use strict;
use warnings FATAL => 'all';

package HTML::Tested;
use base 'Class::Accessor', 'Class::Data::Inheritable';
use Carp;
our $VERSION = 0.18;

__PACKAGE__->mk_classdata('Widgets_Map');
__PACKAGE__->mk_classdata('Widgets_List');

=head1 METHODS

=head2 register_tested_widget(widget_name, widget_class, dont_use)

Registers widget to be available for the inheriting classes.
This implicitly creates make_tested_<widget_name> function.
C<widget_class> should provide behind the scenes support for the widget.
C<dont_use> tells HTML::Tested to not use the module at the time of
loading.

=cut

sub _make_tested_widget {
	my ($class, $widget_name, $widget_class, $dont_use
			, $class1, $name, @args) = @_;
	unless ($dont_use) {
		eval "use $widget_class";
		confess "Error using $widget_class: $@" if $@;
	}
	# to avoid inheritance troubles...
	my %wm = %{ $class1->Widgets_Map || {} };
	$class1->Widgets_Map(\%wm);
	$class1->mk_accessors($name);
	my $res = $widget_class->new($class1, $name, @args);
	$class1->Widgets_Map->{$name} = $res;

	my @wl = @{ $class1->Widgets_List || [] };
	push @wl, $res;
	$class1->Widgets_List(\@wl);
	return $res;
}

sub register_tested_widget {
	my ($class, $widget_name, $widget_class, $dont_use) = @_;
	no strict 'refs';
	*{ "$class\::make_tested_$widget_name" } = sub {
		$class->_make_tested_widget($widget_name , $widget_class
				, $dont_use, @_);
	};
}

=head2 ht_render(stash)

Renders all of the contained controls into the stash.
C<stash> should be hash reference.

=cut
sub ht_render {
	my ($self, $stash, $parent_name) = @_;
	while (my ($n, $v) = each %{ $self->Widgets_Map }) {
		my $id = $parent_name ? $parent_name . "__$n" : $n;
		$v->render($self, $stash, $id);
	}
}


=head2 ht_bless_from_tree(class, tree)

Creates blessed instance of the class from tree.

=cut
sub ht_bless_from_tree {
	my ($class, $tree) = @_;
	my $res = {};
	while (my ($n, $v) = each %$tree) {
		my $wc = $class->Widgets_Map->{$n};
		$res->{$n} = $wc ? $wc->bless_from_tree($v) : $v;
	}
	return bless($res, $class);
}

sub ht_absorb_one_value {
	my ($self, $root, $val, @path) = @_;
	my $p = shift(@path) or return;
	my $wc = $self->Widgets_Map->{$p} or return;
	$wc->absorb_one_value($root, $val, @path);
}

=head2 ht_convert_request_to_tree(class, r)

Creates blessed instance of the class from Apache::Request
compatible object.

=cut
sub ht_convert_request_to_tree {
	my ($class, $r) = @_;
	my @pkeys = $r->param;
	my %res;
	for my $p (sort @pkeys) {
		$class->ht_absorb_one_value(\%res, 
				$r->param($p), split('__', $p));
	}
	for my $u ($r->upload) {
		$class->ht_absorb_one_value(\%res, 
				$u->fh, split('__', $u->name));
	}
	return bless(\%res, $class);
}

sub ht_get_widget_option {
	my ($self, $wname, $opname) = @_;
	my $w = $self->Widgets_Map->{$wname}
		or confess "Unknown widget $wname";
	if (ref($self)) {
		my $n = "__ht__$wname\_$opname";
		return $self->{$n} if exists $self->{$n};
	}
	return $w->options->{$opname};
}

sub ht_set_widget_option {
	my ($self, $wname, $opname, $val) = @_;
	my $w = $self->Widgets_Map->{$wname}
		or confess "Unknown widget $wname";
	if (ref($self)) {
		$self->{"__ht__$wname\_$opname"} = $val;
	} else {
		$w->options->{$opname} = $val;
	}
}

__PACKAGE__->register_tested_widget('value', 'HTML::Tested::Value');
__PACKAGE__->register_tested_widget('list', 'HTML::Tested::List');

{
my %vals = qw(marked_value Marked edit_box EditBox textarea TextArea
		password_box PasswordBox dropdown DropDown checkbox CheckBox
		link Link upload Upload form Form submit Submit
		hidden Hidden radio Radio tree Tree);

while (my ($n, $v) = each %vals) {
	__PACKAGE__->register_tested_widget($n, "HTML::Tested::Value::$v");
}
}

1;

=head1 BUGS

Documentation is too sparse to be taken seriously.

=head1 AUTHOR

	Boris Sukholitko
	CPAN ID: BOSU
	
	boriss@gmail.com
	

=head1 COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

HTML::Tested::Test for writing tests using HTML::Tested.
See HTML::Tested::Value::* for the documentation on the specific
widgets.
See HTML::Tested::List for documentation on list container.

=cut

