File Coverage

blib/lib/File/ChangeNotify/Watcher.pm

Criterion	Covered	Total	%
statement	117	121	96.6
branch	43	54	79.6
condition	3	3	100.0
subroutine	24	26	92.3
pod	1	2	50.0
total	188	206	91.2

package File::ChangeNotify::Watcher;

use strict;
use warnings;
use namespace::autoclean;

our $VERSION = '0.31';

use Fcntl qw( S_IMODE );
use File::ChangeNotify::Event;
use File::Find qw( find );
use File::Spec;
use Module::Runtime qw( use_module );
use Types::Standard
    qw( ArrayRef Bool ClassName CodeRef HashRef Num RegexpRef Str );
use Type::Utils -all;

# Trying to import this just blows up on Win32, and checking
# Time::HiRes::d_hires_stat() _also_ blows up on Win32.
BEGIN {
    ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
    eval {
        require Time::HiRes;
        Time::HiRes->import('stat');
    };
}

use Moo::Role;

has filter => (
    is      => 'ro',
    isa     => RegexpRef,
    default => sub {qr/.*/},
);

#<<<
my $dir_t = subtype as Str,
    where { -d $_ },
    message { "$_ is not a valid directory" };

my $array_of_dirs_t = subtype as ArrayRef[Str],
    where {
        map {-d} @{$_};
    },
    message {"@{$_} is not a list of valid directories"};

coerce $array_of_dirs_t,
    from $dir_t,
    via { [$_] };
#>>>

has directories => (
    is       => 'ro',
    writer   => '_set_directories',
    isa      => $array_of_dirs_t,
    required => 1,
    coerce   => 1,
);

has follow_symlinks => (
    is      => 'ro',
    isa     => Bool,
    default => 0,
);

has event_class => (
    is      => 'ro',
    isa     => ClassName,
    default => 'File::ChangeNotify::Event',
);

has sleep_interval => (
    is      => 'ro',
    isa     => Num,
    default => 2,
);

my $files_or_regexps_or_code_t
    = subtype as ArrayRef [ Str | RegexpRef | CodeRef ];

has exclude => (
    is      => 'ro',
    isa     => $files_or_regexps_or_code_t,
    default => sub { [] },
);

has modify_includes_file_attributes => (
    is      => 'ro',
    isa     => Bool | $files_or_regexps_or_code_t,
    default => 0,
);

has modify_includes_content => (
    is      => 'ro',
    isa     => Bool | $files_or_regexps_or_code_t,
    default => 0,
);

has _map => (
    is        => 'ro',
    writer    => '_set_map',
    isa       => HashRef,
    predicate => '_has_map',
);

sub BUILD {
    my $self = shift;

    use_module( $self->event_class );
}

## no critic ( Subroutines::ProhibitUnusedPrivateSubroutines)
sub _current_map {
    my $self = shift;

    my %map;

    find(
        {
            wanted => sub {

                # File::Find seems to use '/' as the path separator on Windows
                # for some odd reason. It really should be using File::Spec
                # internally everywhere but it doesn't.
                my $path
                    = $^O eq 'MSWin32'
                    ? File::Spec->canonpath($File::Find::name)
                    : $File::Find::name;

                if ( $self->_path_is_excluded($path) ) {
                    $File::Find::prune = 1;
                    return;
                }

                my $entry = $self->_entry_for_map($path) or return;
                $map{$path} = $entry;
            },
            follow_fast => ( $self->follow_symlinks ? 1 : 0 ),
            no_chdir    => 1,
            follow_skip => 2,
        },
        @{ $self->directories },
    );

    return \%map;
}
## use critic

sub _path_is_excluded {
    my $self = shift;
    my $path = shift;

    return $self->_path_matches( $self->exclude, $path );
}

sub _entry_for_map {
    my $self = shift;
    my $path = shift;

    my $is_dir = -d $path ? 1 : 0;

    # This should be free since the stat call was already done when checking
    # -d.
    my @stat = stat;

    return if -l $path && !$is_dir;

    unless ($is_dir) {
        my $filter = $self->filter;
        return unless ( File::Spec->splitpath($path) )[2] =~ /$filter/;
    }

    return {
        is_dir => $is_dir,
        size   => ( $is_dir ? 0 : $stat[7] ),
        $self->_maybe_file_attributes( $path, \@stat ),
        ( $is_dir ? () : $self->_maybe_content($path) ),
    };
}

sub _maybe_file_attributes {
    my $self = shift;
    my $path = shift;
    my $stat = shift;

    # The Default watcher always requires the mtime, regardless of whether or
    # not we're including stat info in the modify events.
    unless ( $self->_always_requires_mtime ) {
        return
            unless $self->_path_matches(
            $self->modify_includes_file_attributes,
            $path,
            );
    }

    return ( stat => $self->_stat( $path, $stat ) );
}

sub _stat {
    my $self = shift;
    my $path = shift;
    my $stat = shift;

    my @stat = $stat ? @{$stat} : stat $path;
    return {
        attributes => {
            permissions => S_IMODE( $stat[2] ),
            uid         => $stat[4],
            gid         => $stat[5],
        },
        mtime => $stat[9],
    };
}

sub _always_requires_mtime {0}

sub _maybe_content {
    my $self = shift;
    my $path = shift;

    return
        unless $self->_path_matches( $self->modify_includes_content, $path );

    open my $fh, '<', $path or die "Cannot open $path for reading: $!";
    binmode $fh, ':bytes' or die qq{Cannot binmode $path as ':bytes': $!};
    my $content = do {
        local $/ = undef;
        <$fh>;
    };
    close $fh or die "Cannot close $path: $!";

    return ( content => $content );
}

sub new_events {
    my $self = shift;

    return $self->_interesting_events;
}

## no critic ( Subroutines::ProhibitUnusedPrivateSubroutines)
sub _modify_event_maybe_file_attribute_changes {
    my $self    = shift;
    my $path    = shift;
    my $old_map = shift;
    my $new_map = shift;

    return
        unless $self->_path_matches(
        $self->modify_includes_file_attributes,
        $path,
        );

    my $old_attr = $old_map->{$path}{stat}{attributes};
    my $new_attr = $new_map->{$path}{stat}{attributes};

    for my $k ( keys %{$new_attr} ) {

        # Any possible info retrieved from stat will be numeric, so we can
        # always use numeric comparison safely.
        return ( attributes => [ $old_attr, $new_attr ] )
            if $old_attr->{$k} != $new_attr->{$k};
    }

    return;
}

sub _modify_event_maybe_content_changes {
    my $self    = shift;
    my $path    = shift;
    my $old_map = shift;
    my $new_map = shift;

    return
        unless $self->_path_matches( $self->modify_includes_content, $path );
    return (
        content => [ $old_map->{$path}{content}, $new_map->{$path}{content} ]
    );
}

sub _path_matches {
    my $self    = shift;
    my $matches = shift;
    my $path    = shift;

    return $matches if !ref $matches;

    foreach my $matcher ( @{$matches} ) {
        if ( my $ref = ref $matcher ) {
            if ( $ref eq 'Regexp' ) {
                return 1 if $path =~ /$matcher/;
            }
            elsif ( $ref eq 'CODE' ) {
                local $_ = $path;
                return 1 if $matcher->($path);
            }
        }
        else {
            return 1 if $path eq $matcher;
        }
    }

    return;
}

sub _remove_directory {
    my $self = shift;
    my $dir  = shift;

    $self->_set_directories(
        [ grep { $_ ne $dir } @{ $self->directories } ] );
}
## use critic

1;

# ABSTRACT: Role consumed by all watchers

__END__