File Coverage

blib/lib/File/Find/Rule.pm

Criterion	Covered	Total	%
statement	196	297	65.9
branch	34	42	80.9
condition	4	6	66.6
subroutine	37	39	94.8
pod	13	14	92.8
total	284	398	71.3

#       $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.34';

# 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 $@;
    }
}

=head1 NAME

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

=head1 SYNOPSIS

  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 );

=head1 DESCRIPTION

File::Find::Rule is a friendlier interface to File::Find.  It allows
you to build rules which specify the desired files and directories.

=cut

# 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;
}


=head1 METHODS

=over

=item C

A constructor.  You need not invoke C manually unless you wish
to, as each of the rule-making methods will auto-create a suitable
object if called as class methods.

=cut

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;
}

=back

=head2 Matching Rules

=over

=item C

Specifies names that should match.  May be globs or regular
expressions.

 $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs
 $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex
 $set->name( 'foo.bar' );        # just things named foo.bar

=cut

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;
}

=item -X tests

Synonyms are provided for each of the -X tests. See L for
details.  None of these methods take arguments.

  Test | Method               Test |  Method
 ------|-------------        ------|----------------
   -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

Though some tests are fairly meaningless as binary flags (C,
C, C), they have been included for completeness.

 # find nonempty files
 $rule->file,
      ->nonempty;

=cut

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;
}


=item stat tests

The following C based methods are provided: C, C,
C, C, C, C, C, C, C,
C, C, C, and C.  See L
for details.

Each of these can take a number of targets, which will follow
L semantics.

 $rule->size( 7 );         # exactly 7
 $rule->size( ">7Ki" );    # larger than 7 * 1024 * 1024 bytes
 $rule->size( ">=7" )
      ->size( "<=90" );    # between 7 and 90, inclusive
 $rule->size( 7, 9, 42 );  # 7, 9 or 42

=cut

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;
    }
}

=item C

=item C

Allows shortcircuiting boolean evaluation as an alternative to the
default and-like nature of combined rules.  C and C are
interchangeable.

 # find avis, movs, things over 200M and empty files
 $rule->any( File::Find::Rule->name( '*.avi', '*.mov' ),
             File::Find::Rule->size( '>200M' ),
             File::Find::Rule->file->empty,
           );

=cut

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;

=item C

=item C

Negates a rule.  (The inverse of C.)  C and C are
interchangeable.

  # files that aren't 8.3 safe
  $rule->file
       ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) );

=cut

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 = \¬

=item C

Traverse no further.  This rule always matches.

=cut

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

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

=item C

Don't keep this file.  This rule always matches.

=cut

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

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

=item C

Allows user-defined rules.  Your subroutine will be invoked with C<$_>
set to the current short name, and with parameters of the name, the
path you're in, and the full relative filename.

Return a true value if your rule matched.

 # get things with long names
 $rules->exec( sub { length > 20 } );

=cut

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

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

=item C

Opens a file and tests it each line at a time.

For each line it evaluates each of the specifiers, stopping at the
first successful match.  A specifier may be a regular expression or a
subroutine.  The subroutine will be invoked with the same parameters
as an ->exec subroutine.

It is possible to provide a set of negative specifiers by enclosing
them in anonymous arrays.  Should a negative specifier match the
iteration is aborted and the clause is failed.  For example:

 $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] );

Is a passing clause if the first line of a file looks like a perl
shebang line.

=cut

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

=item C

Descend at most C<$level> (a non-negative integer) levels of directories
below the starting point.

May be invoked many times per rule, but only the most recent value is
used.

=item C

Do not apply any tests at levels less than C<$level> (a non-negative
integer).

=item C

Specifies extra values to pass through to C as part
of the options hash.

For example this allows you to specify following of symlinks like so:

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

May be invoked many times per rule, but only the most recent value is
used.

=cut

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


=item C

Trim the leading portion of any path found

=cut

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

=item C

Normalize paths found using Ccanonpath>. This will return paths
with a file-seperator that is native to your OS (as determined by L),
 instead of the default C.

For example, this will return C on Unix-ish OSes
and C on Win32.

=cut

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

=item C

Negated version of the rule.  An effective shortand related to ! in
the procedural interface.

 $foo->not_name('*.pl');

 $foo->not( $foo->new->name('*.pl' ) );

=cut

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;
}

=back

=head2 Query Methods

=over

=item C

Evaluates the rule, returns a list of paths to matching files and
directories.

=cut

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};
        my $canonpath = $self->{canonpath};

        # 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) {
            if ($relpath ne "") {
                push @found, $canonpath ? File::Spec->canonpath($relpath) : $relpath;
            }
        }
        else {
            push @found, $canonpath ? File::Spec->canonpath($path) : $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;
}

=item C

Starts a find across the specified directories.  Matching items may
then be queried using L.  This allows you to use a rule as an
iterator.

 my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" );
 while ( defined ( my $image = $rule->match ) ) {
     ...
 }

=cut

sub start {
    my $self = _force_object shift;

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

=item C

Returns the next file which matches, false if there are no more.

=cut

sub match {
    my $self = _force_object shift;

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

1;

__END__