File Coverage

blib/lib/VCS/Lite/Element.pm
Criterion Covered Total %
statement 222 238 93.2
branch 78 106 73.5
condition 30 40 75.0
subroutine 22 23 95.6
pod 7 7 100.0
total 359 414 86.7


line stmt bran cond sub pod time code
1             package VCS::Lite::Element;
2              
3 11     11   51 use strict;
  11         15  
  11         374  
4 11     11   45 use warnings;
  11         17  
  11         576  
5              
6             our $VERSION = '0.12';
7              
8             #----------------------------------------------------------------------------
9              
10 11     11   90 use File::Spec::Functions qw(splitpath catfile catdir catpath rel2abs);
  11         13  
  11         885  
11 11     11   561 use Time::Piece;
  11         8634  
  11         62  
12 11     11   614 use Carp;
  11         15  
  11         574  
13 11     11   5544 use VCS::Lite;
  11         113522  
  11         364  
14 11     11   5957 use Params::Validate qw(:all);
  11         78048  
  11         2310  
15 11     11   85 use Cwd qw(abs_path);
  11         23  
  11         575  
16              
17 11     11   61 use base qw(VCS::Lite::Common);
  11         15  
  11         4982  
18              
19             #----------------------------------------------------------------------------
20              
21             sub new {
22 120     120 1 1726 my $pkg = shift;
23 120         146 my $file = shift;
24 120         520 my %args = validate ( @_,
25             {
26             store => {
27             type => SCALAR | OBJECT,
28             default => $pkg->default_store,
29             },
30             verbose => 0,
31             recordsize => 0, #ignored unless VCS::Lite::Element::Binary
32             } );
33 120         511 my $lite = $file;
34 120         176 my $verbose = $args{verbose};
35              
36 120         323 $file = rel2abs($file);
37 120         1823 my $store_pkg;
38 120 50       268 if (ref $args{store}) {
39 0         0 $store_pkg = $args{store};
40             } else {
41 120 100       392 $store_pkg = ($args{store} =~ /\:\:/) ? $args{store} : "VCS::Lite::Store::$args{store}";
42 120         7196 eval "require $store_pkg";
43 120 50       456 warn "Failed to require $store_pkg\n$@" if $@;
44             }
45              
46 120         624 my $ele = $store_pkg->retrieve($file);
47 120 100       281 if ($ele) {
48 94         311 $ele->path($file);
49 94         499 return $ele;
50             }
51              
52 26         159 my $proto = bless {
53             %args,
54             path => $file,
55             }, $pkg;
56              
57 26         98 $ele = $store_pkg->retrieve_or_create($proto);
58              
59 26         79 $ele->{path} = $file;
60              
61 26 50       77 if (!ref $lite) {
62 26 100       592 unless (-f $file) {
63 5 50       253 open FIL, '>', $file or croak("Failed to create $file, $!");
64 5         32 close FIL;
65             }
66 26         105 $lite = $ele->_slurp_lite($file);
67             } else {
68 0         0 $file = $lite->id; # Not handled at present
69             }
70              
71 26         2897 $ele->_assimilate($lite);
72 26         68 $ele->save;
73              
74 26         4835 $ele->{verbose} = $verbose;
75 26         402 $ele;
76             }
77              
78             sub check_in {
79 27     27 1 412 my $self = shift;
80 27         482 my %args = validate ( @_,
81             {
82             check_in_anyway => 0,
83             description => { type => SCALAR },
84             } );
85 27         112 my $file = $self->{path};
86              
87 27         71 my $lite = $self->_slurp_lite($file);
88              
89 27         2728 my $newgen = $self->_assimilate($lite);
90 27 50 66     210 return if !$newgen && !$args{check_in_anyway};
91              
92 14         66 $self->_mumble("Check in $file");
93 14   100     61 $self->{generation} ||= {};
94 14         17 my %gen = %{$self->{generation}};
  14         43  
95 14         61 $gen{$newgen} = {
96             author => $self->user,
97             description => $args{description},
98             updated => localtime->datetime,
99             };
100              
101 14   100     1301 $self->{latest} ||= {};
102 14         16 my %lat = %{$self->{latest}};
  14         41  
103 14         85 $newgen =~ /(\d+\.)*\d+$/;
104 14   50     79 my $base = $1 || '';
105 14         27 $lat{$base}=$newgen;
106              
107 14         55 $self->_update_ctrl( generation => \%gen, latest => \%lat);
108 14         2767 $newgen;
109             }
110              
111             sub repository {
112 0     0 1 0 my $self = shift;
113              
114 0         0 my ($vol,$dir,$fil) = splitpath($self->{path});
115 0 0       0 my $repos_path = $vol ? catdir($vol,$dir) : $dir;
116              
117 0         0 VCS::Lite::Repository->new($repos_path, verbose => $self->{verbose});
118             }
119              
120             sub traverse {
121 16     16 1 25 undef;
122             }
123              
124             sub fetch {
125 58     58 1 2703 my $self = shift;
126 58         768 my %args = validate ( @_,
127             {
128             time => 0,
129             generation => 0,
130             } );
131              
132 58   100     364 my $gen = $args{generation} || $self->latest;
133              
134 58 50       185 if ($args{time}) {
135 0         0 my $latest_time = '';
136 0   0     0 my $branch = $args{generation} || '';
137 0 0       0 $branch .= '.' if $branch;
138 0         0 for (keys %{$self->{generation}}) {
  0         0  
139 0 0       0 next unless /^$branch\d+$/;
140 0 0       0 next if $self->{generation}{$_}{updated} > $args{time};
141 0 0       0 ($latest_time,$gen) = ($self->{generation}{$_}{updated}, $_)
142             if $self->{generation}{$_}{updated} > $latest_time;
143             }
144 0 0       0 return unless $latest_time;
145             }
146 58 50 66     211 return if $self->{generation} && !$self->{generation}{$gen};
147              
148 58         67 my $skip_to;
149             my @out;
150 58         63 for (@{$self->_contents}) {
  58         174  
151 2853 100       3626 if ($skip_to) {
152 121 100       434 if (/^=$skip_to$/) {
153 25         33 undef $skip_to;
154             }
155 121         183 next;
156             }
157 2732 100       4890 if (my ($type,$gensel) = /^([+-])(.+)/) {
158 60 100       100 if (_is_parent_of($gensel,$gen) ^ ($type eq '+')) {
159 25         28 $skip_to = $gensel;
160             }
161 60         89 next;
162             }
163 2672 100       6372 next if /^=/;
164              
165 2637 50       5202 if (/^ /) {
166 2637         4339 push @out,substr($_,1);
167             }
168             }
169              
170 58         143 my $file = $self->{path};
171 58         414 VCS::Lite->new("$file\@\@$gen",undef,\@out);
172             }
173              
174             sub commit {
175 4     4 1 8 my ($self,$parent) = @_;
176              
177 4         11 my ($vol,$dir,$file) = splitpath($self->path);
178 4         71 my $updfile = catfile($parent,$file);
179 4         13 my $chg = $self->fetch;
180 4         179 my $before = VCS::Lite->new($updfile);
181 4 100       395 return unless $before->delta($chg);
182              
183 3         2967 $self->_mumble("Committing $file to $parent");
184              
185 3         4 my $out;
186 3 50       239 open $out,'>',$updfile or croak "Failed to open $file for committing, $!";
187 3         16 print $out $chg->text;
188             }
189              
190             sub update {
191 9     9 1 17 my ($self,$parent) = @_;
192              
193 9         23 my $file = $self->path;
194 9         44 $self->_mumble("Updating $file from $parent");
195              
196 9         22 my ($vol,$dir,$fil) = splitpath($file);
197 9         131 my $fromfile = catfile($parent,$fil);
198 9   50     45 my $baseline = $self->{baseline} || 0;
199 9         14 my $parbas = $self->{parent_baseline};
200              
201 9         27 my $orig = $self->fetch( generation => $baseline);
202 9         399 my $parele = VCS::Lite::Element->new($fromfile, verbose => $self->{verbose});
203 9         31 my $parfrom = $parele->fetch( generation => $parbas);
204 9         370 my $parlat = $parele->latest($parbas);
205 9         18 my $parto = $parele->fetch( generation => $parlat);
206 9         379 my $origplus = $parfrom->merge($parto,$orig);
207              
208 9         12959 my $chg = VCS::Lite->new($file);
209 9         997 my $merged = $orig->merge($origplus,$chg);
210 9         12771 my $out;
211 9 50       809 open $out,'>',$file or croak "Failed to write back merge of $fil, $!";
212 9         37 print $out $merged->text;
213 9         264 $self->_update_ctrl(baseline => $self->latest, parent_baseline => $parlat);
214             }
215              
216             sub _check_out_member {
217 17     17   23 my $self = shift;
218 17         26 my $newpath = shift;
219 17         348 my %args = validate(@_,
220             {
221             store => { type => SCALAR|OBJECT, optional => 1 },
222             } );
223              
224 17         209 my $repos = VCS::Lite::Repository->new(
225             $newpath,
226             verbose => $self->{verbose},
227             %args);
228              
229 17         65 my ($vol,$dir,$fil) = splitpath($self->path);
230 17         297 my $newfil = catfile($newpath,$fil);
231 17         24 my $out;
232 17 50       1176 open $out,'>',$newfil or croak "Failed to check_out $fil, $!";
233 17         102 print $out $self->fetch->text;
234 17         2001 close $out;
235              
236 17         45 my $pkg = ref $self;
237 17         105 $pkg->new($newfil,%args);
238             }
239              
240             sub _assimilate {
241 53     53   111 my ($self,$lite,%args) = @_;
242              
243 53         173 my @newgen = map { [' '.$_] } $lite->text;
  2462         4365  
244 53         298 my (@oldgen,@openers,@closers,$skip_to);
245 53   66     287 my $genbase = $args{generation} || $self->latest;
246              
247 53 100       128 if (my $cont = $self->_contents) {
248 28         58 for (@$cont) {
249 1118 100       1433 if ($skip_to) {
250 4         6 push @openers, $_;
251 4 100       34 if (/^=$skip_to$/) {
252 2         4 undef $skip_to;
253             }
254 4         19 next;
255             }
256 1114 100       2003 if (my ($type,$gen) = /^([+-])(.+)/) {
257 7 50       15 $oldgen[-1][2] = [@closers] if @closers;
258 7         14 @closers = ();
259 7         9 push @openers, $_;
260 7 100       18 if (_is_parent_of($gen,$genbase) ^ ($type eq '+')) {
261 2         3 $skip_to = $gen;
262             }
263 7         14 next;
264             }
265 1107 100       1609 if (my ($gen) = /^=(.+)/) {
266 5         9 push @closers, $_;
267 5         10 next;
268             }
269 1102 50       2110 if (/^ /) {
270 1102 100       1417 $oldgen[-1][2] = [@closers] if @closers;
271 1102         1600 push @oldgen,[$_, [@openers]];
272 1102         1034 @openers = @closers = ();
273 1102         1059 next;
274             }
275 0         0 croak "Invalid format in element contents";
276             }
277 28 100       76 $oldgen[-1][2] = [@closers] if @closers;
278             } else {
279 25         524 $self->_contents([map $_->[0], @newgen]);
280 25         227 return 1;
281             }
282              
283 28         168 $genbase =~ s/(\d+)$/$1+1/e;
  28         127  
284 28     2500   210 my @sd = Algorithm::Diff::sdiff( \@oldgen, \@newgen, sub { $_[0][0] });
  2500         11204  
285 28         8196 my (@newcont,@pending);
286 28         45 my $prev = 'u';
287 28         33 my $changed = 0;
288              
289 28         47 for (@sd) {
290 1362         1274 my ($ind,$c1,$c2) = @$_;
291 1362         938 my @res1;
292 1362 100       1797 if ($c1) {
293 1102         764 @res1 = (@{$c1->[1]},$c1->[0]);
  1102         1463  
294 1102 100       1609 push @res1,@{$c1->[2]} if defined $c1->[2];
  5         9  
295             }
296 1362 50       1991 my $res2 = $c2->[0] if $c2;
297              
298 1362 100 100     2522 push @newcont,"=$genbase\n" if ($prev ne 'u') && ($ind ne $prev);
299 1362 100 100     2275 if (@pending && ($ind ne 'c')) {
300 9         23 push @newcont, @pending, "=$genbase\n";
301 9         14 @pending=();
302             }
303 1362 100 100     5011 if (($prev =~ /[u+]/) && ($ind =~ /[c-]/)) {
304 9         28 push @newcont,"-$genbase\n";
305 9         11 $changed++;
306             }
307 1362 100       1531 if ($ind eq '+') {
308 260 100       363 push @newcont,"+$genbase\n" if ($prev ne $ind);
309 260         270 push @newcont, $res2;
310 260         195 $changed++;
311             } else {
312 1102         1072 push @newcont, @res1;
313             }
314 1362 100       1803 if ($ind eq 'c') {
315 38 100       61 push @pending,"+$genbase\n" if ($prev ne $ind);
316 38         37 push @pending, $res2;
317             }
318 1362         1587 $prev = $ind;
319             }
320              
321 28 100       86 push @newcont,"=$genbase\n" if ($prev ne 'u');
322 28 100       388 return unless $changed;
323 14         50 $self->_contents(\@newcont);
324 14         237 $genbase;
325             }
326              
327             sub _is_parent_of {
328 67     67   73 my ($gen1,$gen2) = @_;
329              
330 67         142 my @g1v = split /\./,$gen1;
331 67         106 my @g2v = split /\./,$gen2;
332 67   66     476 (shift @g1v,shift @g2v) while @g1v && @g2v && ($g1v[0] eq $g2v[0]);
      100        
333              
334 67 100       216 return 1 unless @g2v;
335 18 50       30 return 0 unless @g1v;
336 18 50       32 return 0 if @g1v > 1;
337              
338 18         74 $g1v[0] < $g2v[0];
339             }
340              
341             sub _update_ctrl {
342 23     23   65 my ($self,%args) = @_;
343              
344 23   33     102 my $path = $args{path} || $self->{path};
345 23         80 my ($vol,$dir,$fil) = splitpath($path);
346 23         416 $self->{$_} = $args{$_} for keys %args;
347 23         87 $self->{updated} = localtime->datetime;
348 23         1789 $self->save;
349             }
350              
351             sub _contents {
352 143     143   161 my $self = shift;
353              
354 143 100       308 $self->{contents} = shift if @_;
355 143 100       341 return unless exists $self->{contents};
356              
357 118         260 $self->{contents};
358             }
359              
360             sub _slurp_lite {
361 50     50   84 my ($self,$name) = @_;
362              
363 50         266 VCS::Lite->new($name);
364             }
365              
366             1;
367              
368             __END__