1#!/usr/bin/perl
2
3use strict;
4use warnings;
5use Storable qw(freeze thaw);
6use Data::Dumper;
7use File::Spec;
8use File::Path;
9use File::Monitor;
10use Test::More tests => 26;
11
12sub with_open {
13  my ( $name, $mode, $cb ) = @_;
14  if ( $mode =~ />/ ) {
15
16    # Writing so make sure the directory exists
17    my ( $vol, $dir, $leaf ) = File::Spec->splitpath( $name );
18    my $new_dir = File::Spec->catpath( $vol, $dir, '' );
19    mkpath( $new_dir );
20  }
21
22  open( my $fh, $mode, $name )
23   or die "Can't open \"$name\" for $mode ($!)\n";
24  $cb->( $fh );
25  close( $fh );
26}
27
28sub touch_file {
29  my $name = shift;
30  with_open( $name, '>>', sub { } );
31}
32
33sub sort_arrays {
34  my $obj = shift;
35
36  if ( ref $obj eq 'ARRAY' ) {
37    return sort @$obj;
38  }
39  elsif ( ref $obj eq 'HASH' ) {
40    while ( my ( $n, $v ) = each %$obj ) {
41      $obj->{$n} = sort_arrays( $v );
42    }
43  }
44  else {
45    $obj ||= '(undef)';
46    die "Can't sort $obj\n";
47  }
48}
49
50SKIP: {
51  my $tmp_dir = File::Spec->tmpdir;
52
53  skip "Can't find temporary directory", 26
54   unless defined $tmp_dir;
55
56  my $test_base = File::Spec->catdir( $tmp_dir, "fmtest-$$" );
57
58  my $next_suff = 1;
59
60  my $next_dir = sub {
61    return File::Spec->catdir( $test_base,
62      sprintf( "dir%03d", $next_suff++ ) );
63  };
64
65  my $test_dir = $next_dir->();
66
67  my $fix_name = sub {
68    my $name = shift;
69    return File::Spec->catfile( $test_dir, split( /\//, $name ) );
70  };
71
72  my $fix_dir = sub {
73    my $name = shift;
74    return File::Spec->catdir( $test_dir, split( /\//, $name ) );
75  };
76
77  my %change = ();
78
79  my %action = (
80    add_dir => sub {
81      my $dirs = shift;
82      for my $dir ( @$dirs ) {
83        my $name = $fix_dir->( $dir );
84        mkpath( $name );
85      }
86    },
87    add_file => sub {
88      my $files = shift;
89      for my $file ( @$files ) {
90        my $name = $fix_name->( $file );
91        touch_file( $name );
92      }
93    },
94    rm_dir => sub {
95      my $dirs = shift;
96      for my $dir ( @$dirs ) {
97        my $name = $fix_dir->( $dir );
98        rmtree( $name );
99      }
100    },
101    rm_file => sub {
102      my $files = shift;
103      for my $file ( @$files ) {
104        my $name = $fix_name->( $file );
105        unlink $name or die "Can't delete $name ($!)\n";
106      }
107    },
108  );
109
110  my @schedule = (
111    {
112      name    => 'Create directories',
113      add_dir => [qw( a b/c d/e/f )],
114    },
115    {
116      name     => 'Create files',
117      add_file => [qw( a/f1 b/c/f2 d/e/f/f3 )],
118    },
119    {
120      name    => 'Create more directories',
121      add_dir => [qw( g/h i )],
122    },
123    {
124      name    => 'Delete files',
125      rm_file => [qw( b/c/f2 d/e/f/f3)],
126    },
127    {
128      name   => 'Delete directories',
129      rm_dir => [qw( g/h i /b/c d/e/f)],
130    },
131  );
132
133  my $thawed = File::Monitor->new( { base => $test_dir } );
134  $thawed->watch( { name => $test_dir, recurse => 1 } );
135
136  my @changed = $thawed->scan;
137  is_deeply \@changed, [], 'first scan, no changes';
138
139  for my $test ( @schedule ) {
140    %change = ();
141    my $name = delete $test->{name};
142    while ( my ( $act, $arg ) = each %$test ) {
143      my $code = $action{$act} || die "No action $act defined";
144      $code->( $arg );
145      push @{ $change{$act} }, @$arg;
146    }
147
148    # Relocate the test directory
149    my $new_dir = $next_dir->();
150    rename( $test_dir, $new_dir )
151     or die "Can't rename $test_dir to $new_dir ($!)\n";
152
153    my $frozen = eval { freeze $thawed };
154    ok !$@, "$name: freeze OK" or diag "Error from freeze: $@";
155
156    my $thawed = eval { thaw $frozen };
157    ok !$@, "$name: thaw OK" or diag "Error from thaw: $@";
158    isa_ok $thawed, 'File::Monitor';
159
160    $thawed->base( $new_dir );
161    $test_dir = $new_dir;
162
163    is $thawed->base, $test_dir, "$name: monitor relocated";
164
165    my %expect = ();
166
167    # Get the expected changes
168    for
169     my $mode ( [ 'add', 'files_created' ], [ 'rm', 'files_deleted' ] )
170    {
171      my ( $act, $key ) = @$mode;
172      for my $type ( [ 'dir', $fix_dir ], [ 'file', $fix_name ] ) {
173        my ( $typ, $fix ) = @$type;
174        push @{ $expect{$key} },
175         map { $fix->( $_ ) } @{ $change{"${act}_${typ}"} || [] };
176      }
177    }
178
179    # Get the changes
180    my %got     = ();
181    my @changes = $thawed->scan();
182    for my $change ( @changes ) {
183      for my $meth ( qw ( files_created files_deleted ) ) {
184        push @{ $got{$meth} }, $change->$meth;
185      }
186    }
187
188    my $r_got    = sort_arrays( \%got );
189    my $r_expect = sort_arrays( \%expect );
190    unless ( is_deeply $r_got, $r_expect, "$name: changes match" ) {
191      diag( Data::Dumper->Dump( [$r_got],    ['$got'] ) );
192      diag( Data::Dumper->Dump( [$r_expect], ['$expect'] ) );
193    }
194  }
195
196  rmtree( $test_base );
197
198}
199