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__ |