File Coverage

lib/CSS/Watcher/Monitor.pm
Criterion Covered Total %
statement 80 80 100.0
branch 14 18 77.7
condition 18 24 75.0
subroutine 19 19 100.0
pod 0 5 0.0
total 131 146 89.7


line stmt bran cond sub pod time code
1             package CSS::Watcher::Monitor;
2              
3 2     2   50930 use strict;
  2         5  
  2         58  
4 2     2   8 use warnings;
  2         5  
  2         62  
5              
6 2     2   11 use Carp;
  2         3  
  2         121  
7 2     2   1291 use Log::Log4perl qw(:easy);
  2         57151  
  2         12  
8 2     2   1256 use File::Spec;
  2         4  
  2         72  
9 2     2   11 use Fcntl ':mode';
  2         4  
  2         708  
10 2     2   1052 use List::MoreUtils qw(any);
  2         12395  
  2         18  
11              
12             our @STAT_FIELDS = qw(
13             dev inode mode num_links uid gid rdev size atime mtime ctime
14             blk_size blocks
15             );
16              
17             sub new {
18 9     9 0 14599 my $class= shift;
19 9         18 my $options = shift;
20              
21             return bless ({
22             dir => $options->{dir} // undef,
23 9   100     92 oldstats => {},
24             }, $class);
25             }
26              
27             sub dir {
28 37     37 0 150 my $self = shift;
29 37 50       82 croak "dir attribute is read-only" if @_;
30 37         295 return $self->{dir};
31             }
32              
33             sub scan {
34 15     15 0 5281 my ($self, $callback, $skip_dirs) = @_;
35              
36 15 100 100     79 return 0 unless (defined $callback && defined $self->dir && -d $self->dir);
      66        
37              
38 12         112 my $newstat = $self->_get_files_info( $self->dir, $skip_dirs );
39              
40 12         22 my $changes = 0;
41 12         14 while ( my( $fname, $stat ) = each %{$newstat->{files}} ) {
  62         1436  
42 50 100       120 unless ($self->_deep_compare ($self->_get_stat ($fname), $stat )) {
43 35         2344 $self->_set_stat ($fname, $stat);
44 35         85 $callback->($fname);
45 35         6388 $changes++;
46             }
47             }
48 12         68 return $changes;
49             }
50              
51             sub is_changed {
52 7     7 0 2001318 my ( $self, $filename ) = @_;
53 7         11 my %objstat;
54 7         74 @objstat{@STAT_FIELDS} = stat ( $filename );
55              
56             # this file may never present before and not exist, return false
57 7 100 66     196 return 0 unless (defined ($objstat{atime}) && -f $filename);
58              
59 6         80 not $self->_deep_compare (
60             $self->_get_stat ($filename),
61             \%objstat);
62             }
63              
64             sub make_dirty {
65 5     5 0 1631 my $self = shift;
66 5         13 $self->{oldstats} = {};
67             }
68              
69             sub _get_stat {
70 56     56   95 my ( $self, $filename ) = @_;
71 56   100     286 return $self->{oldstats}{$filename} // {};
72             }
73              
74             sub _set_stat {
75 35     35   59 my ( $self, $filename, $stat ) = @_;
76 35         84 $self->{oldstats}{$filename} = $stat;
77             }
78              
79             sub _deep_compare {
80 56     56   137 my ( $self, $this, $that ) = @_;
81 2     2   4144 use Storable qw/freeze/;
  2         7121  
  2         1008  
82 56         85 local $Storable::canonical = 1;
83 56         170 return freeze( $this ) eq freeze( $that );
84             }
85              
86             # Scan our target object
87             sub _get_files_info {
88 12     12   26 my ( $self, $dir, $skip_dirs ) = @_;
89 12         16 my %info;
90              
91 12   100     43 $skip_dirs ||= [];
92            
93 12         16 eval {
94 12 50       102 if ( -d $dir ) {
95              
96             # Expand whole directory tree
97 12         98 my @work = $self->_read_dir( $dir );
98 12         43 while ( my $obj = shift @work ) {
99             next # // skip symlinks that have "../" (circular symlink)
100 64 50 66     1058 if ( -d $obj
      33        
101             && -l $obj
102             && readlink($obj) =~ m|\.\./| );
103 64 100 66     941 if (-f $obj) {
    100          
104 50         55 my %objstat;
105 50         903 @objstat{@STAT_FIELDS} = stat ( $obj );
106 50         269 $info{ files }{ $obj } = \%objstat;
107             }
108 4     4   74 elsif ( -d $obj && ( !any { $obj =~ m/$_/; } @{$skip_dirs} ) ) {
  14         111  
109             # Depth first to simulate recursion
110 12         33 unshift @work, $self->_read_dir( $obj );
111             }
112             }
113             }
114             };
115              
116 12         33 $info{error} = $@;
117              
118 12         32 return \%info;
119             }
120              
121             sub _read_dir {
122 24     24   39 my $self = shift;
123 24         63 my $dir = shift;
124              
125 24 50       454 opendir( my $dh, $dir ) or LOGDIE "Can't read $dir ($!)";
126 64         642 my @files = map { File::Spec->catfile( $dir, $_ ) }
127             sort
128 24         515 grep { $_ !~ /^[.]{1,2}$/ } readdir( $dh );
  112         397  
129 24         256 closedir( $dh );
130              
131 24         179 return @files;
132             }
133              
134              
135             1;
136              
137             =head1 NAME
138              
139             CSS::Watcher::Monitor - Monitor files for changes.
140              
141             =head1 SYNOPSIS
142              
143             use CSS::Watcher::Monitor;
144             my $cm = CSS::Watcher::Monitor->new (dir => '/foo/bar');
145              
146             # return num of files modified
147             $cm->scan(
148             sub {
149             my $file = shift;
150             # process changed file or first scan new file
151             } );
152              
153             # Check does file changed since last $cm->scan
154             say $cm->is_changed('/foo/bar/baz.txt');
155              
156             # clean old file stat cache
157             $cm->make_dirty();
158              
159             =head1 DESCRIPTION
160              
161             Watch for changes, call callback sub. Call callback on first scan too.
162              
163             =head1 SEE ALSO
164              
165             File::Monitor - I get some patterns from there
166              
167             =head1 AUTHOR
168              
169             Olexandr Sydorchuk (olexandr.syd@gmail.com)
170              
171             =head1 COPYRIGHT AND LICENSE
172              
173             Copyright (C) 2014 by Olexandr Sydorchuk
174              
175             This program is free software; you can redistribute it and/or modify
176             it under the same terms as Perl itself, either Perl version 5.8.2 or,
177             at your option, any later version of Perl 5 you may have available.
178              
179             =cut