view release on metacpan or  search on metacpan

lib/Path/Iterator/Rule.pm  view on Meta::CPAN

use 5.008001;
use strict;
use warnings;

package Path::Iterator::Rule;
# ABSTRACT: Iterative, recursive file finder
our $VERSION = '1.015';

# Register warnings category
use warnings::register;

use if $] ge '5.010000', 're', 'regexp_pattern';

# Dependencies
use Carp           ();
use File::Basename ();
use File::Spec     ();
use List::Util     ();
use Number::Compare 0.02;
use Scalar::Util ();
use Text::Glob   ();
use Try::Tiny;

#--------------------------------------------------------------------------#
# constructors and meta methods
#--------------------------------------------------------------------------#

sub new {
    my $class = shift;
    $class = ref $class if ref $class;
    return bless { rules => [] }, $class;
}

sub clone {
    my $self = shift;
    return bless _my_clone( {%$self} ), ref $self;
}

# avoid XS/buggy dependencies for a simple recursive clone; we clone
# fully instead of just 'rules' in case we get subclassed and they
# add attributes
sub _my_clone {
    my $d = shift;
    if ( ref $d eq 'HASH' ) {
        return {
            map { ; my $v = $d->{$_}; $_ => ( ref($v) ? _my_clone($v) : $v ) }
              keys %$d
        };
    }
    elsif ( ref $d eq 'ARRAY' ) {
        return [ map { ref($_) ? _my_clone($_) : $_ } @$d ];
    }
    else {
        return $d;
    }
}

sub add_helper {
    my ( $class, $name, $coderef, $skip_negation ) = @_;
    $class = ref $class if ref $class;
    if ( !$class->can($name) ) {
        no strict 'refs'; ## no critic
        *$name = sub {
            my $self = shift;
            my $rule = $coderef->(@_);
            $self->and($rule);
        };
        if ( !$skip_negation ) {
            *{"not_$name"} = sub {
                my $self = shift;
                my $rule = $coderef->(@_);
                $self->not($rule);

lib/Path/Iterator/Rule.pm  view on Meta::CPAN

        return ( $prune ? \0 : 0 ) if !$result;
    }
    return ( $prune ? \1 : 1 ); # all constraints met, but propagate prune state
}

#--------------------------------------------------------------------------#
# private methods
#--------------------------------------------------------------------------#

sub _rulify {
    my ( $self, @args ) = @_;
    my @rules;
    for my $arg (@args) {
        my $rule;
        if ( Scalar::Util::blessed($arg) && $arg->isa("Path::Iterator::Rule") ) {
            $rule = sub { $arg->test(@_) };
        }
        elsif ( ref($arg) eq 'CODE' ) {
            $rule = $arg;
        }
        else {
            Carp::croak("Rules must be coderef or Path::Iterator::Rule");
        }
        push @rules, $rule;
    }
    return @rules;
}

sub _is_unique {
    my ( $self, $string_item, $stash ) = @_;
    my $unique_id;
    my @st = eval { stat $string_item };
    @st = eval { lstat $string_item } unless @st;
    if (@st) {
        $unique_id = join( ",", $st[0], $st[1] );
    }
    else {
        my $type = -d $string_item ? 'directory' : 'file';
        warnings::warnif("Could not stat $type '$string_item'");
        $unique_id = $string_item;
    }
    return !$stash->{_seen}{$unique_id}++;
}

#--------------------------------------------------------------------------#
# built-in helpers
#--------------------------------------------------------------------------#

sub _regexify {
    my ( $re, $add ) = @_;
    $add ||= '';
    my $new = ref($re) eq 'Regexp' ? $re : Text::Glob::glob_to_regex($re);
    return $new unless $add;
    my ( $pattern, $flags ) = _split_re($new);
    my $new_flags = $add ? _reflag( $flags, $add ) : "";
    return qr/$new_flags$pattern/;
}

sub _split_re {
    my $value = shift;
    if ( $] ge 5.010 ) {
        return re::regexp_pattern($value);
    }
    else {
        $value =~ s/^\(\?\^?//;
        $value =~ s/\)$//;
        my ( $opt, $re ) = split( /:/, $value, 2 );
        $opt =~ s/\-\w+$//;
        return ( $re, $opt );
    }
}

sub _reflag {
    my ( $orig, $add ) = @_;
    $orig ||= "";

    if ( $] >= 5.014 ) {
        return "(?^$orig$add)";
    }
    else {
        my ( $pos, $neg ) = split /-/, $orig;
        $pos ||= "";
        $neg ||= "";
        $neg =~ s/i//;
        $neg = "-$neg" if length $neg;
        return "(?$add$pos$neg)";
    }
}

# "simple" helpers take no arguments
my %simple_helpers = (
    directory => sub { -d $_ },           # see also -d => dir below
    dangling => sub { -l $_ && !stat $_ },
);

while ( my ( $k, $v ) = each %simple_helpers ) {
    __PACKAGE__->add_helper( $k, sub { return $v } );
}

sub _generate_name_matcher {
    my (@patterns) = @_;
    if ( @patterns > 1 ) {
        return sub {
            my $name = "$_[1]";
            return ( List::Util::first { $name =~ $_ } @patterns ) ? 1 : 0;
          }
    }
    else {
        my $pattern = $patterns[0];
        return sub {
            my $name = "$_[1]";
            return $name =~ $pattern ? 1 : 0;
          }
    }
}

# "complex" helpers take arguments
my %complex_helpers = (
    name => sub {
        Carp::croak("No patterns provided to 'name'") unless @_;
        _generate_name_matcher( map { _regexify($_) } @_ );