File Coverage

lib/Badger/Filesystem/Visitor.pm

Criterion	Covered	Total	%
statement	89	96	92.7
branch	50	72	69.4
condition	16	27	59.2
subroutine	18	20	90.0
pod	10	18	55.5
total	183	233	78.5

#========================================================================
#
# Badger::Filesystem::Visitor
#
# DESCRIPTION
#   Base class visitor object for traversing a filesystem.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Filesystem::Visitor;

use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Base',
    import    => 'class',
    utils     => 'params',
    constants => 'ARRAY CODE REGEX ON WILDCARD',
    config    => [
        'files|accept|class:FILES',
        'no_files|ignore|class:NO_FILES',
        'dirs|directories|class:DIRS',
        'no_dirs|no_directories|class:NO_DIRS',
        'in_dirs|in_directories|enter|class:IN_DIRS',
        'not_in_dirs|not_in_directories|leave|class:NOT_IN_DIRS',
        'accept_file',
        'reject_file',
        'accept_dir|accept_directory',
        'reject_dir|reject_directory',
        'enter_dir|enter_directory',
        'leave_dir|leave_directory',
    ],
    messages  => {
        no_node    => 'No node specified to %s',
        bad_filter => 'Invalid test in %s specification: %s',
    },
    alias     => {
        init            => \&init_visitor,
        collect_dir     => \&collect_dir,
        enter_dir       => \&enter_directory,
        visit_dir       => \&visit_directory,
        visit_dir_kids  => \&visit_directory_children,
    };

use Badger::Debug ':dump';
our @FILTERS     = qw( files dirs in_dirs no_files no_dirs not_in_dirs );
our $ALL         = 0;
our $FILES       = 1;
our $DIRS        = 1;
our $IN_DIRS     = 0;
our $NO_FILES    = 0;
our $NO_DIRS     = 0;
our $NOT_IN_DIRS = 0;


sub init_visitor {
    my ($self, $config) = @_;
    my $class = $self->class;
    my ($item, $long);

    $self->configure($config);

    $self->{ in_dirs } = 1
        if $config->{ recurse };

    $self->{ collect  } = [ ];
    $self->{ identify } = { };

    $self->init_filters;

    $self->debug("init_visitor() => ", $self->dump) if DEBUG;

    return $self;
}


sub init_filters {
    my $self = shift;
    my ($filter, $tests, $test, $type);

    foreach $filter (@FILTERS) {
        $tests = $self->{ $filter } || next;        # skip over false values
        $self->debug("filter: $filter => $tests\n") if DEBUG;
        $tests = $self->{ $filter } = [$tests]
            unless ref $tests eq ARRAY;

        # NOTE: $test is aliasing list item so we can change it
        foreach $test (@$tests) {
            $self->debug("  - test: $test\n") if $DEBUG;
            last unless $test;                      # false test always fails

            if ($type = ref $test) {
                return $self->error_msg( bad_filter => $filter => $test )
                    unless $type eq CODE or $type eq REGEX;
                # OK
            }
            elsif ($test eq ON) {
                # OK
            }
            elsif ($test =~ WILDCARD) {
                # changing test affects list item via regex
                $test =~ s/\./<>/g;     # . => <>     (tmp)
                $test =~ s/\?/./g;           # ? => .
                $test =~ s/\*/.*/g;          # * => .*
                $test =~ s/<>/\\./g;    # <> => \.
                $test = qr/^$test$/;
                $self->debug("transmogrified wildcard into regex: $test\n") if $DEBUG;
            }
        }

        $self->debug(
            "initialised $filter tests: ",
            $self->dump_data_inline($tests),
            "\n"
        ) if $DEBUG;
    }
}


sub visit {
    my $self = shift;
    my $node = shift || return $self->error_msg( no_node => 'visit' );
    $node->enter($self);
}


sub visit_path {
    my ($self, $path) = @_;
    # TODO: we have nothing going on here
    $self->debug("visiting path: $path\n") if $DEBUG;
}


sub visit_file {
    my ($self, $file) = @_;

    return $self->filter_file($file)
         ? $self->accept_file($file)
         : $self->reject_file($file);
}


sub visit_directory {
    my ($self, $dir) = @_;
    $self->debug("visiting directory: $dir\n") if $DEBUG;

    $self->filter_directory($dir)
         ? $self->accept_directory($dir) || return
         : $self->reject_directory($dir) || return;

    return $self->filter_entry($dir)
         ? $self->enter_directory($dir)
         : $self->leave_directory($dir);
}


sub filter {
    my ($self, $filter, $method, $item) = @_;
    my $tests = $self->{ $filter } || do {
        $self->debug("No filter defined for $filter") if DEBUG;
        return 0;
    };
    my ($test, $type);

    $self->debug("filter($filter, $method, $item)  tests: $tests\n") if $DEBUG;

    foreach $test (@$tests) {
        $self->debug("  - test: $test\n") if $DEBUG;
        if ($test eq ON) {
            return 1;
        }
        elsif ($type = ref $test) {
            if ($type eq CODE) {
#                $self->debug("calling code: ". $test->($item, $self));
                return 1 if $test->($item, $self);
            }
            elsif ($type eq REGEX) {
                return 1 if $item->$method =~ $test;
            }
            else {
                return $self->error_msg( bad_filter => $filter => $test );
            }
        }
        else {
            return 1 if $item->$method eq $test;
        }
    }
    $self->debug("  - ALL FAIL - ignore\n") if $DEBUG;
    return 0;
}


sub filter_file {
    my ($self, $file) = @_;
    return $self->filter( files    => name => $file )
      && ! $self->filter( no_files => name => $file );
}


sub filter_directory {
    my ($self, $dir) = @_;
    return $self->filter( dirs    => name => $dir )
      && ! $self->filter( no_dirs => name => $dir );
}


sub filter_entry {
    my ($self, $dir) = @_;
    return $self->filter( in_dirs     => name => $dir )
      && ! $self->filter( not_in_dirs => name => $dir );
}


sub accept_file {
    my ($self, $file) = @_;
    $self->debug("accept_file($file)") if DEBUG;
    $self->{ accept_file }->($self, $file)
        if $self->{ accept_file };
    return $self->collect($file);

#    return $self->filter( files    => name => @_ )
#      && ! $self->filter( no_files => name => @_ );
}


sub reject_file {
    my ($self, $file) = @_;
    $self->debug("reject_file($file)") if DEBUG;
    return $self->{ reject_file }
         ? $self->{ reject_file }->($self, $file)
         : 1;
}


sub accept_directory {
    my ($self, $dir) = @_;
    $self->debug("accept_dir($dir)") if DEBUG;
    $self->{ accept_dir }->($self, $dir) || return
        if $self->{ accept_dir };
    return $self->collect($dir);
}


sub reject_directory {
    my ($self, $dir) = @_;
    $self->debug("reject_directory($dir)") if DEBUG;
    return $self->{ reject_dir }
         ? $self->{ reject_dir }->($self, $dir)
         : 1;
}

sub enter_directory {
    my ($self, $dir) = @_;
    $self->debug("visiting directory children: $dir") if $DEBUG;
    $self->{ enter_dir }->($self, $dir) || return
        if $self->{ enter_dir };

    $_->accept($self)
        for $dir->children;
#        for $dir->children($self->{ all });
    return 1;
}


sub leave_directory {
    my ($self, $dir) = @_;
    $self->debug("leave_directory($dir)") if DEBUG;
    return $self->{ leave_dir }
         ? $self->{ leave_dir }->($self, $dir)
         : 1;
}


sub collect {
    my $self    = shift;
    my $collect = $self->{ collect };
    push(@$collect, @_) if @_;
    return wantarray
        ? @$collect
        :  $collect;
}


# identify() is not currently used

sub identify {
    my ($self, $params) = self_params(@_);
    my $identify = $self->{ identify };
    @$identify{ keys %$params } = values %$params
        if %$params;
    return wantarray
        ? %$identify
        :  $identify;
}


1;

__END__