File Coverage

blib/lib/VCS/Lite.pm
Criterion Covered Total %
statement 173 195 88.7
branch 69 96 71.8
condition 43 56 76.7
subroutine 22 24 91.6
pod 9 9 100.0
total 316 380 83.1


line stmt bran cond sub pod time code
1             package VCS::Lite;
2              
3 9     9   374692 use strict;
  9         25  
  9         467  
4 9     9   51 use warnings;
  9         17  
  9         567  
5             our $VERSION = '0.11';
6              
7             #----------------------------------------------------------------------------
8              
9             =head1 NAME
10              
11             VCS::Lite - Minimal version control system
12              
13             =head1 SYNOPSIS
14              
15             use VCS::Lite;
16              
17             # diff
18              
19             my $lit = VCS::Lite->new('/home/me/foo1.txt');
20             my $lit2 = VCS::Lite->new('/home/me/foo2.txt');
21             my $difftxt = $lit->delta($lit2)->diff;
22             print OUTFILE $difftxt;
23              
24             # patch
25              
26             my $delt = VCS::Lite::Delta->new('/home/me/patch.diff');
27             my $lit3 = $lit->patch($delt);
28             print OUTFILE $lit3->text;
29              
30             # merge
31              
32             my $lit4 = $lit->merge($lit->delta($lit2),$lit->delta($lit3));
33             print OUTFILE $lit4->text;
34              
35             =head1 DESCRIPTION
36              
37             This module provides the functions normally associated with a version
38             control system, but without needing or implementing a version control
39             system. Applications include wikis, document management systems and
40             configuration management.
41              
42             It makes use of the module Algorithm::Diff. It provides the facility
43             for basic diffing, patching and merging.
44              
45             =cut
46              
47             #----------------------------------------------------------------------------
48              
49             #############################################################################
50             #Library Modules #
51             #############################################################################
52              
53 9     9   62 use Carp;
  9         26  
  9         18045  
54 9     9   13836 use Algorithm::Diff qw(traverse_sequences);
  9         100893  
  9         2102  
55 9     9   23739 use VCS::Lite::Delta;
  9         141  
  9         59367  
56              
57             #----------------------------------------------------------------------------
58              
59             #############################################################################
60             #Interface Methods #
61             #############################################################################
62              
63             sub new {
64 37     37 1 36691 my ($class,$id,$sep,$src,@args) = @_;
65              
66 37         113 my %proto = ();
67              
68             # Decode $sep as needed
69              
70 37 100       157 if (ref($sep) eq 'HASH') {
71 10         55 %proto = %$sep;
72 10         31 $sep = $proto{in};
73 10         32 delete $proto{in};
74             }
75            
76             # DWIM logic, based on $src parameter.
77              
78             # Case 0: $src missing. Use $id as file name, becomes case 3
79 37 100 33     1366 open $src,$id or croak("failed to open '$id': $!") unless $src;
80            
81 37         112 my $atyp = ref $src;
82 37   66     218 $sep ||= $/;
83 37 50       236 local $/ = $sep if $sep;
84 37   50     1814 $proto{out} ||= $\ || '';
      66        
85 37         79 my $out_sep = $proto{out};
86 37         62 my @contents;
87              
88             # Case 1: $src is string
89 37 50       195 if (!$atyp) {
    100          
    50          
    0          
90 0         0 @contents = split /(?=$sep)/,$src;
91             }
92             # Case 2: $src is arrayref
93             elsif ($atyp eq 'ARRAY') {
94 17         1756 @contents = @$src;
95             }
96             # Case 3: $src is globref (file handle)
97             elsif ($atyp eq 'GLOB') {
98 20         1939 @contents = <$src>;
99             }
100             # Case 4: $src is coderef - callback
101             elsif ($atyp eq 'CODE') {
102 0         0 while (my $item=&$src(@args)) {
103 0         0 push @contents,$item;
104             }
105             }
106             # Case otherwise is an error.
107             else {
108 0         0 croak "Invalid argument";
109             }
110            
111 37 100 66     776 $proto{last_line_short} = 1
112             if @contents && ($contents[-1] !~ /$sep$/);
113            
114 37 100       127 if ($proto{chomp}) {
115 6         849 s/$sep$//s for @contents;
116 6   66     34 $proto{out} ||= $sep;
117             }
118            
119 37         1311 bless { id => $id,
120             contents => \@contents,
121             separator => $sep,
122             %proto },$class;
123             }
124              
125             sub original {
126 2     2 1 3 my $self = shift;
127              
128 2         5 my $pkg = ref $self;
129              
130 2 50       13 exists($self->{original}) ?
131             bless ({ id => $self->id,
132             contents => $self->{original},
133             separator => $self->{separator},
134             out => $self->{out},
135             chomp => $self->{chomp},
136             }, $pkg ) :
137             $self;
138             }
139              
140             sub apply {
141 3     3 1 16 my ($self,$other,%par) = @_;
142              
143 3         7 my $pkg = ref $self;
144 3         7 my $base = $par{base};
145 3   100     16 $base ||= 'contents';
146 3 50       19 $base = $pkg->new( $self->id,
147             $self->{separator},
148             $self->{$base})
149             unless ref $base;
150 3 100       17 my $cbase = exists($other->{original}) ? $other->original : $base;
151 3         14 my $mrg = $cbase->merge($base,$other);
152 3         34 my $mrg2 = $base->merge($self,$mrg);
153 3   66     38 $self->{original} ||= $self->{contents};
154 3         16 $self->{contents} = [$mrg2->text];
155             }
156            
157             sub text {
158 40     40 1 7703 my ($self,$sep) = @_;
159            
160 40   100     304 $sep ||= $self->{out} || '';
      66        
161              
162 40 100       93 wantarray ? @{$self->{contents}} : join $sep,@{$self->{contents}};
  27         1072  
  13         405  
163             }
164              
165             sub id {
166 26     26 1 3923 my $self = shift;
167              
168 26 50       252 @_ ? ($self->{id} = shift) : $self->{id};
169             }
170              
171             sub delta {
172 9     9 1 3337 my $lite1 = shift;
173 9         24 my $lite2 = shift;
174 9         26 my %par = @_;
175            
176 9         53 my @wl1 = $lite1->_window($par{window});
177 9         179 my @wl2 = $lite2->_window($par{window});
178 29 100       17876 my @d = map { [map { [$_->[0] . ($_->[2]{short} ? '/' : ''),
  175         1065  
179             $_->[1], $_->[2]{line} ] } @$_ ] }
180 1627     1627   120054 Algorithm::Diff::diff(\@wl1,\@wl2,sub { $_[0]{window}; })
181 9 100       179 or return undef;
182              
183 7         129 VCS::Lite::Delta->new(\@d,$lite1->id,$lite2->id,$lite1->{out});
184             }
185              
186             sub _window {
187 18     18   37 my $self = shift;
188              
189 18   100     770 my $win = shift || 0;
190 18 50       66 my ($win_from,$win_to) = ref($win) ? (-$win->[0],$win->[1]) :
191             (-$win,$win);
192 18         24 my @wintxt;
193 18         27 my $max = $#{$self->{contents}};
  18         49  
194 18         73 for (0..$max) {
195 1599         2407 my $win_lb = $_ + $win_from;
196 1599 100       5783 $win_lb = 0 if $win_lb < 0;
197 1599         2408 my $win_ub = $_ + $win_to;
198 1599 100       6511 $win_ub = $max if $win_ub > $max;
199 1599         11074 push @wintxt, join $self->{out},
200 1599 100 100     5110 (@{$self->{contents}}[$win_lb .. $win_ub],
201             (($win_ub < $max) || !$self->{last_line_short}) ?
202             '' : ());
203             }
204              
205 18 100 100     143 map { {line => $self->{contents}[$_],
  1599         14172  
206             window => $wintxt[$_],
207             ( $self->{last_line_short} && ($_ == $max)) ? ( short => 1 ) : (),
208             } }
209             (0..$max);
210             }
211              
212             sub diff {
213 1     1 1 8 my $self = shift;
214              
215 1         5 $self->delta(@_)->diff;
216             }
217              
218             sub patch {
219 6     6 1 6661 my $self = shift;
220 6         12 my $patch = shift;
221 6 50       29 $patch = VCS::Lite::Delta->new($patch,@_)
222             unless ref $patch eq 'VCS::Lite::Delta';
223 6         8 my @out = @{$self->{contents}};
  6         132  
224 6         25 my $id = $self->id;
225 6         15 my $pkg = ref $self;
226 6         32 my @pat = $patch->hunks;
227              
228 6         17 for (@pat) {
229 20         41 for (@$_) {
230 148         253 my ($ind,$lin,$txt) = @$_;
231 148 100       432 next unless $ind =~ /^-/;
232 82 50       201 _error($lin,'Patch failed'),return undef
233             if $out[$lin] ne $txt;
234             }
235             }
236              
237 6         10 my $line_offset = 0;
238 6         9 my $lls = 0;
239            
240 6         17 for (@pat) {
241 20         40 my @txt1 = grep {$_->[0] =~ /^\-/} @$_;
  148         342  
242 20         34 my @txt2 = grep {$_->[0] =~ /^\+/} @$_;
  148         10734  
243 20 100       64 my $base_line = @txt2 ? $txt2[0][1] : $txt1[0][1] + $line_offset;
244 20         44 splice @out,$base_line,scalar(@txt1),map {$_->[2]} @txt2;
  66         203  
245 20         45 $line_offset += @txt2 - @txt1;
246 20         36 $lls += grep {$_->[0] eq '+/'} @txt2;
  66         191  
247             }
248              
249 6         110 $pkg->new($id,{
250             in => $self->{separator},
251             chomp => $self->{chomp},
252             out => $self->{out},
253             last_line_short => $lls,
254             },\@out);
255             }
256              
257             # Equality of two array references (contents)
258            
259             sub _equal {
260 0     0   0 my ($a,$b) = @_;
261            
262 0 0       0 return 0 if @$a != @$b;
263            
264 0         0 foreach (0..$#$a) {
265 0 0       0 return 0 if $a->[$_] ne $b->[$_];
266             }
267            
268 0         0 1;
269             }
270              
271             sub merge {
272 8     8 1 47 my ($self,$d1,$d2) = @_;
273 8         17 my $pkg = ref $self;
274              
275 8         35 my $orig = [$self->text];
276 8         68 my $chg1 = [$d1->text];
277 8         601 my $chg2 = [$d2->text];
278 8         76 my $out_title = $d1->{id} . '|' . $d2->{id};
279 8         14 my %ins1;
280 8         14 my $del1 = '';
281              
282             traverse_sequences( $self->{contents}, $chg1, {
283 784     784   85779 MATCH => sub { $del1 .= ' ' },
284 24     24   168 DISCARD_A => sub { $del1 .= '-' },
285 12     12   72 DISCARD_B => sub { push @{$ins1{$_[0]}},$chg1->[$_[1]] },
  12         67  
286 8         173 } );
287              
288 8         214 my %ins2;
289 8         21 my $del2 = '';
290              
291             traverse_sequences( $self->{contents}, $chg2, {
292 749     749   56048 MATCH => sub { $del2 .= ' ' },
293 59     59   547 DISCARD_A => sub { $del2 .= '-' },
294 66     66   66788 DISCARD_B => sub { push @{$ins2{$_[0]}},$chg2->[$_[1]] },
  66         328  
295 8         143 } );
296              
297             # First pass conflict detection: deletion on file 1 and insertion on file 2
298              
299 8         185 $del1 =~ s(\-+){
300 9         27 my $stlin = length $`;
301 9         18 my $numdel = length $&;
302              
303 9 100       36 my @confl = map {exists $ins2{$_} ? ($_) : ()}
  15         57  
304             ($stlin+1..$stlin+$numdel-1);
305 9 100       71 @confl ? '*' x $numdel : $&;
306             }eg;
307              
308             # Now the other way round: deletion on file 2 and insertion on file 1
309              
310 8         147 $del2 =~ s(\-+){
311 38         81 my $stlin = length $`;
312 38         61 my $numdel = length $&;
313              
314 38 50       101 my @confl = map {exists $ins1{$_} ? ($_) : ()}
  21         68  
315             ($stlin+1..$stlin+$numdel-1);
316 38 50       208 @confl ? '*' x $numdel : $&;
317             }eg;
318              
319             # Conflict type 1 is insert of 2 into deleted 1, Conflict type 2 is insert of 1 into deleted 2
320             # @defer is used to hold the 'other half' alternative for the conflict
321              
322 8         23 my $conflict = 0;
323 8         16 my $conflict_type = 0;
324 8         19 my @defer;
325              
326             my @out;
327              
328 8         19 for (0..@{$self->{contents}}) {
  8         831  
329              
330             # Get details pertaining to current @f0 input line
331 816         1776 my $line = $self->{contents}[$_];
332 816         3576 my $d1 = substr $del1,$_,1;
333 816 100       1716 my $ins1 = $ins1{$_} if exists $ins1{$_};
334 816         1080 my $d2 = substr $del2,$_,1;
335 816 100       1681 my $ins2 = $ins2{$_} if exists $ins2{$_};
336              
337             # Insert/insert conflict. This is not a conflict if both inserts are identical.
338              
339 816 50 66     3197 if ($ins1 && $ins2 && !&_equal($ins1,$ins2)) {
    100 33        
340 0         0 push @out, ('*'x20)."Start of conflict ".(++$conflict).
341             " Insert to Primary, Insert to Secondary ".('*'x60)."\n";
342              
343 0         0 push @out, @$ins1, ('*'x100)."\n", @$ins2;
344 0         0 push @out, ('*'x20)."End of conflict ".$conflict.('*'x80)."\n";
345             } elsif (!$conflict_type) { #Insert/Delete conflict
346              
347             # Normal insertion - may be from $ins1 or $ins2. Apply the inser and junk both $ins1 and $ins2
348              
349 809   100     4334 $ins1 ||= $ins2;
350              
351 809 100       7986 push @out, @$ins1 if defined $ins1;
352              
353 809         833 undef $ins1;
354 809         916 undef $ins2;
355             }
356              
357             # Detect start of conflict 1 and 2
358              
359 816 100 100     3642 if (!$conflict_type && $d1 eq '*') {
360 2         14 push @out, ('*'x20)."Start of conflict ".(++$conflict).
361             " Delete from Primary, Insert to Secondary ".('*'x60)."\n";
362              
363 2         4 $conflict_type = 1;
364             }
365              
366 816 50 66     3136 if (!$conflict_type && $d2 eq '*') {
367 0         0 push @out, ('*'x20)."Start of conflict ".(++$conflict).
368             " Delete from Secondary, Insert to Primary ".('*'x60)."\n";
369              
370 0         0 $conflict_type = 2;
371             }
372              
373             # Handle case where we are in an Insert/Delete conflict block already
374              
375 816 100       1708 if ($conflict_type == 1) {
376 9 100       23 if ($d1 eq '*') {
377              
378             # Deletion block continues...
379 7 100       22 push @defer,(@$ins2) if $ins2;
380 7 50       22 push @defer,$line if !$d2;
381             } else {
382              
383             # handle end of block, dump out @defer and clear it
384              
385 2         9 push @out, ('*'x100)."\n",@defer;
386 2         5 undef @defer;
387 2         8 push @out, ('*'x20)."End of conflict ".$conflict.('*'x80)."\n";
388 2         4 $conflict_type = 0;
389             }
390             }
391              
392 816 50       5576 if ($conflict_type == 2) {
393 0 0       0 if ($d2 eq '*') {
394              
395             # Deletion block continues...
396 0 0       0 push @defer,(@$ins1) if $ins1;
397 0 0       0 push @defer,$line if !$d1;
398             } else {
399              
400             # handle end of block, dump out @defer and clear it
401              
402 0         0 push @out, ('*'x100),"\n", @defer;
403 0         0 undef @defer;
404 0         0 push @out, ('*'x20)."End of conflict ".$conflict.('*'x80)."\n";
405 0         0 $conflict_type = 0;
406             }
407             }
408 816 100       2899 last unless defined $line; # for end of file, don't want to push undef
409 808 100 100     4805 push @out, $line unless ($d1 eq '-' || $d2 eq '-') && !$conflict_type;
      100        
410             }
411 8         86 $pkg->new($out_title, undef, \@out);
412             }
413              
414 0     0     sub _error {};
415              
416             1;
417              
418             __END__