File Coverage

blib/lib/Shipwright/Backend/FS.pm
Criterion Covered Total %
statement 68 123 55.2
branch 15 54 27.7
condition 6 10 60.0
subroutine 16 27 59.2
pod 4 4 100.0
total 109 218 50.0


line stmt bran cond sub pod time code
1             package Shipwright::Backend::FS;
2              
3 3     3   939 use warnings;
  3         5  
  3         87  
4 3     3   13 use strict;
  3         6  
  3         61  
5 3     3   12 use File::Spec::Functions qw/catfile splitdir catdir rel2abs/;
  3         10  
  3         145  
6 3     3   16 use Shipwright::Util;
  3         4  
  3         243  
7 3     3   609 use File::Copy::Recursive qw/rcopy rmove/;
  3         8445  
  3         152  
8 3     3   17 use File::Path qw/remove_tree make_path/;
  3         5  
  3         163  
9              
10             our %REQUIRE_OPTIONS = ( import => [qw/source/] );
11              
12 3     3   16 use base qw/Shipwright::Backend::Base/;
  3         6  
  3         1830  
13              
14             =head1 NAME
15              
16             Shipwright::Backend::FS - File System backend
17              
18             =head1 SYNOPSIS
19              
20             shipwright create -r fs:/home/me/shipwright/my_project
21              
22             =head1 DESCRIPTION
23              
24             This module implements file system based backend with version control
25             for Shipwright L.
26              
27             =head1 METHODS
28              
29             =cut
30              
31             =over 4
32              
33             =item build
34              
35             =cut
36              
37             sub build {
38 6     6 1 9 my $self = shift;
39 6         19 $self->strip_repository;
40              
41 6         11 my $repo = $self->repository;
42 6         11 $repo =~ s/^~/user_home/e;
  0         0  
43 6         17 my $abs_path = rel2abs($repo);
44 6 50       75 $repo = $abs_path if $abs_path;
45 6         15 $self->repository($repo);
46              
47 6         22 $self->SUPER::build(@_);
48             }
49              
50             =item initialize
51              
52             Initialize a project.
53              
54             =cut
55              
56             sub initialize {
57 2     2 1 21 my $self = shift;
58              
59 2         9 my $dir = $self->SUPER::initialize(@_);
60              
61 2         16 $self->delete; # clean repository in case it exists
62              
63 2 50       15 rcopy( $dir, $self->repository )
64             or confess_or_die "can't copy $dir to " . $self->repository . ": $!";
65             }
66              
67             # a cmd generating factory
68             sub _cmd {
69 6     6   8 my $self = shift;
70 6         9 my $type = shift;
71 6         11 my %args = @_;
72 6   100     24 $args{path} ||= '';
73              
74 6         7 for ( @{ $REQUIRE_OPTIONS{$type} } ) {
  6         17  
75 0 0       0 confess_or_die "$type need option $_" unless $args{$_};
76             }
77              
78 6         10 my @cmd;
79              
80 6 50 33     40 if ( $type eq 'checkout' || $type eq 'export' ) {
    50          
    100          
    50          
    50          
    0          
    0          
81             @cmd = sub {
82 0     0   0 rcopy( $self->repository . $args{path}, $args{target} );
83 0         0 };
84             }
85             elsif ( $type eq 'import' ) {
86 0 0       0 if ( $args{_extra_tests} ) {
87             @cmd = sub {
88             rcopy( $args{source},
89 0     0   0 catdir( $self->repository, 't', 'extra' ) );
90 0         0 };
91             }
92             else {
93 0 0       0 if ( my $script_dir = $args{build_script} ) {
94             push @cmd, sub {
95             rcopy( catdir($script_dir),
96 0     0   0 catdir( $self->repository, 'scripts', $args{name} ) );
97 0         0 };
98             }
99             else {
100 0 0       0 if ( $self->has_branch_support ) {
101 0         0 my @dirs = splitdir( $args{as} );
102 0 0       0 unless (
103             -e catdir(
104             $self->repository, 'sources',
105             $args{name}, @dirs[ 0 .. $#dirs - 1 ]
106             )
107             )
108             {
109             push @cmd, sub {
110             make_path(
111             catdir(
112             $self->repository,
113             'sources',
114             $args{name},
115 0     0   0 @dirs[ 0 .. $#dirs - 1 ]
116             )
117             );
118 0         0 };
119             }
120              
121             push @cmd, sub {
122             rcopy(
123             catdir( $args{source} ),
124             catdir(
125             $self->repository, 'sources',
126             $args{name}, $args{as}
127             )
128 0     0   0 );
129 0         0 };
130             }
131             else {
132             push @cmd, sub {
133             rcopy( catdir( $args{source} ),
134 0     0   0 catdir( $self->repository, 'dists', $args{name} ) );
135 0         0 };
136             }
137             }
138             }
139             }
140             elsif ( $type eq 'delete' ) {
141 2     2   8 @cmd = sub { remove_tree( $self->repository . $args{path} ) };
  2         428  
142             }
143             elsif ( $type eq 'move' ) {
144             @cmd = sub {
145             rmove(
146             $self->repository . $args{path},
147             $self->repository . $args{new_path}
148 0     0   0 );
149 0         0 };
150             }
151             elsif ( $type eq 'info' ) {
152 4     4   18 @cmd = sub { -e $self->repository . $args{path} };
  4         105  
153             }
154             elsif ( $type eq 'list' ) {
155             @cmd = sub {
156 0     0   0 my $path = $self->repository . $args{path};
157 0 0       0 return 'No such file or directory' unless -e $path;
158              
159 0 0       0 if ( -d $path ) {
160 0         0 my $dh;
161 0 0       0 opendir $dh, $path or confess_or_die $!;
162 0         0 my $dirs = join "\t", grep { /^[^.]/ } readdir $dh;
  0         0  
163 0         0 return $dirs;
164             }
165             else {
166 0         0 return $path;
167             }
168 0         0 };
169             }
170             elsif ( $type eq 'cat' ) {
171             @cmd = sub {
172 0     0   0 my $path = $self->repository . $args{path};
173 0 0       0 return ( 'No such file or directory' ) unless -e $path;
174 0 0       0 return ( '', 'Is a directory' ) unless -f $path;
175 0         0 local $/;
176 0 0       0 open my $fh, '<', $path or confess_or_die $!;
177 0         0 my $c = <$fh>;
178 0         0 return $c;
179 0         0 };
180             }
181             else {
182 0         0 confess_or_die "invalid command: $type";
183             }
184              
185 6         23 return @cmd;
186             }
187              
188             =item _yml
189              
190              
191             =cut
192              
193             sub _yml {
194 5     5   6 my $self = shift;
195 5         9 my $path = shift;
196 5         7 my $yml = shift;
197              
198 5         27 my $file = catfile( $self->repository, $path );
199 5 100       13 if ($yml) {
200              
201 2         8 dump_yaml_file( $file, $yml );
202             }
203             else {
204 3         8 load_yaml_file($file);
205             }
206             }
207              
208             =item info
209              
210              
211             =cut
212              
213             sub info {
214 4     4 1 8 my $self = shift;
215 4         8 my %args = @_;
216 4   100     13 my $path = $args{path} || '';
217              
218 4         13 my ( $info, $err ) = $self->SUPER::info( path => $path );
219              
220 4 50       10 if (wantarray) {
221 0         0 return $info, $err;
222             }
223             else {
224 4         12 return $info;
225             }
226             }
227              
228             =item check_repository
229              
230             Check if the given repository is valid.
231              
232             =cut
233              
234             sub check_repository {
235 4     4 1 1348 my $self = shift;
236 4         13 my %args = @_;
237 4 100       10 if ( $args{action} eq 'create' ) {
238 2         5 my $repo = $self->repository;
239 2 50 33     6 if ( $args{force} || !-e $repo ) {
240 2         11 return 1;
241             }
242 0         0 $self->log->fatal("$repo exists already");
243 0         0 return;
244             }
245             else {
246 2         10 return $self->SUPER::check_repository(@_);
247             }
248             }
249              
250             sub _update_file {
251 0     0   0 my $self = shift;
252 0         0 my $path = shift;
253 0         0 my $latest = shift;
254              
255 0         0 my $file = catfile( $self->repository, $path );
256 0         0 unlink $file;
257 0 0       0 rcopy( $latest, $file ) or confess_or_die "can't copy $latest to $file: $!";
258             }
259              
260             sub _update_dir {
261 0     0   0 my $self = shift;
262 0         0 my $path = shift;
263 0         0 my $latest = shift;
264              
265 0         0 my $dir = catfile( $self->repository, $path );
266 0 0       0 rcopy( $latest, $dir ) or confess_or_die "can't copy $latest to $dir: $!";
267             }
268              
269             =item import
270              
271             =cut
272              
273             sub import {
274 2     2   10 my $self = shift;
275 2 50       40 return unless ref $self; # get rid of class->import
276 0           return $self->SUPER::import( @_, delete => 1 );
277             }
278              
279             =back
280              
281             =cut
282              
283             1;
284              
285             __END__