File Coverage

lib/Test/DataDirs.pm
Criterion Covered Total %
statement 75 105 71.4
branch 16 42 38.1
condition 2 5 40.0
subroutine 13 15 86.6
pod 1 6 16.6
total 107 173 61.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Test::DataDirs - manage t/data and t/temp directories for your tests
4              
5             =head1 VERSION
6              
7             version 0.1.2
8              
9             =head1 SYNOPSIS
10              
11             This class is a convenience which provides data directories from which
12             to source information for your tests, and temp directories you can
13             write data.
14              
15             Declare some temp and data directories you need in your test script as
16             below. These are implicitly relative to C<< t/temp/ >>
17             and C<< t/data/ >>. Then you may refer to them
18             using the appropriate entry in the returned hash and assume the dirs
19             exist and that the temp dirs have been (re-)created.
20              
21             # File: t/test-01.t
22             use Test::DataDirs;
23              
24             my %D = Test::DataDirs->new(
25             temp => [temp_stuff => 'actual-dir',
26             more_temp => 'another-dir'],
27             data => [data_stuff => 'actual-dir'],
28             )->hash;
29              
30             print "My test data is checked into $D{data_stuff}\n"
31             print "below $D{data_dir}\n"
32             # Prints (except with absolute paths):
33             # My test data is checked into t/data/test-01/actual-dir
34             # below t/data/test-01
35              
36             print "I can write temp data into $D{temp_stuff}\n"
37             print "and $D{more_temp}, "below $D{temp_dir}\n"
38             # Prints (except with absolute paths):
39             # I can write temp data into t/temp/test-01/actual-dir
40             # and t/temp/test-01/another-dir below t/data/test-01
41              
42              
43             This module defines an OO interface. See also
44             L for a module with similar usage but which
45             imports vars into your namespace.
46              
47             =head1 DESCRIPTION
48              
49             =cut
50              
51             package Test::DataDirs;
52 4     4   22110 use strict;
  4         7  
  4         125  
53 4     4   17 use warnings;
  4         6  
  4         110  
54 4     4   17 use FindBin qw($Bin $Script);
  4         5  
  4         423  
55 4     4   21 use File::Spec;
  4         6  
  4         114  
56 4     4   17 use File::Glob qw(bsd_glob);
  4         13  
  4         361  
57 4     4   20 use File::Path qw(mkpath rmtree);
  4         5  
  4         234  
58 4     4   23 use Carp qw(croak);
  4         5  
  4         4034  
59              
60             our $VERSION = '0.1.2'; # VERSION
61              
62             =head2 C<< $obj = $class->new(%params) >>
63              
64             Given parameters including:
65              
66             base => $base_dir,
67              
68             data => [ddir1 => relpath3, ddir2 => relpath4 ...]
69              
70             temp => [tdir1 => relpath1, tdir2 => relpath2 ...]
71              
72             Uses C as a base dir in which to find data dirs C (which
73             are checked to exist), and in which to re-create fresh test dirs
74             C.
75              
76             If C is not given, uses the name of the invoking script, with
77             any leading digits or periods stripped, and any trailing ".t"
78             stripped.
79              
80             Retuns a hash-based object which keys the names C and C
81             to the appropriate paths constructed from C<$base_dir> and the
82             appropriate C.
83              
84             =cut
85              
86             sub new {
87 9     9 1 21 my $class = shift;
88 9         21 my %param = @_;
89 9         11 my $base = $param{base};
90 9 100       73 ($base) = $Script =~ /^([\d.]*.*?)(\.t)?$/
91             unless defined $base;
92              
93 9   50     992 my $self = bless {
94             data_dir => File::Spec->catdir($Bin,'data', $base),
95             temp_dir => File::Spec->catdir($Bin,'temp', $base),
96             dirs => {},
97             data_dirs => [],
98             temp_dirs => [],
99             copy => $param{copy} || [],
100             }, $class;
101              
102             # expand the data directories
103 9 100       18 my @data = (data_dir => '', @{ $param{data} || [] });
  9         42  
104 9         25 for(my $ix = 0; $ix < @data; $ix += 2) {
105 19         48 my ($name, $dir) = @data[$ix, $ix+1];
106 19 50       51 die "Can't use dir name '$name': already in use as '$self->{$name}'"
107             if exists $self->{dirs}{$name};
108            
109 19         76 $dir = File::Spec->catdir($self->{data_dir}, $dir);
110 19         32 $self->{dirs}{$name} = $dir;
111 19         15 push @{ $self->{data_dirs} }, $name, $dir;
  19         53  
112             }
113              
114             # ditto the temp directories
115 9 100       9 my @temp = (temp_dir => '', @{ $param{temp} || [] });
  9         34  
116 9         23 for(my $ix = 0; $ix < @temp; $ix += 2) {
117 19         23 my ($name, $dir) = @temp[$ix, $ix+1];
118 19 50       34 croak "Can't use dir name '$name': already in use as '$self->{$name}'"
119             if exists $self->{dirs}{$name};
120            
121 19         57 $dir = File::Spec->catdir($self->{temp_dir}, $dir);
122 19         28 $self->{dirs}{$name} = $dir;
123 19         15 push @{ $self->{temp_dirs} }, $name, $dir;
  19         45  
124             }
125              
126             # check the copies attribute
127 9         12 my $copy = $self->{copy};
128 9 50 33     47 croak "copy param must be an arrayref with an even number of members"
129             unless ref $copy eq 'ARRAY'
130             && !(@$copy % 2);
131              
132 9         22 $self->initialise();
133              
134 4         25 return $self;
135             }
136              
137              
138             sub initialise {
139 9     9 0 9 my $self = shift;
140              
141 9         2468 rmtree $self->{temp_dir};
142              
143             # validate the data directories exist
144 9         18 my $data = $self->{data_dirs};
145 9         51 for(my $ix = 0; $ix < @$data; $ix += 2) {
146 15         30 my ($name, $dir) = @$data[$ix, $ix+1];
147 15 100       272 croak "No such data directory '$dir'"
148             unless -d $dir;
149             }
150              
151             # recreate the temp directories
152 4         7 my $temp = $self->{temp_dirs};
153 4         10 for(my $ix = 0; $ix < @$temp; $ix += 2) {
154 8         15 my ($name, $dir) = @$temp[$ix, $ix+1];
155            
156 8 50       104 rmtree $dir if -e $dir;
157 8 50       58 croak "Can't delete '$dir'"
158             if -e $dir;
159 8         6815 mkpath $dir;
160 8 50       132 croak "Can't create '$dir'"
161             unless -d $dir;
162             }
163              
164             # perform any copies
165 4         11 my $copy = $self->{copy};
166 4         14 for(my $ix = 0; $ix < @$copy; $ix += 2) {
167 0         0 my ($from, $to) = @$copy[$ix, $ix+1];
168 0         0 $self->copy($from, $to);
169             }
170             }
171              
172             sub dirs {
173 4 50   4 0 12 croak "->dirs accepts no arguments"
174             if @_ > 1;
175 4         18 return shift->{dirs};
176             }
177              
178             sub dir {
179 0     0 0 0 my ($self, $alias) = @_;
180 0 0       0 croak "you must supply a directory alias"
181             unless defined $alias;
182 0 0       0 my $dir = $self->{dirs}{$alias}
183             or croak "No directory defined for alias '$alias'";
184              
185 0         0 return $dir;
186             }
187              
188             sub hash {
189 1     1 0 937 my $arg = shift;
190 1 50       6 my $self = ref $arg?
191             $arg :
192             $arg->new(@_);
193              
194 1         2 return %{ $self->dirs };
  1         609  
195             }
196              
197              
198             sub copy {
199 0     0 0   my $self = shift;
200 0           my $to = pop;
201              
202             # expand/validate the from aliases
203 0           my @from_paths = map {
204 0           my ($dir, $pat) = m{^ (.*?) (?: /(.*) )? $}x;
205 0           [$self->dir($dir), $pat];
206             } @_;
207              
208             # validate the to aliases
209 0           my $to_dir = $self->dir($to);
210              
211 0           require File::Copy;
212 0           require File::Glob;
213              
214 0           my $count = 0;
215 0           foreach my $item (@from_paths) {
216 0           my ($from_dir, $pat) = @$item;
217              
218 0 0         $pat = "*"
219             unless defined $pat;
220              
221 0           $pat = File::Spec->catdir($from_dir, $pat);
222              
223             # We use bsd_glob because unlike glob, it doesn't (why oh
224             # why?) use spaces as pattern delimiters
225 0           foreach my $src (File::Glob::bsd_glob $pat) {
226 0           my $path = File::Spec->abs2rel($src, $from_dir);
227 0           my $dst = File::Spec->catdir($to_dir, $path);
228              
229 0 0         if (-f $src) { # Copy files
    0          
    0          
    0          
230 0 0         File::Copy::copy($src, $dst)
231             or croak "failed to copy '$src' to '$dst': $!";
232             }
233             elsif (-d $src) { # Create directories
234 0           mkpath $dst;
235             }
236             elsif (-l $src) { # Duplicate links
237 0 0         symlink readlink($src), $dst
238             or croak "failed to copy link '$src' as '$dst': $!";
239             }
240             elsif (!-e $src) { # the src doesn't exist
241 0           croak "cannot copy $src: no such file";
242             }
243             else { # We don't know how to do the right thing
244 0           croak "cannot copy $src: unsupported file type";
245             }
246             }
247 0           $count++;
248             }
249              
250 0           return $count;
251             }
252              
253 4     4   21 no Carp;
  4         4  
  4         80  
254 4     4   13 no File::Path;
  4         4  
  4         86  
255             1;