package WWW::Extractor::XML::Predicates;

use strict;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS %cache);

use Exporter;
use WWW::Extractor::Generic::Predicates qw(:all :cache);

@ISA = qw|Exporter|;

%EXPORT_TAGS = ( all   => [qw(XMLWrap XMLNormal Content AnyAttr Attr Name Value Href Tag In Start End Under), @{$WWW::Extractor::Generic::Predicates::EXPORT_TAGS{all}} ],
		 cache => [@{$WWW::Extractor::Generic::Predicates::{cache}}] );


Exporter::export_ok_tags('all', 'cache');

sub XMLWrap {
    my $test = shift;
    return Wrap($test, \&XMLNormal);
}

sub XMLNormal {
    my $test = PartWrap(shift);
    return Or(Content($test), AnyAttr($test));
}

sub Content {
    my $test = PartWrap(shift);
    return $cache{Content}{$test} ||=
	sub {
	    my $e = shift;
	    return ref $e && $e->type eq 'T' && &$test($e->text);
	};
}

sub AnyAttr {
    my $test = PartWrap(shift);
    return $cache{AnyAttr}{$test} ||=
        sub {
	    my $e = shift;
	    if (ref $e && ($e->type eq 'S' || $e->type eq 'L')) {
		my $attr_hash_ref = $e->{attr};
		for my $attr_key (@{$e->attr_seq}) { # for each attribute key
		    return 1 if &$test($attr_hash_ref->{$attr_key});
		}
	    }
	    return;
	}
}

sub Attr {
    my ($attr_key, $test) = @_;
    $attr_key = lc $attr_key;
    $test = PartWrap($test);
    return $cache{Attr}{$attr_key}{$test} ||=
	sub {
	    my $e = shift;
	    if (ref $e && ($e->type eq 'S' || $e->type eq 'L')) {
		my $attr_hash_ref = $e->attr;
		return exists $attr_hash_ref->{$attr_key} &&
		    &$test($attr_hash_ref->{$attr_key});
	    }
	    return;
	}
}

sub Name {
    my $test = shift;
    return Attr('name', $test);
}

sub Value {
    my $test = shift;
    return Attr('value', $test);
}

sub Href {
    my $test = shift;
    return Attr('href', $test);
}

sub Tag {
    my $test = shift;
    $test = defined $test ? EqWrap($test) : PartWrap($test);
    return $cache{Tag}{$test} ||=
	sub {
	    my $e = shift;
	    return ref $e && ($e->type eq 'S' || $e->type eq 'L')
		&& &$test($e->tag);
	}
}

# In tests if we are inside a certain (type of) container, which must be correctly formed
# The optional second parameter tests the current tag also
sub In {
    my ($tag_test, $content_test) = @_;
    $tag_test = Wrap($tag_test, \&Tag);
    $content_test = XMLWrap($content_test) if defined $content_test;

    # the following line caused warnings when $content_test == undef
    return $cache{In}{$tag_test}{$content_test || 'UNDEF_CODE'} ||=
	sub {
	    my ($e, $stack) = @_;
	    if (! defined $content_test || &$content_test($e)) {
		for (@$stack) {
		    return 1 if (&$tag_test($_));
		}
	    }
	    return;
	}
}

# Under tests if we are inside a certain (type of) container, but not inside any other containers
sub Under {
    my $tag_test = Wrap(shift, \&Tag);
    return $cache{Under}{$tag_test} ||=
	sub {
	    my ($e, $stack) = @_;
	    return &$tag_test($stack->[-1]);
	}
}

sub Start {
    my $tag = shift;
    return $cache{Start}{$tag} ||=
	And(Tag($tag), sub {
	    my $e = shift;
	    return $e->type eq 'S' and $e->has_end;
	});
}

sub End {
    my $test = Wrap(shift, \&Eq);
    return $cache{End}{$test} ||=
	sub {
	    my $e = shift;
	    return ref $e && $e->type eq 'E' && $e->has_start && &$test($e->tag);
	}
}

1