package Test::HTML::Form;
use strict;

=head1 NAME

Test::HTML::Form - HTML Testing and Value Extracting

=head1 VERSION

0.01

=head1 SYNOPSIS

use Test::HTML::Form;

my $filename = 't/form_with_errors.html';

# test functions

title_ok($filename,'Foo Bar','title matches');

no_title($filename,'test site','no english title');

tag_ok($filename,
       'p',
       { class => 'formError',
	 _content => 'There is an error in this form.' },
       'main error message appears as expected' );

no_tag($filename,
       'p',
       { class => 'formError',
	 _content => 'Error' },
       'no unexpected errors' );


text_ok($filename,'koncerty','found text : koncerty'); # check text found in file

no_text($filename,'Concert','no text matching : Concert'); # check text found in file

image_ok($filename,'/images/error.gif','matching image found image in HTML');

link_ok($filename,'/post/foo.html','Found link in HTML');

form_field_value_ok($filename,'category_id', 12345678, undef, 'category_id matches');

form_select_field_ok($filename,{ field_name => $field_name, selected => $field_value, form_name => $form_name}, $description);

form_checkbox_field_ok($filename,{ field_name => $field_name, selected => $field_value, form_name => $form_name}, $description);

# Data extraction functions

my $form_values = Test::HTML::Form->get_form_values({filename => $filename, form_name => 'form1'});

my $posting_id = Test::HTML::Form->extract_text({filename => 'publish.html', pattern => 'Reference :\s(\d+)'});

=head1 DESCRIPTION

Test HTML pages and forms, and extract values.

Developed for and released with permission of Slando (http://www.slando.com)

=cut

use Data::Dumper;
use HTML::TreeBuilder;

use base qw( Exporter Test::Builder::Module);
our @EXPORT = qw(
  link_ok no_link
  image_ok no_image
  tag_ok no_tag
  text_ok no_text
  title_ok no_title
  form_field_value_ok
  form_select_field_ok
  form_checkbox_field_ok
  );


$Data::Dumper::Maxdepth = 2;
my $Test = Test::Builder->new;
my $CLASS = __PACKAGE__;
my %parsed_files = ();
my %parsed_file_forms = ();

our $VERSION = 0.01;

=head1 FUNCTIONS

=head2 image_ok

image_ok($filename,$image_source,'matching image found image in HTML');

=cut

sub image_ok {
  my ($filename,$link,$name) = (@_);
  local $Test::Builder::Level = 2;
  return tag_ok($filename,'img',{ src => $link },$name);
};


=head2 no_image

no_image($filename,$image_source,'no matching image found in HTML');

=cut

sub no_image {
  my ($filename,$link,$name) = (@_);
  local $Test::Builder::Level = 2;
  return no_tag($filename,'img',{ src => $link },$name);
};


=head2 link_ok

link_ok($filename,$link_destination,'Found link in HTML');

=cut

sub link_ok {
  my ($filename,$link,$name) = (@_);
  local $Test::Builder::Level = 2;
  return tag_ok($filename,'a',{ href => $link },$name);
};

=head2 no_link

link_ok($filename,$link_destination,'Link not in HTML');

=cut

sub no_link {
  my ($filename,$link,$name) = (@_);
  local $Test::Builder::Level = 2;
  return no_tag($filename,'a',{ href => $link },$name);
};

=head2 title_ok

title_ok($filename,'Foo bar home page','title matches');

=cut

sub title_ok {
  my ($filename,$title,$name) = @_;
  local $Test::Builder::Level = 2;
  return tag_ok($filename,"title", { _content => $title } ,$name);
};

=head2 no_title

=cut

sub no_title {
  my ($filename,$title,$name) = (@_);
  local $Test::Builder::Level = 2;
  return no_tag($filename,'title', sub { shift->as_trimmed_text =~ m/$title/ },$name);
};

=head2 tag_ok

tag_ok($filename,'a',{ href => $link },$name); # check matching tag found in file

=cut

sub tag_ok {
  my ($filename,$tag,$attr_ref,$name) = @_;
  my $count = _tag_count($filename, $tag, $attr_ref);
  my $tb = $CLASS->builder;
  my $ok = $tb->ok( $count, $name);
  unless ($ok) {
    $tb->diag("Expected at least one tag of type $tag in file $filename matching condition, but got 0\n");
  }
  return $ok;
}

=head2 no_tag

tag_ok($filename,'a',{ href => $link },$name); # check NOT matching tag found in file

=cut

sub no_tag {
  my ($filename,$tag,$attr_ref,$name) = @_;
  my $count = _tag_count($filename, $tag,  $attr_ref);
  my $tb = $CLASS->builder;
  my $ok = $tb->is_eq( $count, 0, $name);
  unless ($ok) {
    $tb->diag("Expected no tags of type $tag matching criteria in file $filename, but got $count\n");
  }
  return $ok;
};

=head2 text_ok

text_ok($filename,$text,$name); # check text found in file

=cut

sub text_ok {
  my ($filename,$text,$name) = @_;
  my $count = _count_text({filename => $filename, text => $text });
  my $tb = $CLASS->builder;
  my $ok = $tb->ok( $count, $name);
  unless ($ok) {
    $tb->diag("Expected HTML to contain at least one instance of text '$text' in file $filename but not found\n");
  }
  return $ok;
};

=head2 no_text

no_text($filename,$text,$name);  # check text NOT found in file

=cut

sub no_text {
  my ($filename,$text,$name) = @_;
  my $count = _count_text({filename => $filename, text => $text });
  my $tb = $CLASS->builder;
  my $ok = $tb->is_eq( $count, 0 , $name);
  unless ($ok) {
    $tb->diag("Expected HTML to not contain text '$text' in file $filename but $count instances found\n");
  }
  return $ok;
};


=head2 form_field_value_ok

form_field_value_ok($filename,$field_name, $field_value, $form_name, $description);

form_field_value_ok($filename,$field_name, qr/some pattern/, $form_name, $description);

field value argument can be a string (for exact matches) or a quoted regexp (for pattern matches)

=cut

sub form_field_value_ok {
  my ($filename,$field_name, $field_value, $form_name, $description) = @_;
  my $form_fields = __PACKAGE__->get_form_values({ filename => $filename, form_name => $form_name });
  my $tb = $CLASS->builder;

  my $elem = $form_fields->{$field_name};

  my $ok = $tb->ok( _compare($elem,$field_value) , $description);
  unless ($ok) {
    $tb->diag("Expected form to contain field '$field_name' and have value of '$field_value' but not found in file $filename\n");
  }
  return $ok;
};

=head2 form_select_field_ok

form_select_field_ok($filename,{ field_name => $field_name, selected => $field_value, form_name => $form_name}, $description);

selected field value can be string or quoted regexp

=cut

sub form_select_field_ok {
  my ($filename, $field_value_args, $description) = @_;
  my $form_fields = __PACKAGE__->get_form_values({ filename => $filename, form_name => $field_value_args->{form_name} });
  my $tb = $CLASS->builder;

  my $field_value = $field_value_args->{selected};
  my $field_name = $field_value_args->{field_name};
  my $select_elem = $form_fields->{$field_name};
  unless (UNIVERSAL::can($select_elem,'descendants')) {
    die "$select_elem (",$select_elem->tag,") is not a select html element for field : $field_name - did you mean to call form_checkbox_field_ok ?";
  }
  my $selected_option;
  foreach my $option ( $select_elem->descendants ) {
    next unless (ref($option) && ( lc($option->tag) eq 'option') );
    if ( _compare($option, $field_value) ) {
      $selected_option = $option;
      last;
    }
  }

  my $ok = $tb->ok( $selected_option && scalar grep (m/selected/i && $selected_option->attr($_), $selected_option->all_external_attr_names), $description);
  unless ($ok) {
    $tb->diag("Expected form to contain field '$field_name' and have option with value of '$field_value' selected but not found in file $filename \n");
  }
  return $ok;
}

=head2 form_checkbox_field_ok

form_checkbox_field_ok($filename,{ field_name => $field_name, selected => $field_value, form_name => $form_name}, $description);

selected field value can be string or quoted regexp

=cut

sub form_checkbox_field_ok {
  my ($filename, $field_value_args, $description) = @_;
  my $form_fields = __PACKAGE__->get_form_values({ filename => $filename, form_name => $field_value_args->{form_name} });
  my $tb = $CLASS->builder;

  my $field_value = $field_value_args->{selected};
  my $field_name = $field_value_args->{field_name};
  my $selected_box;
  my $checkbox_elems = $form_fields->{$field_name} || [];

  foreach my $checkbox ( @$checkbox_elems ) {
    if ( _compare($checkbox, $field_value) ) {
      $selected_box = $checkbox;
      last;
    }
  }

  my $ok = $tb->ok( $selected_box && scalar grep (m/checked/i && $selected_box->attr($_), $selected_box->all_attr_names), $description);
  unless ($ok) {
    $tb->diag("Expected form to contain field '$field_name' and have option with value of '$field_value' selected but not found in file $filename\n");
  }
  return $ok;
}



=head2 get_form_values

my $form_values = Test::HTML::Form->get_form_values({filename => $filename, form_name => 'form1'});

=cut

sub get_form_values {
  my $class = shift;
  my $args = shift;
  no warnings 'uninitialized';
  my $form_name = $args->{form_name};
  my $internal_form_name = $form_name . ' form';
  if ($parsed_file_forms{$args->{filename}}{$internal_form_name}) {
    return $parsed_file_forms{$args->{filename}}{$internal_form_name};
  } else {
    my $tree = _get_tree($args->{filename});
    my $form_fields = { };
    my ($form) = $tree->look_down('_tag', 'form',
				  sub {
				    my $form = shift;
				    if ($form_name) {
				      return 1 if $form->attr('name') eq $form_name;
				    } else {
				      return 1;
				    }
				  }
				 );
    if (ref $form) {
      my @form_nodes = $form->descendants();
      foreach my $node (@form_nodes) {
	next unless (ref($node));
	if (lc($node->tag) =~ /^(input|select|textarea|button)$/i)  {
	  if (lc $node->attr('type')  =~ /(radio|checkbox)/)  {
	    push (@{$form_fields->{$node->attr('name')}},$node);
	  } else {
	    $form_fields->{$node->attr('name')} = $node;
	  }
	}
      }
    }
    $parsed_file_forms{$args->{filename}}{$internal_form_name} = $form_fields;

    return $form_fields;
  }
}

=head2 extract_text

my $posting_id = Test::HTML::Form->extract_text({filename => 'publish.html', pattern => 'Reference :\s(\d+)'});

=cut

sub extract_text {
  my $class = shift;
  my $args = shift;
  my $tree = _get_tree($args->{filename});
  my $pattern = $args->{pattern};
  my ($node) = $tree->look_down( sub {
				  my $thisnode = shift;
				  $thisnode->normalize_content;
				  return 1 if ($thisnode->as_trimmed_text =~ m/$pattern/i);
				});
  my ($match) = ($node->as_trimmed_text =~ m/$pattern/i);

  return $match;
}



#
##########################################
# Private / Internal methods and functions

sub _compare {
  my ($elem, $field_value) = @_;
  unless ($elem && (ref$elem eq 'HTML::Element') ) {
      warn "_compare passed $elem and value $field_value, $elem should be HTML::Element but is : ", ref $elem, "\n";
      return 0 ;
  }

  my $have_regexp = ( ref($field_value) eq 'Regexp' ) ? 1 : 0;
  my $value = $elem->attr('value') ;
  unless (defined $value) {
    $value = $elem->as_trimmed_text;
  }
  my $ok;
  if ($have_regexp) {
      $ok = ( $elem && $value =~ m/$field_value/ ) ? 1 : 0 ;
  } else {
      $ok = ( $elem && $value eq $field_value ) ? 1 : 0 ;
  }
  return $ok
}

sub _tag_count {
  my ($filename, $tag, $attr_ref) = @_;
  my $tree = _get_tree($filename);
  my @parse_args = ();
  if ( ref $attr_ref eq 'HASH' ) {
    my $pattern;
    if (ref($attr_ref->{_content}) eq 'Regexp')  {
      $pattern = $attr_ref->{_content};
      delete $attr_ref->{_content};
    }

    @parse_args = %$attr_ref ;
    if ($pattern) {
      push( @parse_args, sub { return 0 unless (ref $_[0] eq 'HTML::Element' ); return $_[0]->as_trimmed_text =~ m/$pattern/; } );
    }
  } else {
    @parse_args = $attr_ref ;
  }
  my $count = $tree->look_down( _tag => $tag, @parse_args );

  return $count || 0;
}

sub _count_text {
  my $args = shift;
  my $tree = _get_tree($args->{filename});
  my $text = $args->{text};
  my $count = $tree->look_down( sub {
				  my $node = shift;
				  $node->normalize_content;
				  return 1 if ($node->as_trimmed_text =~ m/$text/);
				});
  return $count || 0;
}

sub _get_tree {
  my $filename = shift;
  unless ($parsed_files{$filename}) {
    die "can't find file $filename" unless (-f $filename);
    my $tree = HTML::TreeBuilder->new;
    $tree->parse_file($filename);
    $parsed_files{$filename} = $tree;
  }
  return $parsed_files{$filename};
}

=head1 SEE ALSO

=over 4

=item Test::HTML::Content
=item HTML::TreeBuilder

=back

=head1 AUTHOR

Aaron Trevena

=head1 BUGS

Please report any bugs or feature requests to http://rt.cpan.org

=head1 COPYRIGHT & LICENSE

Copyright 2008 Slando.
Copyright 2009 Aaron Trevena.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut


1;
