File Coverage

blib/lib/File/Find/Match.pm

Criterion	Covered	Total	%
statement	78	87	89.6
branch	34	38	89.4
condition	4	4	100.0
subroutine	14	16	87.5
pod	2	3	66.6
total	132	148	89.1

package File::Find::Match;
use 5.008;
use strict;
use warnings;
use base 'Exporter';
use File::Basename ();
use Carp;

use constant {
	RULE_PREDICATE   => 0,
	RULE_ACTION      => 1,

    # Author's birth year: 1985. :)
	IGNORE => \19,
	MATCH  => \85,
};


our $VERSION    = '1.0';
our @EXPORT     = qw( IGNORE MATCH );
our @EXPORT_OK  = @EXPORT;
our %EXPORT_TAGS = (
	constants => [ @EXPORT ],
	all       => [ @EXPORT ],
);

sub new {
	my ($this) = shift;
	my $self = bless {}, $this;

	$self->_rules(@_);

	return $self;
}

sub _rules {
	my $self = shift;

	while (@_) {
		my ($predicate, $action) = (shift, shift);
        croak "Undefined action!" unless defined  $action;
		my $act  = $self->_make_action($action);
        if ($predicate eq 'default') {
            $self->{default} = $action;
            next;
        }
		my $pred = $self->_make_predicate($predicate);

		push @{ $self->{rules} }, [$pred, $action];
	}

	return $self;
}

sub rule {
	my $self = shift;
	warn "rules() and rule() are deprecated! Please pass rules to new() from now on.\n";
	$self->_rules(@_);
}
*rules = \&rule;


sub find {
	my ($self, @files) = @_;
	my @rules   = @{ $self->{rules} };

	if (exists $self->{default}) {
		push @rules, [ sub { 1 }, $self->{default} ];
	}

	unless (@files) {
		@files = ('.');
	}

	FILE: while (@files) {
		my $path = shift @files;

		RULE: foreach my $rule (@rules) {
			if ($rule->[RULE_PREDICATE]->($path)) {
				my $v = $rule->[RULE_ACTION]->($path) || 0;
				if (ref $v) {
					next FILE if $v == IGNORE;
					last RULE if $v == MATCH;
				}
			}
		}

		if (-d $path) {
			my $dir;
			opendir $dir, $path;

			# read all files from $dir
			# skip . and ..
			# prepend $path/ to the file name.
			# append to @files.
			push @files, map { "$path/$_" } grep(!/^\.\.?$/, readdir $dir);

			closedir $dir;
		}
	}
}

# Take a predicate and return a coderef.
sub _make_predicate {
	my ($self, $pred) = @_;
	my $ref =  ref($pred) || '';

	croak "Undefined predicate!" unless defined $pred;

	# If it is a qr// Regexp object,
	# the predicate is the truth of the regex.
    if ($ref eq 'Regexp') {
		return sub { $_[0] =~ $pred };
	}
	# If it's a sub, just return it.
	elsif ($ref eq 'CODE') {
		return $pred;
	}
    elsif (not $ref) {
    	if ($pred eq 'dir') {
    		warn "the predicate 'dir' is deprecated.\n";
    		$pred = '-d';
    	} elsif ($pred eq 'file') {
    		warn "the predicate 'file' is deprecated.\n";
    		$pred = '-f';
    	}
        my $code = eval "sub { package main; \$_ = shift; $pred }";
        if ($@) {
            die $@;
        }
        return $code;
    }
    # All other values are illegal.
	else {
		croak "Predicate must be a string, code reference, or regexp reference.";
	}
}

# Take an action and return a coderef.
sub _make_action {
	my ($self, $act) = @_;

	if (UNIVERSAL::isa($act, 'UNIVERSAL')) {
		# it's an object. Does it support action?
		if ($act->can('action')) {
			return sub { $act->action(shift) };
		} else {
			croak "Action object must support action() method!"
		}
	} elsif (ref($act) eq 'CODE') {
		return $act;
	} else {
		croak "Action must be a coderef or an object.";
	}
}

1;
__END__