File Coverage

blib/lib/File/Rules.pm

Criterion	Covered	Total	%
statement	100	121	82.6
branch	41	92	44.5
condition	11	22	50.0
subroutine	15	16	93.7
pod	6	6	100.0
total	173	257	67.3

package File::Rules;

use warnings;
use strict;
use Carp;
use File::Spec;
use Data::Dump qw( dump );
use Path::Class;

our $VERSION = '0.02';

sub new {
    my $class = shift;
    my $rules = ref( $_[0] ) ? shift : [@_];
    my $self  = bless { _rules => [] }, $class;
    $self->add($_) for @$rules;
    return $self;
}

my $debug = $ENV{PERL_DEBUG} || 0;

my $FileRuleRegEx
    = qr/^(filename|pathname|dirname|directory)\ +(contains|is|regex)\ +(.+)/io;

sub add {
    my $self = shift;
    my $str = shift or croak "rule string required";

    # parse
    my ( $type, $action, $re ) = ( $str =~ m/$FileRuleRegEx/ );
    if ( !$type or !$action or !$re ) {
        croak "Bad syntax in FileRule: $str";
    }
    if ( $action eq 'regex' or $type eq 'directory' ) {
        eval "\$re = qr$re";    # TODO dangerous?
    }

    # unclear from swish-e docs whether this is true or not,
    # but we are conservative.
    if ( $type eq 'directory' and $action ne 'contains' ) {
        croak "Rule for 'directory' may only have 'contains' action.";
    }

    my $rule = {
        type   => $type,
        action => $action,
        re     => $re,
    };

    push @{ $self->{_rules} }, $rule;

    return $rule;
}

sub rules {
    my $self = shift;
    if (@_) {
        $self->{_rules} = ref( $_[0] ) ? shift : [@_];
    }
    return $self->{_rules};
}

sub match {
    my $self = shift;
    my $file = shift or croak "file required";
    if ( -d $file ) {
        return $self->match_dir( $file, { strict => 1 } );
    }
    else {
        return $self->match_file( $file, { strict => 1 } );
    }
}

sub match_dir {
    my $self = shift;
    my $dir  = shift or croak "dir required";
    my $opts = shift || {};

    if ( $opts->{strict} and !-d $dir ) {
        return 0;
    }

    my $rules = $self->{_rules};

    $debug and warn "match_dir $dir: " . dump($rules) . "\n";

    for my $rule (@$rules) {
        next if $rule->{type} eq 'filename';
        my $method = '_apply_' . $rule->{type} . '_rule';
        return 1 if $self->$method( $dir, $rule, 1 );
    }

    return 0;
}

sub match_file {
    my $self = shift;
    my $file = shift or croak "file required";
    my $opts = shift || {};

    if ( $opts->{strict} and -d $file ) {
        return 0;
    }

    my $rules = $self->{_rules};

    $debug and warn "match_file $file: " . dump($rules) . "\n";

    for my $rule (@$rules) {
        my $method = '_apply_' . $rule->{type} . '_rule';
        return 1 if $self->$method( $file, $rule );
    }

    return 0;
}

sub _apply_filename_rule {
    my ( $self, $file, $rule ) = @_;
    my $match = 0;
    my ( $volume, $dirname, $filename ) = File::Spec->splitpath($file);

    $debug and warn dump($rule) . "\n";
    $debug and warn "dirname=$dirname   filename=$filename\n";

    if ( $rule->{action} eq 'is' ) {
        $match = $rule->{re} eq $filename ? 1 : 0;
    }
    elsif ( $rule->{action} eq 'contains' ) {
        if ( $filename =~ m{$rule->{re}} ) {
            $match = 1;
        }
    }
    elsif ( $rule->{action} eq 'regex' ) {
        my $regex = $rule->{re};
        if ( $filename =~ m{$regex} ) {
            $match = 1;
        }
    }

    $debug
        and warn "_apply_filename_rule for $file returns $match : "
        . dump($rule) . "\n";

    return $match;
}

sub _apply_dirname_rule {
    my ( $self, $file, $rule, $is_dir ) = @_;
    my $match = 0;
    my ( $volume, $dirname, $filename ) = File::Spec->splitpath($file);

    $debug and warn dump($rule) . "\n";
    $debug and warn "dirname=$dirname   filename=$filename\n";

    if ( $rule->{action} eq 'is' ) {
        $match = grep { $rule->{re} eq $_ }
            File::Spec->splitdir( $is_dir ? $file : $dirname );
    }
    elsif ( $rule->{action} eq 'contains' ) {
        if ( $dirname =~ m{$rule->{re}} ) {
            $match = 1;
        }
    }
    elsif ( $rule->{action} eq 'regex' ) {
        my $regex = $rule->{re};
        if ( $dirname =~ m{$regex} ) {
            $match = 1;
        }
    }

    $debug
        and warn "_apply_dirname_rule for $file returns $match : "
        . dump($rule) . "\n";

    return $match;
}

sub _apply_pathname_rule {
    my ( $self, $file, $rule ) = @_;
    my $match = 0;

    my ( $volume, $dirname, $filename ) = File::Spec->splitpath($file);

    $debug and warn dump($rule) . "\n";
    $debug and warn "dirname=$dirname   filename=$filename\n";

    if ( $rule->{action} eq 'is' ) {
        $match = $rule->{re} eq $file;
    }
    elsif ( $rule->{action} eq 'contains' ) {
        if ( $file =~ m{$rule->{re}} ) {
            $match = 1;
        }
    }
    elsif ( $rule->{action} eq 'regex' ) {
        my $regex = $rule->{re};
        if ( $file =~ m{$regex} ) {
            $match = 1;
        }
    }

    $debug
        and warn "_apply_pathname_rule for $file returns $match : "
        . dump($rule) . "\n";

    return $match;
}

sub _apply_directory_rule {
    my ( $self, $dir, $rule ) = @_;
    my $match = 0;
    my $re    = $rule->{re};
    $dir = Path::Class::Dir->new($dir);
    while ( my $file = $dir->next ) {
        if ( $file =~ m/$re/ ) {
            $match = $file;
            last;
        }
    }

    $debug
        and warn "_apply_directory_rule for $dir returns $match : "
        . dump($rule) . "\n";

    return $match;
}

1;

__END__