File::Find::Rule - Alternative interface to File::Find

  use File::Find::Rule;
  # find all the subdirectories of a given directory
  my @subdirs = File::Find::Rule->directory->in( $directory );

  # find all the .pm files in @INC
  my @files = File::Find::Rule->file()
                              ->name( '*.pm' )
                              ->in( @INC );

  # as above, but without method chaining
  my $rule =  File::Find::Rule->new;
  $rule->file;
  $rule->name( '*.pm' );
  my @files = $rule->in( @INC );

 use File::Find::Rule::ImageSize;
 use File::Find::Rule::MMagic;

 # now your rules can use the clauses supplied by the ImageSize and
 # MMagic extension

 use File::Find::Rule qw( :ImageSize :MMagic );

    my $rule = File::Find::Rule->extras({ untaint => 1 });

#       $Id$

package File::Find::Rule;
use strict;
use File::Spec;
use Text::Glob 'glob_to_regex';
use Number::Compare;
use Carp qw/croak/;
use File::Find (); # we're only wrapping for now

our $VERSION = '0.32';

# we'd just inherit from Exporter, but I want the colon
sub import {
    my $pkg = shift;
    my $to  = caller;
    for my $sym ( qw( find rule ) ) {
        no strict 'refs';
        *{"$to\::$sym"} = \&{$sym};
    }
    for (grep /^:/, @_) {
        my ($extension) = /^:(.*)/;
        eval "require File::Find::Rule::$extension";
        croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@;
    }
}

# the procedural shim

*rule = \&find;
sub find {
    my $object = __PACKAGE__->new();
    my $not = 0;

    while (@_) {
        my $method = shift;
        my @args;

        if ($method =~ s/^\!//) {
            # jinkies, we're really negating this
            unshift @_, $method;
            $not = 1;
            next;
        }
        unless (defined prototype $method) {
            my $args = shift;
            @args = ref $args eq 'ARRAY' ? @$args : $args;
        }
        if ($not) {
            $not = 0;
            @args = $object->new->$method(@args);
            $method = "not";
        }

        my @return = $object->$method(@args);
        return @return if $method eq 'in';
    }
    $object;
}

sub new {
    my $referent = shift;
    my $class = ref $referent || $referent;
    bless {
        rules    => [],
        subs     => {},
        iterator => [],
        extras   => {},
        maxdepth => undef,
        mindepth => undef,
    }, $class;
}

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 name {
    my $self = _force_object shift;
    my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ );

    push @{ $self->{rules} }, {
        rule => 'name',
        code => join( ' || ', map { "m($_)" } @names ),
        args => \@_,
    };

    $self;
}

use vars qw( %X_tests );
%X_tests = (
    -r  =>  readable           =>  -R  =>  r_readable      =>
    -w  =>  writeable          =>  -W  =>  r_writeable     =>
    -w  =>  writable           =>  -W  =>  r_writable      =>
    -x  =>  executable         =>  -X  =>  r_executable    =>
    -o  =>  owned              =>  -O  =>  r_owned         =>

    -e  =>  exists             =>  -f  =>  file            =>
    -z  =>  empty              =>  -d  =>  directory       =>
    -s  =>  nonempty           =>  -l  =>  symlink         =>
                               =>  -p  =>  fifo            =>
    -u  =>  setuid             =>  -S  =>  socket          =>
    -g  =>  setgid             =>  -b  =>  block           =>
    -k  =>  sticky             =>  -c  =>  character       =>
                               =>  -t  =>  tty             =>
    -M  =>  modified                                       =>
    -A  =>  accessed           =>  -T  =>  ascii           =>
    -C  =>  changed            =>  -B  =>  binary          =>
   );

for my $test (keys %X_tests) {
    my $sub = eval 'sub () {
                my $self = _force_object shift;
                push @{ $self->{rules} }, {
                        code => "' . $test . ' \$_",
                        rule => "'.$X_tests{$test}.'",
                };
                $self;
        } ';
    no strict 'refs';
    *{ $X_tests{$test} } = $sub;
}

use vars qw( @stat_tests );
@stat_tests = qw( dev ino mode nlink uid gid rdev
                  size atime mtime ctime blksize blocks );
{
    my $i = 0;
    for my $test (@stat_tests) {
        my $index = $i++; # to close over
        my $sub = sub {
            my $self = _force_object shift;

            my @tests = map { Number::Compare->parse_to_perl($_) } @_;

            push @{ $self->{rules} }, {
                rule => $test,
                args => \@_,
                code => 'do { my $val = (stat $_)['.$index.'] || 0;'.
                  join ('||', map { "(\$val $_)" } @tests ).' }',
            };
            $self;
        };
        no strict 'refs';
        *$test = $sub;
    }
}

sub any {
    my $self = _force_object shift;
    # compile all the subrules to code fragments
    push @{ $self->{rules} }, {
        rule => "any",
        code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')',
        args => \@_,
    };
    
    # merge all the subs hashes of the kids into ourself
    %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_;
    $self;
}

*or = \&any;

sub not {
    my $self = _force_object shift;

    push @{ $self->{rules} }, {
        rule => 'not',
        args => \@_,
        code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")",
    };
    
    # merge all the subs hashes into us
    %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_;
    $self;
}

*none = \¬

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

    push @{ $self->{rules} },
      {
       rule => 'prune',
       code => '$File::Find::prune = 1'
      };
    $self;
}

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

    push @{ $self->{rules} }, {
        rule => 'discard',
        code => '$discarded = 1',
    };
    $self;
}

sub exec {
    my $self = _force_object shift;
    my $code = shift;

    push @{ $self->{rules} }, {
        rule => 'exec',
        code => $code,
    };
    $self;
}

sub grep {
    my $self = _force_object shift;
    my @pattern = map {
        ref $_
          ? ref $_ eq 'ARRAY'
            ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_
            : [ $_ => 1 ]
          : [ qr/$_/ => 1 ]
      } @_;

    $self->exec( sub {
        local *FILE;
        open FILE, $_ or return;
        local ($_, $.);
        while (<FILE>) {
            for my $p (@pattern) {
                my ($rule, $ret) = @$p;
                return $ret
                  if ref $rule eq 'Regexp'
                    ? /$rule/
                      : $rule->(@_);
            }
        }
        return;
    } );
}

for my $setter (qw( maxdepth mindepth extras )) {
    my $sub = sub {
        my $self = _force_object shift;
        $self->{$setter} = shift;
        $self;
    };
    no strict 'refs';
    *$setter = $sub;
}

sub relative () {
    my $self = _force_object shift;
    $self->{relative} = 1;
    $self;
}

sub DESTROY {}
sub AUTOLOAD {
    our $AUTOLOAD;
    $AUTOLOAD =~ /::not_([^:]*)$/
      or croak "Can't locate method $AUTOLOAD";
    my $method = $1;

    my $sub = sub {
        my $self = _force_object shift;
        $self->not( $self->new->$method(@_) );
    };
    {
        no strict 'refs';
        *$AUTOLOAD = $sub;
    }
    &$sub;
}

sub in {
    my $self = _force_object shift;

    my @found;
    my $fragment = $self->_compile;
    my %subs = %{ $self->{subs} };

    warn "relative mode handed multiple paths - that's a bit silly\n"
      if $self->{relative} && @_ > 1;

    my $topdir;
    my $code = 'sub {
                (my $path = $File::Find::name)  =~ s#^(?:\./+)+##;
                my @args = ($_, $File::Find::dir, $path);
                my $maxdepth = $self->{maxdepth};
                my $mindepth = $self->{mindepth};
                my $relative = $self->{relative};

                # figure out the relative path and depth
                my $relpath = $File::Find::name;
                $relpath =~ s{^\Q$topdir\E/?}{};
                my $depth = scalar File::Spec->splitdir($relpath);
                #print "name: \'$File::Find::name\' ";
                #print "relpath: \'$relpath\' depth: $depth relative: $relative\n";

                defined $maxdepth && $depth >= $maxdepth
                      and $File::Find::prune = 1;

                defined $mindepth && $depth < $mindepth
                      and return;

                #print "Testing \'$_\'\n";

                my $discarded;
                return unless ' . $fragment . ';
                return if $discarded;
                if ($relative) {
                        push @found, $relpath if $relpath ne "";
                }
                else {
                        push @found, $path;
                }
        }';

    #use Data::Dumper;
    #print Dumper \%subs;
    #warn "Compiled sub: '$code'\n";

    my $sub = eval "$code" or die "compile error '$code' $@";
    for my $path (@_) {
        # $topdir is used for relative and maxdepth
        $topdir = $path;
        # slice off the trailing slash if there is one (the
        # maxdepth/mindepth code is fussy)
        $topdir =~ s{/?$}{}
          unless $topdir eq '/';
        $self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path );
    }

    return @found;
}

sub _call_find {
    my $self = shift;
    File::Find::find( @_ );
}

sub _compile {
    my $self = shift;

    return '1' unless @{ $self->{rules} };
    my $code = join " && ", map {
        if (ref $_->{code}) {
            my $key = "$_->{code}";
            $self->{subs}{$key} = $_->{code};
            "\$subs{'$key'}->(\@args) # $_->{rule}\n";
        }
        else {
            "( $_->{code} ) # $_->{rule}\n";
        }
    } @{ $self->{rules} };

    #warn $code;
    return $code;
}

sub start {
    my $self = _force_object shift;

    $self->{iterator} = [ $self->in( @_ ) ];
    $self;
}

sub match {
    my $self = _force_object shift;

    return shift @{ $self->{iterator} };
}

1;

__END__

Implementation notes:

$self->rules is an array of hashrefs.  it may be a code fragment or a call
to a subroutine.

Anonymous subroutines are stored in the $self->subs hashref keyed on the
stringfied version of the coderef.

When one File::Find::Rule object is combined with another, such as in the any
and not operations, this entire hash is merged.

The _compile method walks the rules element and simply glues the code
fragments together so they can be compiled into an anyonymous File::Find
match sub for speed


[*] There's probably a win to be made with the current model in making
stat calls use C<_>.  For

  find( file => size => "> 20M" => size => "< 400M" );

up to 3 stats will happen for each candidate.  Adding a priming _
would be a bit blind if the first operation was C< name => 'foo' >,
since that can be tested by a single regex.  Simply checking what the
next type of operation doesn't work since any arbritary exec sub may
or may not stat.  Potentially worse, they could stat something else
like so:

  # extract from the worlds stupidest make(1)
  find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } );

Maybe the best way is to treat C<_> as invalid after calling an exec,
and doc that C<_> will only be meaningful after stat and -X tests if
they're wanted in exec blocks.