File Coverage

blib/lib/URI/Find/Rule.pm

Criterion	Covered	Total	%
statement	152	154	98.7
branch	27	36	75.0
condition	15	19	78.9
subroutine	27	27	100.0
pod	4	14	28.5
total	225	250	90.0

package URI::Find::Rule;

use strict;
use vars qw/$VERSION $AUTOLOAD/;
use URI::Find;
use URI;
use Text::Glob 'glob_to_regex';

use Data::Dumper;

$VERSION = '0.8';

sub _force_object {
    my $object = shift;
    $object = $object->new()
      unless ref $object;
    $object;
}

sub _flatten {
    my @flat;
    while (@_) {
        my $item = shift;
        ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item;
    }
    return @flat;
}

sub in {
    my $self = _force_object shift;
    my ($anonsub, $return_objects) = @_;

	my @urls;
	my $sub = sub {
		my ($original, $uri) = @_;
        my $uri_object = URI->new($uri);
        my $keep = 1;
        my $negate_next = 0;
        foreach my $i (@{ $self->{rules} }) {
            if ($i->{rule} eq 'not') {
                $negate_next = 1;
            } else {
                my $result = &{$i->{code}}($original, $uri, $uri_object);
                $keep = $keep & ($negate_next ^ $result);
                $negate_next = 0;
            }
        }
        if ($keep) {
            if ($return_objects) {
                push @urls, $uri_object;
            } else {
                push @urls, [$original, $uri];
            }
        }
		return $original;
	};
	my $finder = URI::Find->new($sub);
	$finder->find(\$anonsub);
	return @urls;
}

sub new {
    my $referent = shift;
    my $class = ref $referent || $referent;
    my $self = bless {
        rules => []
    }, $class;
    return $self;
}

sub not {
    my $self = _force_object shift;
    push @{ $self->{rules} }, { rule => 'not' };
    return $self;
}

*protocol=\&scheme;

sub AUTOLOAD
{
    (my $method = $AUTOLOAD) =~ s/^.*:://;
	return if $method eq 'DESTROY';

    # It would be nice to do this differently but I can't see any
    # easy way of working around the lack of object at this point.
    # Maybe it's best to rip this out entirely.
    if (URI->new('http://x:y@a/b#c?d')->can($method)) {
        my $code = <<'DEFINE_AUTO';
sub _FUNC_ {
    my $self = _force_object shift;
    my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ }  _flatten( @_ );
    my $regex = join( '|', @names );

    push @{ $self->{rules} }, {
        rule => '_FUNC_',
        code => sub { ( $_[2]->_FUNC_() || '' )=~ /$regex/ },
        args => \@_,
    };

    return $self;
}
DEFINE_AUTO
        $code =~ s/_FUNC_/$method/g;
        my $sub = eval $code;
        {
            no strict 'refs';
            return &$AUTOLOAD(@_);
        }
    } else {
        my $code = <<'DEFINE_SCHEME';
sub _FUNC_ {
    my $self = _force_object shift;
    if (@_) {
        $self->scheme('_FUNC_')->host(@_);
    } else {
        $self->scheme('_FUNC_');
    }
}
DEFINE_SCHEME
        $code =~ s/_FUNC_/$method/g;
        eval $code;
        {
            no strict 'refs';
            return &$AUTOLOAD(@_);
        }
    }
}

1;

__END__