diff options
author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2011-09-19 11:54:59 +0000 |
---|---|---|
committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2011-09-19 11:54:59 +0000 |
commit | 5e7c9d8e7b80b54baa3f8161222b5a8e9077c0aa (patch) | |
tree | 13376521346e9b901c77087e41c947c1aadbfdd8 | |
download | File-Find-Rule-tarball-master.tar.gz |
File-Find-Rule-0.33HEADFile-Find-Rule-0.33master
-rw-r--r-- | Changes | 134 | ||||
-rw-r--r-- | MANIFEST | 14 | ||||
-rw-r--r-- | META.yml | 25 | ||||
-rw-r--r-- | Makefile.PL | 14 | ||||
-rw-r--r-- | findrule | 138 | ||||
-rw-r--r-- | lib/File/Find/Rule.pm | 797 | ||||
-rw-r--r-- | lib/File/Find/Rule/Extending.pod | 91 | ||||
-rw-r--r-- | lib/File/Find/Rule/Procedural.pod | 72 | ||||
-rw-r--r-- | t/File-Find-Rule.t | 329 | ||||
-rw-r--r-- | t/findrule.t | 35 | ||||
-rw-r--r-- | testdir/File-Find-Rule.t | 313 | ||||
-rw-r--r-- | testdir/findrule.t | 35 | ||||
-rw-r--r-- | testdir/foobar | 1 | ||||
-rw-r--r-- | testdir/lib/File/Find/Rule/Test/ATeam.pm | 11 |
14 files changed, 2009 insertions, 0 deletions
@@ -0,0 +1,134 @@ +0.33 Monday 19th September, 2011 + Fixes the case where name("foo(*") hits an error with mismatched + parentheis. Reported by Jan Engelhardt. + +0.32 Saturday 28th November, 2009 + Rework the referencing of anyonymous subroutines internally, + closes RT#46599 (Reported by Kevin Ryde) + +0.31 Friday 27th November 2009 + Move to Makefile.PL + use Test::Differences in the testsuite if available. + Rearrange the testsuite so you don't keep tripping over yourself. + Dropped 5.00503 backwards compatibility, allows some 5.6isms and + dropping the shonky Cwd code. + All taint 'bugs' are now the same as the behaviour of File::Find, + documentation has been added to describe this. + + +0.30 Wednesday 1st June, 2006 + Made './//././././///.//././/////./blah' be treated the same + as './blah' (it gets turned into 'blah') + +0.29 Tuesday 16th May, 2006 + Kludged around {min,max}depth and trailing slashes in path + names. + +0.28 Tuesday 18th May, 2004 + exposed %X_tests and @stat_tests as package variables, and make a + _call_find method for File::Find::Rule::Filesys::Virtual + +0.27 Wednesday 25th February, 2004 + Changed to write_makefile_pl to 'traditional' from + 'passthrough'. Fixes INDIRECTLY REPORTED install problems + caused by new Module::Build being backwards incompatible. + +0.26 Monday 10th November, 2003 + Typo/thinko in File::Find::Rule::Extending corrected (spotted + by Jim Cromie) + + Optimization to the stat-based tests. They now compile to code + fragments saving much subroutine dispatch. + +0.25 Wednesday 22nd October, 2003 + applied a patch from Leon Brocard to make the tests ignore CVS dirs + as well as .svn dirs. + + reworked part of t/File-Find-Rule.t to not assume that t/foobar will + always be 10 bytes in size. (rt.cpan.org #3838) + + now we install the findrule script + +0.24 Monday 6th October, 2003 + when you specify an extra of C<{ follow => 1 }> File::Find stops + populating $File::Find::topdir. This leads to warnings noise so + instead we now track $topdir ourselves. + +0.23 Friday 3rd October, 2003 + make the extras hash work and add a proper test for it. (Doh!) + +0.22 Friday 3rd October, 2003 + add in ->extras hash for passing things through to File::Find::find + +0.21 Monday 15th September, 2003 + pod glitch in File::Find::Rule::Procedural spotted and fixed + by Tom Hukins + +0.20 8th September, 2003 + - relative flag + + - Fix maxdepth? - this is undertested. + + - MANIFEST fixes (thanks to the cpan smokers) + + - split the documentation of the procedural interface out to + File::Find::Rule::Procedural, as people often seem to get + confused that the method calls don't take anonymous arrays + after seeing the procedural code that did + + - Chunky internal restructure. Now we compile a match sub + from code fragments. Though more complex, this is a big + speed win as it eliminates a lot of the subroutine dispatch. + + - During the restructure we lost the ->test method. I hope + that it's not missed, since maintining it through a + deprecation cycle would be fiddly with the current _compile code. + + - Split the findrule tests into their own file, and just skip + the tricky ones on Win32. + +0.11 29th July, 2003 + - Fix Win32 test failures (rt.cpan.org #3047) + +0.10 10th March 2003 + - fixup an accidental warning in the stat-based tests. Caught + by Alex Gough (rt.cpan.org #2138) + - make the findrule tests more win32 safe/shell independent (picked + up by Philip Newton) + - autogenerate READMEs from bits and pieces + +0.09 21st January 2003 + - Fix to the stat-based tests (spotted by Randal L. Schwartz) + - implemented our own import sub so we can bootstrap + extensions more easily + - added some documentation about using extensions. + +0.08 28th October, 2002 + - ->not_* and implicit s#^\./## (based on suggestions by Tony + Bowden) + - Sketchy first cut of findrule (suggestion from Tatsuhiko Miyagawa) + +0.07 25th October, 2002 + - Tweaks required to let extensions work + +0.06 22nd October, 2002 + -> Fix the code example for the ->grep clause (again from + Douglas Wilson) + +0.05 21st October, 2002 + - ->grep clause - from original code from Douglas Wilson + - Bugfix the demo code in the synopsis - pointed out by Barbie + +0.04 10th September, 2002 + - create a correctly spelled writable rule (thanks to Iain + Truskett for this one) + +0.03 24th August, 2002 + - backport to 5.00503 (hadn't tested before this point) + +0.02 14th August, 2002 + - bugfix ->exec subrule invocation (thanks to Chris Carline + for pointing this out) + +0.01 26th July, 2002 + - Inital release diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..458e184 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,14 @@ +MANIFEST +Changes +Makefile.PL +META.yml +lib/File/Find/Rule.pm +lib/File/Find/Rule/Extending.pod +lib/File/Find/Rule/Procedural.pod +t/File-Find-Rule.t +t/findrule.t +testdir/File-Find-Rule.t +testdir/findrule.t +testdir/foobar +testdir/lib/File/Find/Rule/Test/ATeam.pm +findrule diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..ca79cf4 --- /dev/null +++ b/META.yml @@ -0,0 +1,25 @@ +--- #YAML:1.0 +name: File-Find-Rule +version: 0.33 +abstract: ~ +author: [] +license: unknown +distribution_type: module +configure_requires: + ExtUtils::MakeMaker: 0 +build_requires: + ExtUtils::MakeMaker: 0 +requires: + File::Find: 0 + File::Spec: 0 + Number::Compare: 0 + Test::More: 0 + Text::Glob: 0.07 +no_index: + directory: + - t + - inc +generated_by: ExtUtils::MakeMaker version 6.57_05 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..34f4caf --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,14 @@ +use strict; +use ExtUtils::MakeMaker; +WriteMakefile( + 'NAME' => 'File::Find::Rule', + 'VERSION_FROM' => 'lib/File/Find/Rule.pm', + 'PREREQ_PM' => { + 'File::Find' => 0, + 'File::Spec' => 0, + 'Number::Compare' => 0, + 'Text::Glob' => '0.07', + 'Test::More' => 0, + }, + 'EXE_FILES' => ['findrule'], +); diff --git a/findrule b/findrule new file mode 100644 index 0000000..6aa37d6 --- /dev/null +++ b/findrule @@ -0,0 +1,138 @@ +#!perl -w +use strict; +use File::Find::Rule; +use File::Spec::Functions qw(catdir); + +# bootstrap extensions +for (@INC) { + my $dir = catdir($_, qw( File Find Rule ) ); + next unless -d $dir; + my @pm = find( name => '*.pm', maxdepth => 1, + exec => sub { (my $name = $_) =~ s/\.pm$//; + eval "require File::Find::Rule::$name"; }, + in => $dir ); +} + +# what directories are we searching in? +my @where; +while (@ARGV) { + local $_ = shift @ARGV; + if (/^-/) { + unshift @ARGV, $_; + last; + } + push @where, $_; +} + +# parse arguments, build a rule object +my $rule = new File::Find::Rule; +while (@ARGV) { + my $clause = shift @ARGV; + + unless ( $clause =~ s/^-// && $rule->can( $clause ) ) { + # not a known rule - complain about this + die "unknown option '$clause'\n" + } + + # it was the last switch + unless (@ARGV) { + $rule->$clause(); + next; + } + + # consume the parameters + my $param = shift @ARGV; + + if ($param =~ /^-/) { + # it's the next switch - put it back, and add one with no params + unshift @ARGV, $param; + $rule->$clause(); + next; + } + + if ($param eq '(') { + # multiple values - just look for the closing parenthesis + my @p; + while (@ARGV) { + my $val = shift @ARGV; + last if $val eq ')'; + push @p, $val; + } + $rule->$clause( @p ); + next; + } + + # a single argument + $rule->$clause( $param ); +} + +# add a print rule so things happen faster +$rule->exec( sub { print "$_[2]\n"; return; } ); + +# profit +$rule->in( @where ? @where : '.' ); +exit 0; + +__END__ + +=head1 NAME + +findrule - command line wrapper to File::Find::Rule + +=head1 USAGE + + findrule [path...] [expression] + +=head1 DESCRIPTION + +C<findrule> mostly borrows the interface from GNU find(1) to provide a +command-line interface onto the File::Find::Rule heirarchy of modules. + +The syntax for expressions is the rule name, preceded by a dash, +followed by an optional argument. If the argument is an opening +parenthesis it is taken as a list of arguments, terminated by a +closing parenthesis. + +Some examples: + + find -file -name ( foo bar ) + +files named C<foo> or C<bar>, below the current directory. + + find -file -name foo -bar + +files named C<foo>, that have pubs (for this is what our ficticious +C<bar> clause specifies), below the current directory. + + find -file -name ( -bar ) + +files named C<-bar>, below the current directory. In this case if +we'd have omitted the parenthesis it would have parsed as a call to +name with no arguments, followed by a call to -bar. + +=head2 Supported switches + +I'm very slack. Please consult the File::Find::Rule manpage for now, +and prepend - to the commands that you want. + +=head2 Extra bonus switches + +findrule automatically loads all of your installed File::Find::Rule::* +extension modules, so check the documentation to see what those would be. + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> from a suggestion by Tatsuhiko Miyagawa + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Find::Rule> + +=cut diff --git a/lib/File/Find/Rule.pm b/lib/File/Find/Rule.pm new file mode 100644 index 0000000..93a21b9 --- /dev/null +++ b/lib/File/Find/Rule.pm @@ -0,0 +1,797 @@ +# $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.33'; + +# 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<new> + +A constructor. You need not invoke C<new> 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<name( @patterns )> + +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<perlfunc/-X> 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<modified>, +C<accessed>, C<changed>), 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<stat> based methods are provided: C<dev>, C<ino>, +C<mode>, C<nlink>, C<uid>, C<gid>, C<rdev>, C<size>, C<atime>, +C<mtime>, C<ctime>, C<blksize>, and C<blocks>. See L<perlfunc/stat> +for details. + +Each of these can take a number of targets, which will follow +L<Number::Compare> 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<any( @rules )> + +=item C<or( @rules )> + +Allows shortcircuiting boolean evaluation as an alternative to the +default and-like nature of combined rules. C<any> and C<or> 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<none( @rules )> + +=item C<not( @rules )> + +Negates a rule. (The inverse of C<any>.) C<none> and C<not> 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<prune> + +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<discard> + +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<exec( \&subroutine( $shortname, $path, $fullname ) )> + +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<grep( @specifiers )> + +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 (<FILE>) { + for my $p (@pattern) { + my ($rule, $ret) = @$p; + return $ret + if ref $rule eq 'Regexp' + ? /$rule/ + : $rule->(@_); + } + } + return; + } ); +} + +=item C<maxdepth( $level )> + +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<mindepth( $level )> + +Do not apply any tests at levels less than C<$level> (a non-negative +integer). + +=item C<extras( \%extras )> + +Specifies extra values to pass through to C<File::File::find> 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<relative> + +Trim the leading portion of any path found + +=cut + +sub relative () { + my $self = _force_object shift; + $self->{relative} = 1; + $self; +} + +=item C<not_*> + +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<in( @directories )> + +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}; + + # 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; +} + +=item C<start( @directories )> + +Starts a find across the specified directories. Matching items may +then be queried using L</match>. 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<match> + +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__ + +=back + +=head2 Extensions + +Extension modules are available from CPAN in the File::Find::Rule +namespace. In order to use these extensions either use them directly: + + use File::Find::Rule::ImageSize; + use File::Find::Rule::MMagic; + + # now your rules can use the clauses supplied by the ImageSize and + # MMagic extension + +or, specify that File::Find::Rule should load them for you: + + use File::Find::Rule qw( :ImageSize :MMagic ); + +For notes on implementing your own extensions, consult +L<File::Find::Rule::Extending> + +=head2 Further examples + +=over + +=item Finding perl scripts + + my $finder = File::Find::Rule->or + ( + File::Find::Rule->name( '*.pl' ), + File::Find::Rule->exec( + sub { + if (open my $fh, $_) { + my $shebang = <$fh>; + close $fh; + return $shebang =~ /^#!.*\bperl/; + } + return 0; + } ), + ); + +Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842 + +=item ignore CVS directories + + my $rule = File::Find::Rule->new; + $rule->or($rule->new + ->directory + ->name('CVS') + ->prune + ->discard, + $rule->new); + +Note here the use of a null rule. Null rules match anything they see, +so the effect is to match (and discard) directories called 'CVS' or to +match anything. + +=back + +=head1 TWO FOR THE PRICE OF ONE + +File::Find::Rule also gives you a procedural interface. This is +documented in L<File::Find::Rule::Procedural> + +=head1 EXPORTS + +L</find>, L</rule> + +=head1 TAINT MODE INTERACTION + +As of 0.32 File::Find::Rule doesn't capture the current working directory in +a taint-unsafe manner. File::Find itself still does operations that the taint +system will flag as insecure but you can use the L</extras> feature to ask +L<File::Find> to internally C<untaint> file paths with a regex like so: + + my $rule = File::Find::Rule->extras({ untaint => 1 }); + +Please consult L<File::Find>'s documentation for C<untaint>, +C<untaint_pattern>, and C<untaint_skip> for more information. + +=head1 BUGS + +The code makes use of the C<our> keyword and as such requires perl version +5.6.0 or newer. + +Currently it isn't possible to remove a clause from a rule object. If +this becomes a significant issue it will be addressed. + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> with input gained from this +use.perl discussion: http://use.perl.org/~richardc/journal/6467 + +Additional proofreading and input provided by Kake, Greg McCarroll, +and Andy Lester andy@petdance.com. + +=head1 COPYRIGHT + +Copyright (C) 2002, 2003, 2004, 2006, 2009, 2011 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Find>, L<Text::Glob>, L<Number::Compare>, find(1) + +If you want to know about the procedural interface, see +L<File::Find::Rule::Procedural>, and if you have an idea for a neat +extension L<File::Find::Rule::Extending> + +=cut + +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. diff --git a/lib/File/Find/Rule/Extending.pod b/lib/File/Find/Rule/Extending.pod new file mode 100644 index 0000000..7137859 --- /dev/null +++ b/lib/File/Find/Rule/Extending.pod @@ -0,0 +1,91 @@ +=head1 NAME + +File::Find::Rule::Extending - the mini-guide to extending File::Find::Rule + +=head1 SYNOPSIS + + package File::Find::Rule::Random; + use strict; + + # take useful things from File::Find::Rule + use base 'File::Find::Rule'; + + # and force our crack into the main namespace + sub File::Find::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + + 1; + +=head1 DESCRIPTION + +File::Find::Rule went down so well with the buying public that +everyone wanted to add extra features. With the 0.07 release this +became a possibility, using the following conventions. + +=head2 Declare your package + + package File::Find::Rule::Random; + use strict; + +=head2 Inherit methods from File::Find::Rule + + # take useful things from File::Find::Rule + use base 'File::Find::Rule'; + +=head3 Force your madness into the main package + + # and force our crack into the main namespace + sub File::Find::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + + +Yes, we're being very cavalier here and defining things into the main +File::Find::Rule namespace. This is due to lack of imaginiation on my +part - I simply can't find a way for the functional and oo interface +to work without doing this or some kind of inheritance, and +inheritance stops you using two File::Find::Rule::Foo modules +together. + +For this reason try and pick distinct names for your extensions. If +this becomes a problem then I may institute a semi-official registry +of taken names. + +=head2 Taking no arguments. + +Note the null prototype on random. This is a cheat for the procedural +interface to know that your sub takes no arguments, and so allows this +to happen: + + find( random => in => '.' ); + +If you hadn't declared C<random> with a null prototype it would have +consumed C<in> as a parameter to it, then got all confused as it +doesn't know about a C<'.'> rule. + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Find::Rule> + +L<File::Find::Rule::MMagic> was the first extension module, so maybe +check that out. + +=cut + + + + diff --git a/lib/File/Find/Rule/Procedural.pod b/lib/File/Find/Rule/Procedural.pod new file mode 100644 index 0000000..09eeadd --- /dev/null +++ b/lib/File/Find/Rule/Procedural.pod @@ -0,0 +1,72 @@ +=head1 NAME + +File::Find::Rule::Procedural - File::Find::Rule's procedural interface + +=head1 SYNOPSIS + + use File::Find::Rule; + + # find all .pm files, procedurally + my @files = find(file => name => '*.pm', in => \@INC); + +=head1 DESCRIPTION + +In addition to the regular object-oriented interface, +L<File::Find::Rule> provides two subroutines for you to use. + +=over + +=item C<find( @clauses )> + +=item C<rule( @clauses )> + +C<find> and C<rule> can be used to invoke any methods available to the +OO version. C<rule> is a synonym for C<find> + +=back + +Passing more than one value to a clause is done with an anonymous +array: + + my $finder = find( name => [ '*.mp3', '*.ogg' ] ); + +C<find> and C<rule> both return a File::Find::Rule instance, unless +one of the arguments is C<in>, in which case it returns a list of +things that match the rule. + + my @files = find( name => [ '*.mp3', '*.ogg' ], in => $ENV{HOME} ); + +Please note that C<in> will be the last clause evaluated, and so this +code will search for mp3s regardless of size. + + my @files = find( name => '*.mp3', in => $ENV{HOME}, size => '<2k' ); + ^ + | + Clause processing stopped here ------/ + +It is also possible to invert a single rule by prefixing it with C<!> +like so: + + # large files that aren't videos + my @files = find( file => + '!name' => [ '*.avi', '*.mov' ], + size => '>20M', + in => $ENV{HOME} ); + + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> + +=head1 COPYRIGHT + +Copyright (C) 2003 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Find::Rule> + +=cut diff --git a/t/File-Find-Rule.t b/t/File-Find-Rule.t new file mode 100644 index 0000000..1a00637 --- /dev/null +++ b/t/File-Find-Rule.t @@ -0,0 +1,329 @@ +#!perl -w +# $Id$ + +use strict; +use Test::More tests => 45; + +if (eval { require Test::Differences; 1 }) { + no warnings; + *is_deeply = *Test::Differences::eq_or_diff; +} + + +my $class; +my @tests = qw( testdir/File-Find-Rule.t testdir/findrule.t ); +BEGIN { + $class = 'File::Find::Rule'; + use_ok($class) +} + +# on win32 systems the testdir/foobar file isn't 10 bytes it's 11, so the +# previous tests on the magic number 10 failed. rt.cpan.org #3838 +my $foobar_size = -s 'testdir/foobar'; + +my $f = $class->new; +isa_ok($f, $class); + + +# name +$f = $class->name( qr/\.t$/ ); +is_deeply( [ sort $f->in('testdir') ], + [ @tests ], + "name( qr/\\.t\$/ )" ); + +$f = $class->name( 'foobar' ); +is_deeply( [ $f->in('testdir') ], + [ 'testdir/foobar' ], + "name( 'foobar' )" ); + +$f = $class->name( '*.t' ); +is_deeply( [ sort $f->in('testdir') ], + \@tests, + "name( '*.t' )" ); + +$f = $class->name( 'foobar', '*.t' ); +is_deeply( [ sort $f->in('testdir') ], + [ @tests, 'testdir/foobar' ], + "name( 'foobar', '*.t' )" ); + +$f = $class->name( [ 'foobar', '*.t' ] ); +is_deeply( [ sort $f->in('testdir') ], + [ @tests, 'testdir/foobar' ], + "name( [ 'foobar', '*.t' ] )" ); + +$f = $class->name( "test(*" ); +is_deeply( [ sort $f->in('testdir') ], + [], + 'name("test(*"); used to be invalid' ); + + +# exec +$f = $class->exec(sub { length == 6 })->maxdepth(1); +is_deeply( [ $f->in('testdir') ], + [ 'testdir/foobar' ], + "exec (short)" ); + +$f = $class->exec(sub { length > $foobar_size })->maxdepth(1); +is_deeply( [ $f->in('testdir') ], + [ 'testdir/File-Find-Rule.t' ], + "exec (long)" ); + +is_deeply( [ find( maxdepth => 1, exec => sub { $_[2] eq 'testdir/foobar' }, in => 'testdir' ) ], + [ 'testdir/foobar' ], + "exec (check arg 2)" ); + +# name and exec, chained +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/\.t$/ ); + +is_deeply( [ $f->in('testdir') ], + [ 'testdir/File-Find-Rule.t' ], + "exec(match) and name(match)" ); + +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/foo/ ) + ->maxdepth(1); + +is_deeply( [ $f->in('testdir') ], + [ ], + "exec(match) and name(fail)" ); + + +# directory +$f = $class + ->directory + ->maxdepth(1) + ->exec(sub { $_ !~ /(\.svn|CVS)/ }); # ignore .svn/CVS dirs + +is_deeply( [ $f->in('testdir') ], + [ qw( testdir testdir/lib ) ], + "directory autostub" ); + + +# any/or +$f = $class->any( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +is_deeply( [ sort $f->in('testdir') ], + [ 'testdir/File-Find-Rule.t', 'testdir/foobar' ], + "any" ); + +$f = $class->or( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +is_deeply( [ sort $f->in('testdir') ], + [ 'testdir/File-Find-Rule.t', 'testdir/foobar' ], + "or" ); + +# nesting ->or (RT 46599) +$f = $class->or( $class->or( $class->name("foobar") ) ); +is_deeply( [ sort $f->in('testdir') ], + [ 'testdir/foobar' ], + "or, nested" ); + + +# not/none +$f = $class + ->file + ->not( $class->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 10 }); +is_deeply( [ $f->in('testdir') ], + [ 'testdir/File-Find-Rule.t' ], + "not" ); + +# not as not_* +$f = $class + ->file + ->not_name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 10 }); +is_deeply( [ $f->in('testdir') ], + [ 'testdir/File-Find-Rule.t' ], + "not_*" ); + +# prune/discard (.svn demo) +# this test may be a little meaningless for a cpan release, but it +# fires perfectly in my dev sandbox +$f = $class->or( $class->directory + ->name(qr/(\.svn|CVS)/) + ->prune + ->discard, + $class->new->file ); + +is_deeply( [ sort $f->in('testdir') ], + [ @tests, 'testdir/foobar', 'testdir/lib/File/Find/Rule/Test/ATeam.pm' ], + "prune/discard .svn" + ); + + +# procedural form of the CVS demo +$f = find(or => [ find( directory => + name => qr/(\.svn|CVS)/, + prune => + discard => ), + find( file => ) ]); + +is_deeply( [ sort $f->in('testdir') ], + [ @tests, 'testdir/foobar', 'testdir/lib/File/Find/Rule/Test/ATeam.pm' ], + "procedural prune/discard .svn" + ); + +# size (stat test) +is_deeply( [ find( maxdepth => 1, file => size => $foobar_size, in => 'testdir' ) ], + [ 'testdir/foobar' ], + "size $foobar_size (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<= $foobar_size", + in => 'testdir' ) ], + [ 'testdir/foobar' ], + "size <= $foobar_size (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<".($foobar_size + 1), + in => 'testdir' ) ], + [ 'testdir/foobar' ], + "size <($foobar_size + 1) (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<1K", + exec => sub { length == 6 }, + in => 'testdir' ) ], + [ 'testdir/foobar' ], + "size <1K (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => ">3K", in => 'testdir' ) ], + [ 'testdir/File-Find-Rule.t' ], + "size >3K (stat)" ); + +# these next two should never fail. if they do then the testing fairy +# went mad +is_deeply( [ find( file => size => ">3M", in => 'testdir' ) ], + [ ], + "size >3M (stat)" ); + +is_deeply( [ find( file => size => ">3G", in => 'testdir' ) ], + [ ], + "size >3G (stat)" ); + + +#min/maxdepth + +is_deeply( [ find( maxdepth => 0, in => 'testdir' ) ], + [ 'testdir' ], + "maxdepth == 0" ); + + + +my $rule = find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1 ); + +is_deeply( [ sort $rule->in( 'testdir' ) ], + [ 'testdir', @tests, 'testdir/foobar', 'testdir/lib' ], + "maxdepth == 1" ); +is_deeply( [ sort $rule->in( 'testdir/' ) ], + [ 'testdir', @tests, 'testdir/foobar', 'testdir/lib' ], + "maxdepth == 1, trailing slash on the path" ); + +is_deeply( [ sort $rule->in( './testdir' ) ], + [ 'testdir', @tests, 'testdir/foobar', 'testdir/lib' ], + "maxdepth == 1, ./t" ); + +is_deeply( [ sort $rule->in( './/testdir' ) ], + [ 'testdir', @tests, 'testdir/foobar', 'testdir/lib' ], + "maxdepth == 1, .//t" ); + +is_deeply( [ sort $rule->in( './//testdir' ) ], + [ 'testdir', @tests, 'testdir/foobar', 'testdir/lib' ], + "maxdepth == 1, .///testdir" ); + +is_deeply( [ sort $rule->in( './././///./testdir' ) ], + [ 'testdir', @tests, 'testdir/foobar', 'testdir/lib' ], + "maxdepth == 1, ./././///./testdir" ); + +my @ateam_path = qw( testdir/lib + testdir/lib/File + testdir/lib/File/Find + testdir/lib/File/Find/Rule + testdir/lib/File/Find/Rule/Test + testdir/lib/File/Find/Rule/Test/ATeam.pm ); + +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find( ), + ], + mindepth => 1, + in => 'testdir' ) ], + [ @tests, 'testdir/foobar', @ateam_path ], + "mindepth == 1" ); + + +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1, + mindepth => 1, + in => 'testdir' ) ], + [ @tests, 'testdir/foobar', 'testdir/lib' ], + "maxdepth = 1 mindepth == 1" ); + +# extras +my $ok = 0; +find( extras => { preprocess => sub { $ok = 1 } }, in => 'testdir' ); +ok( $ok, "extras preprocess fired" ); + +#iterator +$f = find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find(), + ], + start => 'testdir' ); + +{ +my @found; +while ($_ = $f->match) { push @found, $_ } +is_deeply( [ sort @found ], [ 'testdir', @tests, 'testdir/foobar', @ateam_path ], "iterator" ); +} + +# negating in the procedural interface +is_deeply( [ find( file => '!name' => qr/^[^.]{1,8}(\.[^.]{0,3})?$/, + maxdepth => 1, + in => 'testdir' ) ], + [ 'testdir/File-Find-Rule.t' ], + "negating in the procedural interface" ); + +# grep +is_deeply( [ find( maxdepth => 1, file => grep => [ qr/bytes./, [ qr/.?/ ] ], in => 'testdir' ) ], + [ 'testdir/foobar' ], + "grep" ); + + + +# relative +is_deeply( [ find( 'relative', maxdepth => 1, name => 'foobar', in => 'testdir' ) ], + [ 'foobar' ], + 'relative' ); + + + +# bootstrapping extensions via import + +use lib qw(testdir/lib); + +eval { $class->import(':Test::Elusive') }; +like( $@, qr/^couldn't bootstrap File::Find::Rule::Test::Elusive/, + "couldn't find the Elusive extension" ); + +eval { $class->import(':Test::ATeam') }; +is ($@, "", "if you can find them, maybe you can hire the A-Team" ); +can_ok( $class, 'ba' ); diff --git a/t/findrule.t b/t/findrule.t new file mode 100644 index 0000000..090c13c --- /dev/null +++ b/t/findrule.t @@ -0,0 +1,35 @@ +#!perl -w +use strict; +use Test::More tests => 6; + +# extra tests for findrule. these are more for testing the parsing code. + +sub run ($) { + my $expr = shift; + [ sort split /\n/, `$^X -Iblib/lib -Iblib/arch findrule $expr 2>&1` ]; +} + +is_deeply(run 'testdir -file -name foobar', [ 'testdir/foobar' ], + '-file -name foobar'); + +is_deeply(run 'testdir -maxdepth 0 -directory', + [ 'testdir' ], 'last clause has no args'); + + +{ + local $TODO = "Win32 cmd.exe hurts my brane" + if ($^O =~ m/Win32/ || $^O eq 'dos'); + + is_deeply(run 'testdir -file -name \( foobar \*.t \)', + [ qw( testdir/File-Find-Rule.t testdir/findrule.t testdir/foobar ) ], + 'grouping ()'); + + is_deeply(run 'testdir -name \( -foo foobar \)', + [ 'testdir/foobar' ], 'grouping ( -literal )'); +} + +is_deeply(run 'testdir -file -name foobar baz', + [ "unknown option 'baz'" ], 'no implicit grouping'); + +is_deeply(run 'testdir -maxdepth 0 -name -file', + [], 'terminate at next -'); diff --git a/testdir/File-Find-Rule.t b/testdir/File-Find-Rule.t new file mode 100644 index 0000000..7a356d9 --- /dev/null +++ b/testdir/File-Find-Rule.t @@ -0,0 +1,313 @@ +#!perl -w +# $Id$ + +use strict; +use Test::More tests => 43; + +my $class; +my @tests = qw( t/File-Find-Rule.t t/findrule.t ); +BEGIN { + $class = 'File::Find::Rule'; + use_ok($class) +} + +# on win32 systems the t/foobar file isn't 10 bytes it's 11, so the +# previous tests on the magic number 10 failed. rt.cpan.org #3838 +my $foobar_size = -s 't/foobar'; + +my $f = $class->new; +isa_ok($f, $class); + + +# name +$f = $class->name( qr/\.t$/ ); +is_deeply( [ sort $f->in('t') ], + [ @tests ], + "name( qr/\\.t\$/ )" ); + +$f = $class->name( 'foobar' ); +is_deeply( [ $f->in('t') ], + [ 't/foobar' ], + "name( 'foobar' )" ); + +$f = $class->name( '*.t' ); +is_deeply( [ sort $f->in('t') ], + \@tests, + "name( '*.t' )" ); + +$f = $class->name( 'foobar', '*.t' ); +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar' ], + "name( 'foobar', '*.t' )" ); + +$f = $class->name( [ 'foobar', '*.t' ] ); +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar' ], + "name( [ 'foobar', '*.t' ] )" ); + + + +# exec +$f = $class->exec(sub { length == 6 })->maxdepth(1); +is_deeply( [ $f->in('t') ], + [ 't/foobar' ], + "exec (short)" ); + +$f = $class->exec(sub { length > $foobar_size })->maxdepth(1); +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "exec (long)" ); + +is_deeply( [ find( maxdepth => 1, exec => sub { $_[2] eq 't/foobar' }, in => 't' ) ], + [ 't/foobar' ], + "exec (check arg 2)" ); + +# name and exec, chained +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/\.t$/ ); + +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "exec(match) and name(match)" ); + +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/foo/ ) + ->maxdepth(1); + +is_deeply( [ $f->in('t') ], + [ ], + "exec(match) and name(fail)" ); + + +# directory +$f = $class + ->directory + ->maxdepth(1) + ->exec(sub { $_ !~ /(\.svn|CVS)/ }); # ignore .svn/CVS dirs + +is_deeply( [ $f->in('t') ], + [ qw( t t/lib ) ], + "directory autostub" ); + + +# any/or +$f = $class->any( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +is_deeply( [ sort $f->in('t') ], + [ 't/File-Find-Rule.t', 't/foobar' ], + "any" ); + +$f = $class->or( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +is_deeply( [ sort $f->in('t') ], + [ 't/File-Find-Rule.t', 't/foobar' ], + "or" ); + + +# not/none +$f = $class + ->file + ->not( $class->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 10 }); +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "not" ); + +# not as not_* +$f = $class + ->file + ->not_name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 10 }); +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "not_*" ); + +# prune/discard (.svn demo) +# this test may be a little meaningless for a cpan release, but it +# fires perfectly in my dev sandbox +$f = $class->or( $class->directory + ->name(qr/(\.svn|CVS)/) + ->prune + ->discard, + $class->new->file ); + +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar', 't/lib/File/Find/Rule/Test/ATeam.pm' ], + "prune/discard .svn" + ); + + +# procedural form of the CVS demo +$f = find(or => [ find( directory => + name => qr/(\.svn|CVS)/, + prune => + discard => ), + find( file => ) ]); + +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar', 't/lib/File/Find/Rule/Test/ATeam.pm' ], + "procedural prune/discard .svn" + ); + +# size (stat test) +is_deeply( [ find( maxdepth => 1, file => size => $foobar_size, in => 't' ) ], + [ 't/foobar' ], + "size $foobar_size (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<= $foobar_size", + in => 't' ) ], + [ 't/foobar' ], + "size <= $foobar_size (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<".($foobar_size + 1), + in => 't' ) ], + [ 't/foobar' ], + "size <($foobar_size + 1) (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<1K", + exec => sub { length == 6 }, + in => 't' ) ], + [ 't/foobar' ], + "size <1K (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => ">3K", in => 't' ) ], + [ 't/File-Find-Rule.t' ], + "size >3K (stat)" ); + +# these next two should never fail. if they do then the testing fairy +# went mad +is_deeply( [ find( file => size => ">3M", in => 't' ) ], + [ ], + "size >3M (stat)" ); + +is_deeply( [ find( file => size => ">3G", in => 't' ) ], + [ ], + "size >3G (stat)" ); + + +#min/maxdepth + +is_deeply( [ find( maxdepth => 0, in => 't' ) ], + [ 't' ], + "maxdepth == 0" ); + + + +my $rule = find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1 ); + +is_deeply( [ sort $rule->in( 't' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1" ); +is_deeply( [ sort $rule->in( 't/' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, trailing slash on the path" ); + +is_deeply( [ sort $rule->in( './t' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, ./t" ); + +is_deeply( [ sort $rule->in( './/t' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, .//t" ); + +is_deeply( [ sort $rule->in( './//t' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, .///t" ); + +is_deeply( [ sort $rule->in( './././///./t' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, ./././///./t" ); + +my @ateam_path = qw( t/lib + t/lib/File + t/lib/File/Find + t/lib/File/Find/Rule + t/lib/File/Find/Rule/Test + t/lib/File/Find/Rule/Test/ATeam.pm ); + +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find( ), + ], + mindepth => 1, + in => 't' ) ], + [ @tests, 't/foobar', @ateam_path ], + "mindepth == 1" ); + + +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1, + mindepth => 1, + in => 't' ) ], + [ @tests, 't/foobar', 't/lib' ], + "maxdepth = 1 mindepth == 1" ); + +# extras +my $ok = 0; +find( extras => { preprocess => sub { $ok = 1 } }, in => 't' ); +ok( $ok, "extras preprocess fired" ); + +#iterator +$f = find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find(), + ], + start => 't' ); + +{ +my @found; +while ($_ = $f->match) { push @found, $_ } +is_deeply( [ sort @found ], [ 't', @tests, 't/foobar', @ateam_path ], "iterator" ); +} + +# negating in the procedural interface +is_deeply( [ find( file => '!name' => qr/^[^.]{1,8}(\.[^.]{0,3})?$/, + maxdepth => 1, + in => 't' ) ], + [ 't/File-Find-Rule.t' ], + "negating in the procedural interface" ); + +# grep +is_deeply( [ find( maxdepth => 1, file => grep => [ qr/bytes./, [ qr/.?/ ] ], in => 't' ) ], + [ 't/foobar' ], + "grep" ); + + + +# relative +is_deeply( [ find( 'relative', maxdepth => 1, name => 'foobar', in => 't' ) ], + [ 'foobar' ], + 'relative' ); + + + +# bootstrapping extensions via import + +use lib qw(t/lib); + +eval { $class->import(':Test::Elusive') }; +like( $@, qr/^couldn't bootstrap File::Find::Rule::Test::Elusive/, + "couldn't find the Elusive extension" ); + +eval { $class->import(':Test::ATeam') }; +is ($@, "", "if you can find them, maybe you can hire the A-Team" ); +can_ok( $class, 'ba' ); diff --git a/testdir/findrule.t b/testdir/findrule.t new file mode 100644 index 0000000..88b1f76 --- /dev/null +++ b/testdir/findrule.t @@ -0,0 +1,35 @@ +#!perl -w +use strict; +use Test::More tests => 6; + +# extra tests for findrule. these are more for testing the parsing code. + +sub run ($) { + my $expr = shift; + [ sort split /\n/, `$^X -Iblib/lib -Iblib/arch findrule $expr 2>&1` ]; +} + +is_deeply(run 't -file -name foobar', [ 't/foobar' ], + '-file -name foobar'); + +is_deeply(run 't -maxdepth 0 -directory', + [ 't' ], 'last clause has no args'); + + +{ + local $TODO = "Win32 cmd.exe hurts my brane" + if ($^O =~ m/Win32/ || $^O eq 'dos'); + + is_deeply(run 't -file -name \( foobar \*.t \)', + [ qw( t/File-Find-Rule.t t/findrule.t t/foobar ) ], + 'grouping ()'); + + is_deeply(run 't -name \( -foo foobar \)', + [ 't/foobar' ], 'grouping ( -literal )'); +} + +is_deeply(run 't -file -name foobar baz', + [ "unknown option 'baz'" ], 'no implicit grouping'); + +is_deeply(run 't -maxdepth 0 -name -file', + [], 'terminate at next -'); diff --git a/testdir/foobar b/testdir/foobar new file mode 100644 index 0000000..d7ed3b4 --- /dev/null +++ b/testdir/foobar @@ -0,0 +1 @@ +10 bytes. diff --git a/testdir/lib/File/Find/Rule/Test/ATeam.pm b/testdir/lib/File/Find/Rule/Test/ATeam.pm new file mode 100644 index 0000000..87e6630 --- /dev/null +++ b/testdir/lib/File/Find/Rule/Test/ATeam.pm @@ -0,0 +1,11 @@ +package File::Find::Rule::Test::ATeam; +use strict; +use File::Find::Rule; +use base 'File::Find::Rule'; + +sub File::Find::Rule::ba { + my $self = shift()->_force_object; + $self->exec( sub { die "I pity the fool who uses this in production" }); +} + +1; |