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

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

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

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

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

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

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

#       $Id: /mirror/lab/perl/File-Find-Rule/lib/File/Find/Rule.pm 2102 2006-06-01T15:39:03.942922Z richardc  $

package File::Find::Object::Rule;

use strict;
use warnings;

use vars qw/$VERSION $AUTOLOAD/;
use File::Spec;
use Text::Glob 'glob_to_regex';
use Number::Compare;
use Carp qw/croak/;
use File::Find::Object; # we're only wrapping for now
use File::Basename;
use Cwd;           # 5.00503s File::Find goes screwy with max_depth == 0

$VERSION = '0.0300';

use Class::XSAccessor
    accessors => {
        "extras" => "extras",
        "finder" => "finder",
        "_match_cb" => "_match_cb",
        "rules" => "rules",
        "_relative" => "_relative",
        "_subs" => "_subs",
        "_maxdepth" => "_maxdepth",
        "_mindepth" => "_mindepth",
    }
    ;

# 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::Object::Rule::$extension";
        croak "couldn't bootstrap File::Find::Object::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 = ref($object)->new->$method(@args);
            $method = "not";
        }

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

sub new {
    # We need this to maintain compatibility with File-Find-Object.
    # However, Randal Schwartz recommends against this practice in general:
    # http://www.stonehenge.com/merlyn/UnixReview/col52.html
    my $referent = shift;
    my $class = ref $referent || $referent;

    return 
    bless {
        rules    => [],  # [0]
        _subs     => [],  # [1]
        iterator => [],
        extras   => {},
        _maxdepth => undef,
        _mindepth => undef,
        _relative => 0,
    }, $class;
}

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

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

sub _add_rule {
    my $self = shift;
    my $new_rule = shift;

    push @{$self->rules()}, $new_rule;

    return;
}

sub name {
    my $self = _force_object shift;
    my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ );

    $self->_add_rule(
        {
            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;
                $self->_add_rule({
                        code => "' . $test . ' \$path",
                        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($_) } @_;

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

sub any {
    my $self = _force_object shift;
    my @rulesets = @_;

    $self->_add_rule({
        rule => 'any',
        code => '(' . join( ' || ', map {
            "( " . $_->_compile($self->_subs()) . " )"
        } @_ ) . ")",
        args => \@_,
    });
    $self;
}

*or = \&any;

sub not {
    my $self = _force_object shift;
    my @rulesets = @_;

    $self->_add_rule({
        rule => 'not',
        args => \@rulesets,
        code => '(' . join ( ' && ', map {
            "!(". $_->_compile($self->_subs()) . ")"
        } @_ ) . ")",
    });
    $self;
}

*none = \¬

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

    $self->_add_rule(
        {
            rule => 'prune',
            code => 'do { $self->finder->prune(); 1 }'
        },
    );

    return $self;
}

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

    $self->_add_rule({
        rule => 'discard',
        code => '$discarded = 1',
    });

    return $self;
}

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

    $self->_add_rule(
        {
            rule => 'exec',
            code => $code,
        }
    );

    return $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, $self->finder->item() or return;
        local ($_, $.);
        while (<FILE>) {
            for my $p (@pattern) {
                my ($rule, $ret) = @$p;
                return $ret
                  if ref $rule eq 'Regexp'
                    ? /$rule/
                      : $rule->(@_);
            }
        }
        return;
    } );
}

sub maxdepth {
    my $self = _force_object shift;
    $self->_maxdepth(shift);
    return $self;
}

sub mindepth {
    my $self = _force_object shift;
    $self->_mindepth(shift);
    return $self;
}

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

    return $self;
}

sub DESTROY {}
sub 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 _call_find {
    my $self = shift;
    my $paths = shift;

    my $finder = File::Find::Object->new( $self->extras(), @$paths);

    $self->finder($finder);

    return;
}

sub _compile {
    my $self = shift;
    my $subs = shift;

    return '1' unless @{ $self->rules() };

    my $code = join " && ", map {
        if (ref $_->{code}) {
            push @$subs, $_->{code};
            "\$subs->[$#{$subs}]->(\@args) # $_->{rule}\n";
        }
        else {
            "( $_->{code} ) # $_->{rule}\n";
        }
    } @{ $self->rules() };

    return $code;
}

sub in {
    my $self = _force_object shift;
    my @paths = @_;

    $self->start(@paths);

    my @results;

    while (defined(my $match = $self->match()))
    {
        push @results, $match;
    }

    return @results;
}

sub start {
    my $self = _force_object shift;
    my @paths = @_;

    my $fragment = $self->_compile($self->_subs());

    my $subs = $self->_subs();

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

    my $code = 'sub {
                my $path_obj = shift;
                my $path = shift;
                
                if (!defined($path_obj))
                {
                        return;
                }

                $path =~ s#^(?:\./+)+##;
                my $path_dir = dirname($path);
                my $path_base = fileparse($path);
                my @args = ($path_base, $path_dir, $path);
                local $_ = $path_base;
                my $maxdepth = $self->_maxdepth;
                my $mindepth = $self->_mindepth;

                my $comps = $path_obj->full_components();

                my $depth = scalar(@$comps);

                defined $maxdepth && $depth >= $maxdepth
                      and $self->finder->prune();

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

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

                my $discarded;
                return unless ' . $fragment . ';
                return if $discarded;
                return $path;
        }';

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

    my $callback = eval "$code" or die "compile error '$code' $@";

    $self->_match_cb($callback);
    $self->_call_find(\@paths);

    return 1;
}

sub match {
    my $self = _force_object shift;

    my $finder = $self->finder();

    my $match_cb = $self->_match_cb();
    my $preproc_cb = $self->extras()->{'preprocess'};

    while(defined(my $next_obj = $finder->next_obj()))
    {
        if (defined($preproc_cb) && $next_obj->is_dir())
        {
            $finder->set_traverse_to(
                $preproc_cb->(
                        $self, 
                        [ @{$finder->get_current_node_files_list()} ]
                )
            );
        }

        if (defined(my $path = $match_cb->($next_obj, $next_obj->path())))
        {
            if ($self->_relative)
            {
                my $comps = $next_obj->full_components();
                if (@$comps)
                {
                    return
                        ($next_obj->is_dir()
                        ? File::Spec->catdir(@$comps)
                        : File::Spec->catfile(@$comps)
                        )
                    ;
                }
            }
            else
            {
                return $path;
            }
        }

    }

    return;
}

1;

__END__