File Coverage

blib/lib/VCS/Lite/Repository.pm
Criterion Covered Total %
statement 207 249 83.1
branch 49 84 58.3
condition 36 77 46.7
subroutine 26 27 96.3
pod 14 14 100.0
total 332 451 73.6


line stmt bran cond sub pod time code
1             package VCS::Lite::Repository;
2              
3 10     10   79684 use 5.006;
  10         33  
  10         395  
4 10     10   51 use strict;
  10         16  
  10         396  
5 10     10   53 use warnings;
  10         12  
  10         497  
6              
7             our $VERSION = '0.12';
8              
9             #----------------------------------------------------------------------------
10              
11 10     10   52 use Carp;
  10         16  
  10         777  
12 10     10   2314 use File::Spec::Functions qw(:ALL !path);
  10         2832  
  10         2149  
13 10     10   5994 use Time::Piece;
  10         121876  
  10         51  
14 10     10   5260 use VCS::Lite::Element;
  10         25  
  10         471  
15 10     10   78 use Params::Validate qw(:all);
  10         13  
  10         1965  
16 10     10   48 use Cwd qw(abs_path);
  10         14  
  10         403  
17              
18 10     10   42 use base qw(VCS::Lite::Common);
  10         24  
  10         26866  
19              
20             #----------------------------------------------------------------------------
21              
22             sub new {
23 97     97 1 92739 my $pkg = shift;
24 97         154 my $path = shift;
25 97         430 my %args = validate ( @_,
26             {
27             store => {
28             type => SCALAR | OBJECT,
29             default => $pkg->default_store
30             },
31             verbose => 0,
32             } );
33              
34 97         809 my $verbose = $args{verbose};
35              
36 97 100       1556 if (-d $path) {
    100          
37             } elsif (-f $path) {
38 1         163 croak "Invalid path '$path' must be a directory";
39             } else {
40 11 100       744 mkdir $path or croak "Failed to create directory: $!";
41             }
42              
43 95         3114 my $abspath = abs_path($path);
44 95         476 my $proto = bless {
45             path => $abspath,
46             verbose => $verbose,
47             contents => []
48             },$pkg;
49              
50 95         133 my $store_pkg;
51 95 50       233 if (ref $args{store}) {
52 0         0 $store_pkg = $args{store};
53             } else {
54 95 100       395 $store_pkg = ($args{store} =~ /\:\:/) ? $args{store} : "VCS::Lite::Store::$args{store}";
55 95         6947 eval "require $store_pkg";
56 95 50       389 warn "Failed to require $store_pkg\n$@" if $@;
57             }
58              
59 95         508 my $repos = $store_pkg->retrieve_or_create($proto);
60 95 50       270 if (exists $repos->{elements}) {
61 0         0 $repos->_mumble("Upgrading repository $abspath from 0.02 to $VERSION");
62 0   0     0 $repos->{contents} ||= $repos->{elements};
63 0         0 delete $repos->{elements};
64 0         0 $repos->save;
65             }
66              
67 95         278 $repos->path($abspath);
68 95         246 $repos->{author} = $repos->user;
69 95         163 $repos->{verbose} = $verbose;
70 95         619 $repos;
71             }
72              
73             sub add {
74 13     13 1 1415 my $self = shift;
75 13         206 my ($file) = validate_pos(@_, { type => SCALAR });
76              
77 13         56 my $path = $self->path;
78 13         43 my ($vol,$dirs,$fil) = splitpath($file);
79 13         209 my $absfile;
80             my $remainder;
81              
82 13 100       30 if ($dirs) {
83 2         6 my ($top,@dirs) = splitdir($dirs);
84 2 50       17 $top = shift @dirs if $top eq ''; # VMS quirk
85 2 50 33     13 pop @dirs if !defined($dirs[-1]) || ($dirs[-1] eq '');
86 2         155 $absfile = abs_path(catfile($path,$top));
87 2 100       105 mkdir $absfile unless -d $absfile;
88 2 100       12 $remainder = @dirs ? catpath($vol,catdir(@dirs),$fil) : $fil;
89 2         13 $file = $top;
90             } else {
91 11         60 $absfile = catfile($path,$fil);
92             }
93              
94 13 50 66     164 unless ((catdir($file) eq updir) ||
  10   66     39  
95             (catdir($file) eq curdir) ||
96 12         48 grep {$file eq $_} @{$self->{contents}}) {
97              
98 12         112 $self->_mumble("Add $file to $path");
99              
100 12         19 my @newlist = sort(@{$self->{contents}},$file);
  12         63  
101 12   100     57 $self->{transactions} ||= [];
102 12         48 my @trans = (@{$self->{transactions}}, ['add',$file]);
  12         45  
103 12         54 $self->_update_ctrl( contents => \@newlist, transactions => \@trans);
104             }
105              
106 13 100       2567 my $newobj = (
107             -d $absfile)
108             ? VCS::Lite::Repository->new($absfile, store => $self->{store})
109             : VCS::Lite::Element->new($absfile, store => $self->{store}
110             );
111            
112 13 100       98 $remainder ? $newobj->add($remainder) : $newobj;
113             }
114              
115             sub add_element {
116 1     1 1 662 my ($self,$file) = @_;
117 1 50       16 (-d $file) ? undef : add(@_);
118             }
119              
120             sub add_repository {
121 2     2 1 1842 my ($self,$dir) = @_;
122 2 50       46 return if -f $dir;
123              
124 2         149 mkdir catfile($self->{path},$dir);
125 2         10 add(@_);
126             }
127              
128             sub remove {
129 2     2 1 1183 my $self = shift;
130 2         30 my ($file) = validate_pos(@_, { type => SCALAR });
131              
132 2         9 my @contents;
133 2         3 my $doit = 0;
134              
135 2         3 for (@{$self->{contents}}) {
  2         8  
136 5 100       11 if ($file eq $_) {
137 2         3 $doit++;
138             } else {
139 3         6 push @contents,$_;
140             }
141             }
142 2 50       6 return unless $doit;
143              
144 2         10 $self->_mumble("Remove $file from " . $self->path);
145 2   100     8 $self->{transactions} ||= [];
146 2         4 my @trans = (@{$self->{transactions}}, ['remove',$file]);
  2         7  
147 2         6 $self->_update_ctrl( contents => \@contents, transactions => \@trans);
148 2         375 1;
149             }
150              
151             sub contents {
152 45     45 1 1645 my $self = shift;
153              
154 105         512 map {
155 45         120 my $file = catfile($self->{path},$_);
156 105 100       2583 (-d $file)
157             ? VCS::Lite::Repository->new($file,
158             verbose => $self->{verbose},
159             store => $self->{store})
160             : VCS::Lite::Element->new($file,
161             verbose => $self->{verbose},
162             store => $self->{store});
163 45         56 } @{$self->{contents}};
164             }
165              
166             sub elements {
167 1     1 1 484 my $self = shift;
168              
169 1         4 grep {$_->isa('VCS::Lite::Element')} $self->contents;
  1         6  
170             }
171              
172             sub repositories {
173 0     0 1 0 my $self = shift;
174              
175 0         0 grep {$_->isa('VCS::Lite::Repository')} $self->contents;
  0         0  
176             }
177              
178             sub traverse {
179 37     37 1 4325 my $self = shift;
180 37         64 my $func = shift;
181 37         718 my %args = validate(@_,
182             {
183             recurse => 0,
184             params => { type => ARRAYREF | SCALAR, optional => 1 },
185             } );
186              
187 37         135 my @out;
188 37   100     114 $args{params} ||= [];
189 37 100       117 $args{params} = [$args{params}] unless ref $args{params};
190              
191 37         105 for ($self->contents) {
192 89 50 66     293 if ($args{recurse} && ($args{recurse} eq 'pre')) {
193 0         0 my @subout = grep {defined $_} $_->traverse($func,%args);
  0         0  
194 0 0       0 push @out,\@subout if @subout;
195             }
196 97         2514 my @res = grep {defined $_} ((ref $func) ?
  15         33  
197 74         421 &$func($_,@{$args{params}}) :
198 89 100       198 $_->$func(@{$args{params}}));
199 89         2635 push @out,@res;
200 89 100 66     376 if ($args{recurse} && ($args{recurse} ne 'pre')) {
201 20         56 my @subout = grep {defined $_} $_->traverse($func,%args);
  37         49  
202 20 100       54 push @out,\@subout if @subout;
203             }
204             }
205 37         950 @out;
206             }
207              
208             sub check_out {
209 9     9 1 2642 my $self = shift;
210 9         16 my $newpath = shift;
211 9         176 my %args = validate(@_,
212             {
213             store => { type => SCALAR|OBJECT, optional => 1 },
214             } );
215              
216 9         56 $self->_mumble("Check out " . $self->path . " to $newpath");
217             # $self->{transactions} ||= [];
218 9         58 my $newrep = VCS::Lite::Repository->new(
219             $newpath,
220             verbose => $self->{verbose},
221             %args);
222 9         48 $newrep->_update_ctrl(
223             parent => $self->{path},
224             contents => $self->{contents},
225             original_contents => $self->{contents},
226             parent_baseline => $self->latest,
227             parent_store => $self->{store}
228             );
229 9         1509 $self->traverse('_check_out_member', params => [$newpath,%args]);
230 9         114 VCS::Lite::Repository->new(
231             $newpath,
232             verbose => $self->{verbose},
233             %args);
234             # This is different from the $newrep object, as it is fully populated.
235             }
236              
237             sub check_in {
238 12     12 1 783 my $self = shift;
239 12         249 my %args = validate ( @_,
240             {
241             check_in_anyway => 0,
242             description => { type => SCALAR },
243             } );
244              
245 12         80 $self->_mumble("Checking in " . $self->path);
246 12 100 66     64 if (($self->{transactions} && @{$self->{transactions}})
  6   66     30  
247             || $args{check_in_anyway}) {
248              
249 6         15 $self->_mumble("Updating directory changes");
250              
251 6   33     39 my $newgen = $args{generation} || $self->latest;
252 6         43 $newgen =~ s/(\d+)$/$1+1/e;
  6         26  
253 6   50     33 $self->{generation} ||= {};
254 6         9 my %gen = %{$self->{generation}};
  6         18  
255 6         24 $gen{$newgen} = {
256             author => $self->user,
257             description => $args{description},
258             updated => localtime->datetime,
259             transactions => $self->{transactions},
260             contents => $self->{contents},
261             };
262              
263 6   50     640 $self->{latest} ||= {};
264 6         8 my %lat = %{$self->{latest}};
  6         16  
265 6         38 $newgen =~ /(\d+\.)*\d+$/;
266 6   50     30 my $base = $1 || '';
267 6         14 $lat{$base}=$newgen;
268 6         16 delete $self->{transactions};
269              
270 6         22 $self->_update_ctrl( generation => \%gen, latest => \%lat);
271             }
272              
273 12         1362 $self->traverse('check_in', params => [%args]);
274             }
275              
276             sub commit {
277 2     2 1 5 my ($self,$parent) = @_;
278              
279 2         7 my $path = $self->path;
280 2         7 my $repos_name = (splitdir($self->path))[-1];
281 2   33     25 my $parent_repos_path = $self->{parent} || catdir($parent,$repos_name);
282 2         13 $self->_mumble("Committing $path to $parent_repos_path");
283 2   33     18 my $parent_repos = VCS::Lite::Repository->new(
284             $parent_repos_path,
285             verbose => $self->{verbose},
286             store => $self->{parent_store} || $self->{store});
287              
288 2         13 my $orig = VCS::Lite->new($repos_name,undef,$parent_repos->{contents});
289 2         83 my $changed = VCS::Lite->new($repos_name,undef,$self->{contents});
290              
291 2         55 $self->_apply($parent_repos,$orig->delta($changed));
292 2   33     22 $self->traverse('commit',
293             params => $self->{parent} || catdir($parent,$repos_name));
294             }
295              
296             sub update {
297 5     5 1 9 my ($self,$srep) = @_;
298              
299 5         18 my $file = $self->path;
300 5         21 my $repos_name = (splitdir($file))[-1];
301 5   33     53 $self->{parent} ||= catdir($srep,$repos_name);
302 5         11 my $parent = $self->{parent};
303 5         30 $self->_mumble("Updating $file from $parent");
304 5   50     24 my $baseline = $self->{baseline} || 0;
305 5         10 my $parbas = $self->{parent_baseline};
306              
307 5         15 my $orig = $self->fetch( generation => $baseline);
308 5         197 my $parele = VCS::Lite::Repository->new(
309             $parent,
310             verbose => $self->{verbose},
311             store => $self->{parent_store});
312              
313 5         15 my $parfrom = $parele->fetch( generation => $parbas);
314 5         175 my $parlat = $parele->latest; # was latest($parbas) - buggy
315 5         14 my $parto = $parele->fetch( generation => $parlat);
316 5         119 my $origplus = $parfrom->merge($parto,$orig);
317              
318 5         1281 my $chg = VCS::Lite->new($repos_name,undef,$self->{contents});
319 5         97 my $merged = $orig->merge($origplus,$chg);
320 5         957 $parele->_apply($self,$chg->delta($merged));
321              
322 5         30 $self->_update_ctrl(baseline => $self->latest, parent_baseline => $parlat);
323              
324 5         890 $self->traverse('update', params => $parent);
325             }
326              
327             sub fetch {
328 17     17 1 26 my $self = shift;
329 17         209 my %args = validate ( @_,
330             {
331             time => 0,
332             generation => 0,
333             } );
334              
335 17 100       79 my $gen = exists($args{generation}) ? $args{generation} : $self->latest;
336              
337 17 50       36 if ($args{time}) {
338 0         0 my $latest_time = '';
339 0   0     0 my $branch = $args{generation} || '';
340 0 0       0 $branch .= '.' if $branch;
341              
342 0         0 for (keys %{$self->{generation}}) {
  0         0  
343 0 0       0 next unless /^$branch\d+$/;
344 0 0       0 next if $self->{generation}{$_}{updated} > $args{time};
345 0 0       0 ($latest_time,$gen) = ($self->{generation}{$_}{updated}, $_)
346             if $self->{generation}{$_}{updated} > $latest_time;
347             }
348              
349 0 0       0 return unless $latest_time;
350             }
351              
352 17 50 66     68 return if $gen && $self->{generation} && !$self->{generation}{$gen};
      66        
353              
354 17 100 50     48 my $cont =
355             $gen
356             ? $self->{generation}{$gen}{contents}
357             : $self->{original_contents} || [];
358              
359 17         20 my $file = $self->{path};
360 17   100     55 $gen ||= 0;
361 17         82 VCS::Lite->new("$file\@\@$gen",undef,$cont);
362             }
363              
364             sub _apply {
365 7     7   1219 my ($src,$dest,$delt) = @_;
366              
367 7 50       81 return unless $delt;
368              
369 0         0 my $srcpath = $src->path;
370 0         0 my $path = $dest->path;
371              
372 0         0 for (map {@$_} $delt->hunks) {
  0         0  
373 0         0 my ($ind,$lin,$val) = @$_;
374 0 0       0 if ($ind eq '-') {
    0          
375 0         0 $dest->remove($val);
376             } elsif ($ind eq '+') {
377 0         0 my $destname = catdir($path,$val);
378 0         0 my $srcname = catdir($srcpath,$val);
379             # $srcname is false if catdir can't construct a dir, e.g.
380             # if on VMS and $val contains a dot
381 0 0 0     0 mkdir $destname if $srcname && -d $srcname;
382 0         0 my $newobj = $dest->add($val);
383 0 0 0     0 if (exists($dest->{parent}) && ($dest->{parent} eq $srcpath)) {
384 0         0 $newobj->{parent} = catdir($dest->{parent},$val);
385 0         0 $newobj->{parent_store} = $dest->{parent_store};
386 0         0 $newobj->{parent_baseline} = 0;
387 0         0 $newobj->save;
388             }
389 0 0 0     0 if (exists($src->{parent}) && ($src->{parent} eq $path)) {
390 0         0 my $srcobj = $src->{store}->retrieve($srcname);
391 0         0 $srcobj->{parent} = catdir($src->{parent},$val);
392 0         0 $srcobj->{parent_store} = $src->{parent_store};
393 0         0 $srcobj->{parent_baseline} = 0;
394 0         0 $srcobj->save;
395             }
396             }
397             }
398             }
399              
400             sub _check_out_member {
401 5     5   7 my $self = shift;
402 5         9 my $newpath = shift;
403 5         97 my %args = validate(@_,
404             {
405             store => { type => SCALAR|OBJECT, optional => 1 },
406             } );
407              
408 5         34 my $repos_name = (splitdir($self->path))[-1];
409 5         74 my $newrep = VCS::Lite::Repository->new(
410             $newpath,
411             verbose => $self->{verbose},
412             %args);
413              
414 5         22 my $new_repos = catdir($newpath,$repos_name);
415              
416 5         24 $self->check_out($new_repos,%args);
417             }
418              
419             sub _update_ctrl {
420 34     34   148 my ($self,%args) = @_;
421              
422 34   33     161 my $path = $args{path} || $self->{path};
423 34         100 for (keys %args) {
424 95         182 $self->{$_} = $args{$_};
425             }
426              
427 34         130 $self->{updated} = localtime->datetime;
428 34         2892 $self->save;
429             }
430              
431             1;
432              
433             __END__