File Coverage

blib/lib/File/Find/Object/Rule.pm

Criterion	Covered	Total	%
statement	216	292	73.9
branch	41	50	82.0
condition	7	9	77.7
subroutine	43	45	95.5
pod	15	15	100.0
total	322	411	78.3

#       $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;
$File::Find::Object::Rule::VERSION = '0.0313';
use strict;
use warnings;

use 5.008;

use vars qw/$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

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() ) . " )" } @rulesets )
                . ")",
            args => \@rulesets,
        }
    );
    $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 ()
            {
                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 $self;
}


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__