File Coverage

blib/lib/File/Finder.pm

Criterion	Covered	Total	%
statement	93	94	98.9
branch	55	66	83.3
condition			n/a
subroutine	20	20	100.0
pod	5	5	100.0
total	173	185	93.5

package File::Finder;

use 5.006;
use strict;
use warnings;

use base qw(Exporter);

## no exports

our $VERSION = '1.01';

use Carp qw(croak);

## public methods:

sub new {
  my $class = shift;
  bless {
	 options => {},
	 steps => [],
	}, $class;
}

sub as_wanted {
  my $self = shift;
  return sub { $self->_run };
}

use overload
  '&{}' => 'as_wanted',
  # '""' => sub { overload::StrVal(shift) },
  ;

sub as_options {
  my $self = shift;
  return { %{$self->{options}}, wanted => sub { $self->_run } };
}

sub in {
  my $self = _force_object(shift);

  ## this must return count in a scalar context
  $self->collect(sub { $File::Find::name }, @_);
}

sub collect {
  my $self = _force_object(shift);
  my $code = shift;

  my @result;
  my $self_store = $self->eval( sub { push @result, $code->() } );

  require File::Find;
  File::Find::find($self_store->as_options, @_);

  ## this must return count in a scalar context
  return @result;
}

## private methods

sub _force_object {
  my $self_or_class = shift;
  ref $self_or_class ? $self_or_class : $self_or_class->new;
}

sub _clone {
  my $self = _force_object(shift);
  bless {
	 options => {%{$self->{options}}},
	 steps => [@{$self->{steps}}],
	}, ref $self;
}

## we set this to ensure that _ is correct for all tests
$File::Find::dont_use_nlink = 1;
## otherwise, we have to lstat/stat($_) inside _run
## thanks, tye!

sub _run {
  my $self = shift;

  my @stat;
  @stat = stat if defined $_;

  my @state = (1);
  ## $state[-1]:
  ## if 2: we're in a true state, but we've just seen a NOT
  ## if 1: we're in a true state
  ## if 0: we're in a false state
  ## if -1: we're in a "skipping" state (true OR ...[here]...)

  for my $step(@{$self->{steps}}) {

    ## verify underscore handle is good:
    if (@stat) {
      my @cache_stat = stat _;
      stat unless "@stat" eq "@cache_stat";
    }

    if (ref $step) {		# coderef
      if ($state[-1] >= 1) {	# true state
	if ($self->$step) {	# coderef ran returning true
	  if ($state[-1] == 2) {
	    $state[-1] = 0;
	  }
	} else {
	  $state[-1]--;		# 2 => 1, 1 => 0
	}
      }
    } elsif ($step eq "or") {
      # -1 => -1, 0 => 1, 1 => -1, 2 is error
      croak "not before or?" if $state[-1] > 1;
      if ($state[-1] == 0) {
	$state[-1] = 1;
      } elsif ($state[-1] == 1) {
	$state[-1] = -1;
      }
    } elsif ($step eq "left") {
      ## start subrule
      ## -1 => -1, 0 => -1, 1 => 1, 2 => 1
      push @state, ($state[-1] >= 1) ? 1 : -1;
    } elsif ($step eq "right") {
      ## end subrule
      croak "right without left" unless @state > 1;
      croak "not before right" if $state[-1] > 1;
      my $result = pop @state;
      if ($state[-1] >= 1) {
	if ($result) { # 1 or -1, so counts as true
	  if ($state[-1] == 2) {
	    $state[-1] = 0;
	  }
	} else {
	  $state[-1]--;		# 2 => 1, 1 => 0
	}
      }
    } elsif ($step eq "comma") {
      croak "not before comma" if $state[-1] > 1;
      if (@state < 2) {		# not in parens
	$state[-1] = 1;		# reset to true
      } else {			# in parens, reset as if start of parens
	$state[-1] = (($state[-2] >= 1) ? 1 : -1);
      }
    } elsif ($step eq "not") {
      # -1 => -1, 0 => 0, 1 => 2, 2 => 1
      if ($state[-1] >= 1) {
	$state[-1] = $state[-1] > 1 ? 1 : 2;
      }
    } else {
      die "internal error at $step";
    }
  }
  croak "left without right" unless @state == 1;
  croak "trailing not" if $state[-1] > 1;
  return $state[-1] != 0;	# true and skipping are both true
}

sub AUTOLOAD {
  my $self = _force_object(shift);

  my ($method) = our $AUTOLOAD =~ /(?:.*::)?(.*)/;
  return if $method eq "DESTROY";

  my $clone = $self->_clone;

  ## bring in the steps
  my $steps_class = $clone->_steps_class;
  $steps_class =~ /[^\w:]/
    and die "bad value for \$steps_class: $steps_class";
  eval "require $steps_class"; die $@ if $@;

  my $sub_method = $steps_class->can($method)
    or croak "Cannot add step $method";

  push @{$clone->{steps}}, $sub_method->($clone, @_);
  $clone;
}

sub _steps_class { "File::Finder::Steps" }

1;
__END__