1 | #------------------------------------------------------------------------------- |
---|
2 | # Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
3 | # |
---|
4 | # This file is part of FCM, tools for managing and building source code. |
---|
5 | # |
---|
6 | # FCM is free software: you can redistribute it and/or modify |
---|
7 | # it under the terms of the GNU General Public License as published by |
---|
8 | # the Free Software Foundation, either version 3 of the License, or |
---|
9 | # (at your option) any later version. |
---|
10 | # |
---|
11 | # FCM is distributed in the hope that it will be useful, |
---|
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | # GNU General Public License for more details. |
---|
15 | # |
---|
16 | # You should have received a copy of the GNU General Public License |
---|
17 | # along with FCM. If not, see <http://www.gnu.org/licenses/>. |
---|
18 | #------------------------------------------------------------------------------- |
---|
19 | use strict; |
---|
20 | use warnings; |
---|
21 | |
---|
22 | #------------------------------------------------------------------------------- |
---|
23 | package FCM::System::CM::SVN; |
---|
24 | use base qw{FCM::Class::CODE}; |
---|
25 | |
---|
26 | use Cwd qw{cwd}; |
---|
27 | use FCM::Context::Event; |
---|
28 | use FCM::Context::Locator; |
---|
29 | use FCM::System::Exception; |
---|
30 | use Memoize qw{memoize}; |
---|
31 | use File::Basename qw{dirname}; |
---|
32 | use File::Spec::Functions qw{catfile rel2abs}; |
---|
33 | use Time::Piece; |
---|
34 | use XML::Parser; |
---|
35 | |
---|
36 | my $E = 'FCM::System::Exception'; |
---|
37 | |
---|
38 | # Settings for the default repository layout |
---|
39 | our %LAYOUT_CONFIG = ( |
---|
40 | 'depth-project' => undef, |
---|
41 | 'depth-branch' => 3, |
---|
42 | 'depth-tag' => 1, |
---|
43 | 'dir-trunk' => 'trunk', |
---|
44 | 'dir-branch' => 'branches', |
---|
45 | 'dir-tag' => 'tags', |
---|
46 | 'level-owner-branch' => 2, |
---|
47 | 'level-owner-tag' => undef, |
---|
48 | 'owner' => undef, |
---|
49 | 'template-branch' => '{category}/{owner}/{name_prefix}{name}', |
---|
50 | 'template-tag' => undef, |
---|
51 | ); |
---|
52 | |
---|
53 | # Layout configuration file basename |
---|
54 | our $LAYOUT_CFG_BASE = 'svn-repos-layout.cfg'; |
---|
55 | |
---|
56 | # "svn log --xml" handlers. |
---|
57 | # -> element node start tag handlers |
---|
58 | my %SVN_LOG_ELEMENT_START_HANDLER_FOR = ( |
---|
59 | # tag => handler |
---|
60 | 'logentry' => \&_get_log_handle_element_enter_logentry, |
---|
61 | 'path' => \&_get_log_handle_element_enter_path, |
---|
62 | ); |
---|
63 | # -> text node (after a start tag) handlers |
---|
64 | my %SVN_LOG_TEXT_HANDLER_FOR = ( |
---|
65 | # tag => handler |
---|
66 | 'date' => \&_get_log_handle_text_date, |
---|
67 | 'path' => \&_get_log_handle_text_path, |
---|
68 | ); |
---|
69 | |
---|
70 | our $SUBVERSION_SERVERS_CONF = catfile((getpwuid($<))[7], qw{.subversion/servers}); |
---|
71 | |
---|
72 | my %ACTION_OF = ( |
---|
73 | 'call' => \&_call, |
---|
74 | 'get_info' => \&_get_info, |
---|
75 | 'get_layout' => \&_get_layout, |
---|
76 | 'get_layout_common' => \&_get_layout_common, |
---|
77 | 'get_list' => \&_get_list, |
---|
78 | 'get_log' => \&_get_log, |
---|
79 | 'get_username' => \&_get_username, |
---|
80 | 'get_wc_root' => \&_get_wc_root, |
---|
81 | 'load_layout_config' => \&_load_layout_config, |
---|
82 | 'split_by_peg' => \&_split_by_peg, |
---|
83 | 'stdout' => \&_stdout, |
---|
84 | ); |
---|
85 | |
---|
86 | # Creates the class. |
---|
87 | __PACKAGE__->class( |
---|
88 | { layout_cfg_base => {isa => '$', default => $LAYOUT_CFG_BASE}, |
---|
89 | layout_config_of=> '%', |
---|
90 | util => '&', |
---|
91 | }, |
---|
92 | {action_of => \%ACTION_OF}, |
---|
93 | ); |
---|
94 | |
---|
95 | # Calls "svn". |
---|
96 | sub _call { |
---|
97 | my ($attrib_ref, @args) = @_; |
---|
98 | my @command = ('svn', @args); |
---|
99 | my $timer = $attrib_ref->{util}->timer(); |
---|
100 | my $rc = system(@command); |
---|
101 | $attrib_ref->{util}->event( |
---|
102 | FCM::Context::Event->SHELL, \@command, $rc, $timer->()); |
---|
103 | if ($rc) { |
---|
104 | $rc = $? == -1 ? $! |
---|
105 | : $? & 127 ? $? & 127 |
---|
106 | : $? >> 8 |
---|
107 | ; |
---|
108 | return $E->throw($E->SHELL, {command_list => \@command, rc => $rc}); |
---|
109 | } |
---|
110 | return; |
---|
111 | } |
---|
112 | |
---|
113 | # Invokes "svn info --xml @paths", and returns a LIST of info entries. |
---|
114 | memoize('_get_info'); |
---|
115 | sub _get_info { |
---|
116 | my $attrib_ref = shift(); |
---|
117 | my %option = ('recursive' => undef, 'revision' => undef); |
---|
118 | if (@_ && ref($_[0]) && ref($_[0]) eq 'HASH') { |
---|
119 | %option = (%option, %{shift()}); |
---|
120 | } |
---|
121 | my @paths = @_; |
---|
122 | if (!@paths) { |
---|
123 | @paths = (q{.}); |
---|
124 | } |
---|
125 | my (@entries, @stack); |
---|
126 | my $parser = XML::Parser->new(Handlers => { |
---|
127 | 'Start' => sub {_get_info_handle_element_enter(\@entries, \@stack, @_)}, |
---|
128 | 'End' => sub {_get_info_handle_element_leave(\@entries, \@stack, @_)}, |
---|
129 | 'Char' => sub {_get_info_handle_text( \@entries, \@stack, @_)}, |
---|
130 | }); |
---|
131 | $parser->parse(scalar(_stdout( |
---|
132 | $attrib_ref, |
---|
133 | qw{svn info --xml}, |
---|
134 | ($option{'recursive'} ? '--recursive' : ()), |
---|
135 | ($option{'revision'} ? ('--revision', $option{'revision'}) : ()), |
---|
136 | @paths, |
---|
137 | ))); |
---|
138 | \@entries; |
---|
139 | } |
---|
140 | |
---|
141 | # Helper for _get_info. Handle the start tag of an XML element. |
---|
142 | sub _get_info_handle_element_enter { |
---|
143 | my ($entries_ref, $stack_ref, $expat, $tag, %attrib) = @_; |
---|
144 | # "entry": create a new entry in the list |
---|
145 | if ($tag eq 'entry') { |
---|
146 | push(@{$entries_ref}, {}); |
---|
147 | } |
---|
148 | # "tree-conflict:version": need to handle differently |
---|
149 | if ( $tag eq 'version' |
---|
150 | && @{$stack_ref} |
---|
151 | && $stack_ref->[-1] eq 'tree-conflict' |
---|
152 | ) { |
---|
153 | my (undef, undef, @names) = @{$stack_ref}; |
---|
154 | push(@names, delete($attrib{side})); |
---|
155 | while (my ($key, $value) = each(%attrib)) { |
---|
156 | my $name = join(':', @names, $key); |
---|
157 | $entries_ref->[-1]->{$name} = delete($attrib{$key}); |
---|
158 | } |
---|
159 | } |
---|
160 | # Add current tag to stack |
---|
161 | push(@{$stack_ref}, $tag); |
---|
162 | # Add attributes to current entry, if appropriate |
---|
163 | if (@{$entries_ref} && @{$stack_ref} >= 2 && %attrib) { |
---|
164 | my (undef, undef, @names) = @{$stack_ref}; |
---|
165 | while (my ($key, $value) = each(%attrib)) { |
---|
166 | my $name = join(':', @names, $key); |
---|
167 | $entries_ref->[-1]->{$name} = $value; |
---|
168 | } |
---|
169 | } |
---|
170 | } |
---|
171 | |
---|
172 | # Helper for _get_info. Handle the end tag of an XML element. |
---|
173 | sub _get_info_handle_element_leave { |
---|
174 | my ($entries_ref, $stack_ref, $expat, $tag) = @_; |
---|
175 | pop(@{$stack_ref}) eq $tag; |
---|
176 | } |
---|
177 | |
---|
178 | # Helper for _get_info. Handle an XML text node. |
---|
179 | sub _get_info_handle_text { |
---|
180 | my ($entries_ref, $stack_ref, $expat, $text) = @_; |
---|
181 | if (@{$stack_ref} <= 2 || !@{$entries_ref} || $text eq "\n") { |
---|
182 | return; |
---|
183 | } |
---|
184 | my (undef, undef, @names) = @{$stack_ref}; |
---|
185 | my $name = join(':', @names); |
---|
186 | $entries_ref->[-1]->{$name} .= $text; |
---|
187 | } |
---|
188 | |
---|
189 | # Return an object containing the repository layout information of a URL. |
---|
190 | sub _get_layout { |
---|
191 | my ($attrib_ref, $url_arg) = @_; |
---|
192 | my %info = %{_get_info($attrib_ref, $url_arg)->[0]}; |
---|
193 | my ($url, $root, $peg_rev) = @info{'url', 'repository:root', 'revision'}; |
---|
194 | my $path = substr($url, length($root)); |
---|
195 | my $layout = _get_layout_common($attrib_ref, $root, $peg_rev, $path); |
---|
196 | $layout->set_url($root . $path . '@' . $peg_rev); |
---|
197 | $layout->set_username(_get_username($attrib_ref, $root)); |
---|
198 | $layout; |
---|
199 | } |
---|
200 | |
---|
201 | # Return an object containing the repository layout information of a URL. |
---|
202 | sub _get_layout_common { |
---|
203 | my ($attrib_ref, $root, $rev, $path, $is_local) = @_; |
---|
204 | |
---|
205 | my %layout_config = _load_layout_config( |
---|
206 | $attrib_ref, ($is_local ? 'file://' . $root : $root), |
---|
207 | ); |
---|
208 | my ($project, $branch, $category, $owner, $sub_tree); |
---|
209 | my @names = split(qr{/+}msx, $path); |
---|
210 | shift(@names); # element 1 should be an empty string |
---|
211 | |
---|
212 | # Search for the project |
---|
213 | my $depth = $layout_config{'depth-project'}; |
---|
214 | if (defined($depth)) { |
---|
215 | if (@names >= $depth) { |
---|
216 | my @project_names = (); |
---|
217 | for (1 .. $layout_config{'depth-project'}) { |
---|
218 | push(@project_names, shift(@names)); |
---|
219 | } |
---|
220 | $project = join('/', @project_names); |
---|
221 | } |
---|
222 | } |
---|
223 | elsif (!grep {!defined($layout_config{"dir-$_"})} qw{trunk branch tag}) { |
---|
224 | # trunk, branches and tags are ALL in specific sub-directories under |
---|
225 | # the project |
---|
226 | my @dirs = map {$layout_config{"dir-$_"}} qw{trunk branch tag}; |
---|
227 | my @head = (); |
---|
228 | my @tail = @names; |
---|
229 | while (my $name = shift(@tail)) { |
---|
230 | if (grep {$_ eq $name} @dirs) { |
---|
231 | $project = join('/', @head); |
---|
232 | @names = ($name, @tail); |
---|
233 | last; |
---|
234 | } |
---|
235 | push(@head, $name); |
---|
236 | } |
---|
237 | if (!defined($project)) { |
---|
238 | # $path does not contain the specific sub-directories that |
---|
239 | # contain the trunk, branches and tags, but $path itself may be |
---|
240 | # the project |
---|
241 | my $target = $path . '/' . $layout_config{'dir-trunk'}; |
---|
242 | if (_verify_path($attrib_ref, $root, $rev, $target, $is_local)) { |
---|
243 | $project = join('/', @names); |
---|
244 | } |
---|
245 | @names = (); |
---|
246 | } |
---|
247 | } |
---|
248 | else { |
---|
249 | # Can only assume that trunk is in a specific sub-directory under the |
---|
250 | # project |
---|
251 | my @head = (); |
---|
252 | my @tail = @names; |
---|
253 | while (my $name = shift(@tail)) { |
---|
254 | if ($name eq $layout_config{'dir-trunk'}) { |
---|
255 | $project = join('/', @head); |
---|
256 | @names = ($name, @tail); |
---|
257 | last; |
---|
258 | } |
---|
259 | push(@head, $name); |
---|
260 | } |
---|
261 | if (!defined($project)) { |
---|
262 | # $path does not contain the trunk sub-directory, need to search |
---|
263 | # for it |
---|
264 | my @head = (); |
---|
265 | my @tail = @names; |
---|
266 | while (@head <= @names) { |
---|
267 | my $target = join('/', @head, $layout_config{'dir-trunk'}); |
---|
268 | if (_verify_path($attrib_ref, $root, $rev, $target, $is_local)) { |
---|
269 | $project = join('/', @head); |
---|
270 | @names = @tail; |
---|
271 | last; |
---|
272 | } |
---|
273 | push(@head, shift(@tail)); |
---|
274 | } |
---|
275 | } |
---|
276 | } |
---|
277 | |
---|
278 | # Search for the branch |
---|
279 | if (defined($project) && @names) { |
---|
280 | KEY: |
---|
281 | for my $key (qw{trunk branch tag}) { |
---|
282 | my @branch_names; |
---|
283 | if ($layout_config{"dir-$key"}) { |
---|
284 | if ($names[0] eq $layout_config{"dir-$key"}) { |
---|
285 | @branch_names = (shift(@names)); |
---|
286 | } |
---|
287 | else { |
---|
288 | next KEY; |
---|
289 | } |
---|
290 | } |
---|
291 | my $depth = $layout_config{"depth-$key"} |
---|
292 | ? $layout_config{"depth-$key"} : 0; |
---|
293 | if (@names >= $depth) { |
---|
294 | for my $i (1 .. $depth) { |
---|
295 | my $name = shift(@names); |
---|
296 | push(@branch_names, $name); |
---|
297 | if ( $layout_config{"level-owner-$key"} |
---|
298 | && $layout_config{"level-owner-$key"} == $i |
---|
299 | ) { |
---|
300 | $owner = $name; |
---|
301 | } |
---|
302 | } |
---|
303 | $branch = join('/', @branch_names); |
---|
304 | $category = $key; |
---|
305 | } |
---|
306 | last KEY; |
---|
307 | } |
---|
308 | } |
---|
309 | # Remainder is the sub-tree under the branch |
---|
310 | if (defined($branch)) { |
---|
311 | $sub_tree = join('/', @names); |
---|
312 | } |
---|
313 | FCM::System::CM::SVN::Layout->new({ |
---|
314 | config => \%layout_config, |
---|
315 | root => $root, |
---|
316 | path => $path, |
---|
317 | peg_rev => $rev, |
---|
318 | project => $project, |
---|
319 | branch => $branch, |
---|
320 | branch_category => $category, |
---|
321 | branch_owner => $owner, |
---|
322 | sub_tree => $sub_tree, |
---|
323 | }); |
---|
324 | } |
---|
325 | |
---|
326 | # Return a (filtered) recursive listing of $url_arg. |
---|
327 | sub _get_list { |
---|
328 | my ($attrib_ref, $url_arg, $filter_func) = @_; |
---|
329 | my @list; |
---|
330 | my ($url0, $rev) = _split_by_peg($attrib_ref, $url_arg); |
---|
331 | my @items = ([$url0, 0]); |
---|
332 | while (my $item = shift(@items)) { |
---|
333 | my ($url, $depth) = @{$item}; |
---|
334 | ++$depth; |
---|
335 | my @lines = _stdout($attrib_ref, qw{svn list}, $url . '@' . $rev); |
---|
336 | for my $line (@lines) { |
---|
337 | my ($this_name, $is_dir) = $line =~ qr{\A(.*?)(/?)\z}; |
---|
338 | my $this_url = $url . '/' . $this_name ; |
---|
339 | my ($can_return, $can_recurse) = (1, $is_dir); |
---|
340 | if (defined($filter_func)) { |
---|
341 | ($can_return, $can_recurse) |
---|
342 | = $filter_func->($this_url, $this_name, $is_dir, $depth); |
---|
343 | } |
---|
344 | if ($can_return) { |
---|
345 | push(@list, $this_url . '@' . $rev); |
---|
346 | } |
---|
347 | if ($can_recurse && $is_dir) { |
---|
348 | push(@items, [$this_url, $depth]); |
---|
349 | } |
---|
350 | } |
---|
351 | } |
---|
352 | @list; |
---|
353 | } |
---|
354 | |
---|
355 | # Invokes "svn log --xml". |
---|
356 | sub _get_log { |
---|
357 | my $attrib_ref = shift(); |
---|
358 | my %option = ('revision' => undef, 'stop-on-copy' => undef); |
---|
359 | if (@_ && ref($_[0]) && ref($_[0]) eq 'HASH') { |
---|
360 | %option = (%option, %{shift()}); |
---|
361 | } |
---|
362 | my @paths = @_; |
---|
363 | if (!@paths) { |
---|
364 | @paths = (q{.}); |
---|
365 | } |
---|
366 | my (@entries, @stack); |
---|
367 | my $parser = XML::Parser->new(Handlers => { |
---|
368 | 'Start' => sub {_get_log_handle_element_enter(\@entries, \@stack, @_)}, |
---|
369 | 'End' => sub {_get_log_handle_element_leave(\@entries, \@stack, @_)}, |
---|
370 | 'Char' => sub {_get_log_handle_text( \@entries, \@stack, @_)}, |
---|
371 | }); |
---|
372 | $parser->parse(scalar(_stdout( |
---|
373 | $attrib_ref, |
---|
374 | qw{svn log --xml -v}, |
---|
375 | ($option{'revision'} ? ('--revision', $option{'revision'}) : ()), |
---|
376 | ($option{'stop-on-copy'} ? ('--stop-on-copy') : ()), |
---|
377 | @paths, |
---|
378 | ))); |
---|
379 | \@entries; |
---|
380 | } |
---|
381 | |
---|
382 | # Helper for "_get_log", handle beginning of an XML element. |
---|
383 | sub _get_log_handle_element_enter { |
---|
384 | my ($entries_ref, $stack_ref, $expat, $tag, %attrib) = @_; |
---|
385 | push(@{$stack_ref}, $tag); |
---|
386 | if (exists($SVN_LOG_ELEMENT_START_HANDLER_FOR{$tag})) { |
---|
387 | $SVN_LOG_ELEMENT_START_HANDLER_FOR{$tag}->( |
---|
388 | $entries_ref, |
---|
389 | $tag, |
---|
390 | %attrib, |
---|
391 | ); |
---|
392 | } |
---|
393 | } |
---|
394 | |
---|
395 | # Helper for "_get_log", handle beginning of the "logentry" element. |
---|
396 | sub _get_log_handle_element_enter_logentry { |
---|
397 | my ($entries_ref, $tag, %attrib) = @_; |
---|
398 | push( |
---|
399 | @{$entries_ref}, |
---|
400 | { 'author' => q{}, |
---|
401 | 'date' => q{}, |
---|
402 | 'msg' => q{}, |
---|
403 | 'paths' => [], |
---|
404 | 'revision' => $attrib{'revision'}, |
---|
405 | }, |
---|
406 | ); |
---|
407 | } |
---|
408 | |
---|
409 | # Helper for "_get_log", handle beginning of the "path" element. |
---|
410 | sub _get_log_handle_element_enter_path { |
---|
411 | my ($entries_ref, $tag, %attrib) = @_; |
---|
412 | push(@{$entries_ref->[-1]->{'paths'}}, {%attrib, 'path' => q{}}); |
---|
413 | } |
---|
414 | |
---|
415 | # Helper for "_get_log", handle end of an element. |
---|
416 | sub _get_log_handle_element_leave { |
---|
417 | my ($entries_ref, $stack_ref, $expat, $tag) = @_; |
---|
418 | pop(@{$stack_ref}) eq $tag; |
---|
419 | } |
---|
420 | |
---|
421 | # Helper for "_get_log", handle text node. |
---|
422 | sub _get_log_handle_text { |
---|
423 | my ($entries_ref, $stack_ref, $expat, $text) = @_; |
---|
424 | if (!exists($stack_ref->[-1])) { |
---|
425 | return; |
---|
426 | } |
---|
427 | if (exists($SVN_LOG_TEXT_HANDLER_FOR{$stack_ref->[-1]})) { |
---|
428 | $SVN_LOG_TEXT_HANDLER_FOR{$stack_ref->[-1]}->($entries_ref, $text); |
---|
429 | } |
---|
430 | elsif ( @{$entries_ref} |
---|
431 | && exists($entries_ref->[-1]->{$stack_ref->[-1]}) |
---|
432 | && !ref($entries_ref->[-1]->{$stack_ref->[-1]}) |
---|
433 | ) { |
---|
434 | $entries_ref->[-1]->{$stack_ref->[-1]} .= $text; |
---|
435 | } |
---|
436 | } |
---|
437 | |
---|
438 | # Helper for "_get_log", handle text node in a "date" element. |
---|
439 | sub _get_log_handle_text_date { |
---|
440 | my ($entries_ref, $text) = @_; |
---|
441 | # "svn log --xml" may return a date with trailing spaces! |
---|
442 | $text =~ s{\s+\z}{}gmsx; |
---|
443 | my $head = Time::Piece->strptime(substr($text, 0, -8), '%Y-%m-%dT%H:%M:%S'); |
---|
444 | my $tail = substr($text, -8, -1); |
---|
445 | $entries_ref->[-1]->{'date'} = $head->epoch() + $tail; |
---|
446 | } |
---|
447 | |
---|
448 | # Helper for "_get_log", handle text node in a "path" element. |
---|
449 | sub _get_log_handle_text_path { |
---|
450 | my ($entries_ref, $text) = @_; |
---|
451 | $entries_ref->[-1]->{'paths'}->[-1]->{'path'} .= $text; |
---|
452 | } |
---|
453 | |
---|
454 | # Return the username of the host of a given target URL. |
---|
455 | memoize('_get_username'); |
---|
456 | sub _get_username { |
---|
457 | my ($attrib_ref, $target) = @_; |
---|
458 | my ($scheme, $sps) = $attrib_ref->{util}->uri_match($target); |
---|
459 | my ($host) = $sps =~ qr{\A//([^/]+)(?:/|\z)}msx; |
---|
460 | # Note: can use Config::IniFiles, but best to avoid another dependency. |
---|
461 | # Note: not very efficient logic here, but should not yet matter. |
---|
462 | my $subversion_servers_conf = exists($ENV{'FCM_SUBVERSION_SERVERS_CONF'}) |
---|
463 | ? $ENV{'FCM_SUBVERSION_SERVERS_CONF'} : $SUBVERSION_SERVERS_CONF; |
---|
464 | my $handle |
---|
465 | = $attrib_ref->{'util'}->file_load_handle($subversion_servers_conf); |
---|
466 | my $is_in_section; |
---|
467 | my $group; |
---|
468 | LINE: |
---|
469 | while (my $line = readline($handle)) { |
---|
470 | chomp($line); |
---|
471 | if ($line =~ qr{\A\s*(?:[#;]|\z)}msx) { |
---|
472 | next LINE; |
---|
473 | } |
---|
474 | if ($line =~ qr{\A\s*\[\s*groups\s*\]\s*\z}msx) { |
---|
475 | $is_in_section = 1; |
---|
476 | } |
---|
477 | elsif ($line =~ qr{\A\s*\[}msx) { |
---|
478 | $is_in_section = 0; |
---|
479 | } |
---|
480 | elsif ($is_in_section) { |
---|
481 | my ($lhs, $rhs) = $line =~ qr{\A\s*(\S+)\s*=\s*(\S+)\s*\z}msx; |
---|
482 | if ($rhs) { |
---|
483 | $rhs =~ s{[.]}{\\.}gmsx; |
---|
484 | $rhs =~ s{[*]}{.*}gmsx; |
---|
485 | $rhs =~ s{[?]}{.?}gmsx; |
---|
486 | if ($host && $host =~ qr{\A$rhs\z}msx) { |
---|
487 | $group = $lhs; |
---|
488 | last LINE; |
---|
489 | } |
---|
490 | } |
---|
491 | } |
---|
492 | } |
---|
493 | my $username = scalar(getpwuid($<)); # current user ID |
---|
494 | if ($group) { |
---|
495 | seek($handle, 0, 0); |
---|
496 | LINE: |
---|
497 | while (my $line = readline($handle)) { |
---|
498 | chomp($line); |
---|
499 | if ($line =~ qr{\A\s*(?:[#;]|\z)}msx) { |
---|
500 | next LINE; |
---|
501 | } |
---|
502 | if ($line =~ qr{\A\s*\[\s*$group\s*\]\s*\z}msx) { |
---|
503 | $is_in_section = 1; |
---|
504 | } |
---|
505 | elsif ($line =~ qr{\A\s*\[}msx) { |
---|
506 | $is_in_section = 0; |
---|
507 | } |
---|
508 | elsif ($is_in_section) { |
---|
509 | my ($rhs) = $line =~ qr{\A\s*username\s*=\s*(\S+)\s*\z}msx; |
---|
510 | if ($rhs) { |
---|
511 | $username = $rhs; |
---|
512 | last LINE; |
---|
513 | } |
---|
514 | } |
---|
515 | } |
---|
516 | } |
---|
517 | close($handle); |
---|
518 | return $username; |
---|
519 | } |
---|
520 | |
---|
521 | # Return path to the root working copy directory of the argument. |
---|
522 | sub _get_wc_root { |
---|
523 | my ($attrib_ref, $path) = @_; |
---|
524 | $path ||= cwd(); |
---|
525 | my ($entries_ref) = _get_info($attrib_ref, $path); |
---|
526 | if ( defined($entries_ref) |
---|
527 | && @{$entries_ref} |
---|
528 | && exists($entries_ref->[0]->{'wc-info:wcroot-abspath'}) |
---|
529 | ) { |
---|
530 | return $entries_ref->[0]->{'wc-info:wcroot-abspath'}; |
---|
531 | } |
---|
532 | if (-f $path) { |
---|
533 | $path = dirname($path); |
---|
534 | } |
---|
535 | $path = rel2abs($path); |
---|
536 | my $return; |
---|
537 | if (-e catfile($path, qw{.svn entries})) { |
---|
538 | while ( -e catfile($path, qw{.svn entries}) |
---|
539 | && $path ne dirname($path) |
---|
540 | ) { |
---|
541 | $return = $path; |
---|
542 | $path = dirname($path); |
---|
543 | } |
---|
544 | } |
---|
545 | else { |
---|
546 | while ( !-e catfile($path, qw{.svn entries}) |
---|
547 | && $path ne dirname($path) |
---|
548 | ) { |
---|
549 | $path = dirname($path); |
---|
550 | $return = $path; |
---|
551 | } |
---|
552 | } |
---|
553 | return $return; |
---|
554 | } |
---|
555 | |
---|
556 | # Load layout related configuration for a given URL root. |
---|
557 | memoize('_load_layout_config'); |
---|
558 | sub _load_layout_config { |
---|
559 | my ($attrib_ref, $root) = @_; |
---|
560 | if (exists($attrib_ref->{layout_config_of}{$root})) { |
---|
561 | return %{$attrib_ref->{layout_config_of}{$root}}; |
---|
562 | } |
---|
563 | my %site_layout_config; |
---|
564 | if (exists($attrib_ref->{layout_config_of}{q{}})) { |
---|
565 | %site_layout_config = %{$attrib_ref->{layout_config_of}{q{}}}; |
---|
566 | } |
---|
567 | else { |
---|
568 | %site_layout_config = %LAYOUT_CONFIG; |
---|
569 | $attrib_ref->{util}->cfg_init( |
---|
570 | $attrib_ref->{layout_cfg_base}, |
---|
571 | sub { |
---|
572 | my $config_reader = shift(); |
---|
573 | my @unknown_entries; |
---|
574 | while (defined(my $entry = $config_reader->())) { |
---|
575 | if (exists($site_layout_config{$entry->get_label()})) { |
---|
576 | my $value |
---|
577 | = $entry->get_value() ? $entry->get_value() : undef; |
---|
578 | $site_layout_config{$entry->get_label()} = $value; |
---|
579 | } |
---|
580 | else { |
---|
581 | push(@unknown_entries, $entry); |
---|
582 | } |
---|
583 | } |
---|
584 | if (@unknown_entries) { |
---|
585 | return $E->throw($E->CONFIG_UNKNOWN, \@unknown_entries); |
---|
586 | } |
---|
587 | }, |
---|
588 | ); |
---|
589 | $attrib_ref->{layout_config_of}{q{}} = {%site_layout_config}; |
---|
590 | } |
---|
591 | $attrib_ref->{layout_config_of}{$root} = {%site_layout_config}; |
---|
592 | my @prop_lines = eval { |
---|
593 | _stdout($attrib_ref, qw{svn propget fcm:layout}, $root); |
---|
594 | }; |
---|
595 | if ($@) { |
---|
596 | $@ = undef; |
---|
597 | } |
---|
598 | PROP_LINE: |
---|
599 | while (defined(my $prop_line = shift(@prop_lines))) { |
---|
600 | chomp($prop_line); |
---|
601 | if ($prop_line =~ qr{\A\s*(?:\#|\z)}msx) { # comment line |
---|
602 | next PROP_LINE; |
---|
603 | } |
---|
604 | ($prop_line) = $prop_line =~ qr{\A\s*(.+?)\s*\z}msx; # trim |
---|
605 | my ($key, $value) = split(qr{\s*=\s*}msx, $prop_line, 2); |
---|
606 | if (exists($attrib_ref->{layout_config_of}{$root}{$key})) { |
---|
607 | $attrib_ref->{layout_config_of}{$root}{$key} = $value; |
---|
608 | } |
---|
609 | } |
---|
610 | %{$attrib_ref->{layout_config_of}{$root}}; |
---|
611 | } |
---|
612 | |
---|
613 | # Splits a URL@REV by the @. |
---|
614 | sub _split_by_peg { |
---|
615 | my ($attrib_ref, $url) = @_; |
---|
616 | $url =~ qr{\A(.*?)(?:@([^@/]+))?\z}msx; |
---|
617 | } |
---|
618 | |
---|
619 | # Calls "svn", return its standard output. |
---|
620 | sub _stdout { |
---|
621 | my ($attrib_ref, @command) = @_; |
---|
622 | my %value_of = %{$attrib_ref->{util}->shell_simple(\@command)}; |
---|
623 | if ($value_of{rc}) { |
---|
624 | return $E->throw( |
---|
625 | $E->SHELL, |
---|
626 | {command_list => \@command, %value_of}, |
---|
627 | $value_of{e} |
---|
628 | ); |
---|
629 | } |
---|
630 | wantarray() ? split("\n", $value_of{o}) : $value_of{o}; |
---|
631 | } |
---|
632 | |
---|
633 | # Return true if $path is in $repos for this $rev |
---|
634 | sub _verify_path { |
---|
635 | my ($attrib_ref, $root, $rev, $path, $is_local) = @_; |
---|
636 | if ($is_local) { |
---|
637 | my $opt = $rev =~ qr{\A\d+\z}msx ? '-r' : '-t'; |
---|
638 | eval { |
---|
639 | _stdout($attrib_ref, qw{svnlook tree -N}, $opt, $rev, $root, $path); |
---|
640 | }; |
---|
641 | if ($@) { |
---|
642 | $@ = q{}; |
---|
643 | return; |
---|
644 | } |
---|
645 | return ($root, $rev, $path); |
---|
646 | } |
---|
647 | else { |
---|
648 | my $target = $root . '/' . $path . '@' . $rev; |
---|
649 | my $url = eval {_get_info($attrib_ref, $target)->[0]->{url}}; |
---|
650 | if ($@ || !$url) { |
---|
651 | $@ = q{}; |
---|
652 | return; |
---|
653 | } |
---|
654 | return ($root, $rev, $path); |
---|
655 | } |
---|
656 | } |
---|
657 | |
---|
658 | #------------------------------------------------------------------------------- |
---|
659 | # Represent the layout information of a Subversion URL. |
---|
660 | package FCM::System::CM::SVN::Layout; |
---|
661 | use base qw{FCM::Class::HASH}; |
---|
662 | |
---|
663 | __PACKAGE__->class({ |
---|
664 | config => '%', |
---|
665 | url => '$', |
---|
666 | root => '$', |
---|
667 | path => '$', |
---|
668 | peg_rev => '$', |
---|
669 | project => '$', |
---|
670 | branch => '$', |
---|
671 | branch_category => '$', |
---|
672 | branch_owner => '$', |
---|
673 | sub_tree => '$', |
---|
674 | username => {isa => '$', default => scalar(getpwuid($<))}, |
---|
675 | }); |
---|
676 | |
---|
677 | sub is_trunk { |
---|
678 | $_[0]->{branch_category} && $_[0]->{branch_category} eq 'trunk'; |
---|
679 | } |
---|
680 | |
---|
681 | sub is_branch { |
---|
682 | $_[0]->{branch_category} && $_[0]->{branch_category} eq 'branch'; |
---|
683 | } |
---|
684 | |
---|
685 | sub is_tag { |
---|
686 | $_[0]->{branch_category} && $_[0]->{branch_category} eq 'tag'; |
---|
687 | } |
---|
688 | |
---|
689 | sub is_owned_by_user { |
---|
690 | my ($self, $user) = @_; |
---|
691 | $user ||= $self->get_username(); |
---|
692 | $self->{branch_owner} && $self->{branch_owner} eq $user; |
---|
693 | } |
---|
694 | |
---|
695 | sub is_shared { |
---|
696 | my ($self) = @_; |
---|
697 | $self->{branch_owner} |
---|
698 | && grep {$_ eq $self->{branch_owner}} qw{Share Config Rel}; |
---|
699 | } |
---|
700 | |
---|
701 | sub as_string { |
---|
702 | my ($self) = @_; |
---|
703 | my $return = q{}; |
---|
704 | for my $key (qw{ |
---|
705 | url |
---|
706 | root |
---|
707 | path |
---|
708 | peg_rev |
---|
709 | project |
---|
710 | branch |
---|
711 | branch_category |
---|
712 | branch_owner |
---|
713 | sub_tree |
---|
714 | }) { |
---|
715 | my $value = $self->{$key}; |
---|
716 | if ($key ne 'config' && defined($value)) { |
---|
717 | $return .= "$key: $value\n"; |
---|
718 | } |
---|
719 | } |
---|
720 | return $return; |
---|
721 | } |
---|
722 | |
---|
723 | 1; |
---|
724 | __END__ |
---|
725 | |
---|
726 | =head1 NAME |
---|
727 | |
---|
728 | FCM::System::CM::SVN |
---|
729 | |
---|
730 | =head1 DESCRIPTION |
---|
731 | |
---|
732 | Part of L<FCM::System::CM|FCM::System::CM>. Provides an interface for common SVN |
---|
733 | functionalities used in the FCM CM sub-system. |
---|
734 | |
---|
735 | =head1 METHODS |
---|
736 | |
---|
737 | This is a sub-class of L<FCM::Class::CODE|FCM::Class::CODE>. |
---|
738 | |
---|
739 | =over 4 |
---|
740 | |
---|
741 | =item $class->new(\%attrib) |
---|
742 | |
---|
743 | Return a new instance of this class. %attrib accepts a single "util" key for an |
---|
744 | instance of an L<FCM::Util|FCM::Util> object. |
---|
745 | |
---|
746 | =item $instance->call(@args) |
---|
747 | |
---|
748 | Call the command line "svn" with a list of arguments in @args. |
---|
749 | |
---|
750 | =item $instance->get_info(@path) |
---|
751 | =item $instance->get_info(\%option, @path) |
---|
752 | |
---|
753 | Invokes "svn info --xml @paths", and returns a LIST of info entries. If @paths |
---|
754 | is not specified, use ("."). If %option is specified, it may contain the keys: |
---|
755 | |
---|
756 | =over 4 |
---|
757 | |
---|
758 | =item recursive |
---|
759 | |
---|
760 | If value of this key is not undef, add --recursive to "svn info". |
---|
761 | |
---|
762 | =item revision |
---|
763 | |
---|
764 | If value of this key is not undef, add --revision VALUE to "svn info". |
---|
765 | |
---|
766 | =back |
---|
767 | |
---|
768 | Each info entry is a HASH with keys reflecting the tag or attribute name in an |
---|
769 | entry element. The original hierarchy below the entry element is delimited by a |
---|
770 | colon in the name. For example, a return structure may look like this: |
---|
771 | [ { 'commit:author' => 'fred', |
---|
772 | 'commit:date' => '2011-11-09T15:41:14.514665Z', |
---|
773 | 'commit:revision' => '4549', |
---|
774 | 'kind' => 'dir', |
---|
775 | 'path' => 'trunk', |
---|
776 | 'revision' => '4552', |
---|
777 | 'repository:root' => 'svn://host/my-repos', |
---|
778 | 'repository:uuid' => '91f685bf-fbee-0310-99e6-f3aa9e660bd5' |
---|
779 | 'url' => 'svn://host/my-repos/FCM/trunk', |
---|
780 | }, |
---|
781 | ] |
---|
782 | |
---|
783 | =item $instance->get_layout($url) |
---|
784 | |
---|
785 | Return an instance of L<FCM::System::CM::SVN::Layout|/FCM::System::CM::SVN::Layout> |
---|
786 | containing the repository layout information of $url. |
---|
787 | |
---|
788 | =item $instance->get_layout_common($root, $rev, $path, $is_local) |
---|
789 | |
---|
790 | Return an instance of L<FCM::System::CM::SVN::Layout|/FCM::System::CM::SVN::Layout> |
---|
791 | containing the repository layout information for $path in $root at $rev. If |
---|
792 | $is_local is true, use "svnlook" to verify the existence of $path in $root |
---|
793 | at $rev. Otherwise, it uses "svn info" instead. If $rev is assumed to be a |
---|
794 | transaction if it is not numeric. |
---|
795 | |
---|
796 | =item $instance->get_list($url_arg, $filter_func) |
---|
797 | |
---|
798 | Call "svn list" multiple times to obtain a recursive listing of files and |
---|
799 | directories under $url_arg. Return a list containing the listing. If |
---|
800 | $filter_func is defined, it should be a CODE reference, which would be invoked |
---|
801 | for each file/directory found. It should have the interface: |
---|
802 | |
---|
803 | ($can_return, $can_recurse) |
---|
804 | = $filter_func->($this_url, $this_name, $is_dir, $depth); |
---|
805 | |
---|
806 | where $this_url is the URL of the file/directory found, $this_name is the |
---|
807 | base name of the file/directory found, $is_dir is true if it is a directory, |
---|
808 | $depth is the directory depth of $this_url relative to $url_arg. |
---|
809 | |
---|
810 | The $filter_func CODE reference should return a 2-element list ($can_return, |
---|
811 | $can_recurse). The get_list method will only return $this_url in the listing |
---|
812 | if $can_return is set to true. If $is_dir is true and $can_recurse is true, the |
---|
813 | get_list method will go down to do more listing in $this_url. |
---|
814 | |
---|
815 | =item $instance->get_log(@path) |
---|
816 | =item $instance->get_log(\%option, @path) |
---|
817 | |
---|
818 | Invokes "svn log --xml". If @paths is not specified, use ("."). If %option is |
---|
819 | specified, it may contain the keys: |
---|
820 | |
---|
821 | =over 4 |
---|
822 | |
---|
823 | =item revision |
---|
824 | |
---|
825 | If value of this key is not undef, add --revision VALUE to "svn log". |
---|
826 | |
---|
827 | =item stop-on-copy |
---|
828 | |
---|
829 | If value of this key is not undef, add --stop-on-copy to "svn log". |
---|
830 | |
---|
831 | =back |
---|
832 | |
---|
833 | Returns an ARRAY reference. Each element is a data structure that represents a |
---|
834 | log entry. The data structure should look like: |
---|
835 | [ { 'author' => $author, |
---|
836 | 'date' => $date, # seconds since epoch |
---|
837 | 'msg' => $msg, |
---|
838 | 'paths' => [ |
---|
839 | { 'path' => $path, |
---|
840 | 'action' => $action, |
---|
841 | 'copyfrom-path' => $p, |
---|
842 | 'copyfrom-rev' => $r, |
---|
843 | }, |
---|
844 | # ... |
---|
845 | ], |
---|
846 | 'revision' => $revision, |
---|
847 | }, |
---|
848 | ] |
---|
849 | |
---|
850 | =item $instance->get_username($target) |
---|
851 | |
---|
852 | Return the user name associated with $target. |
---|
853 | |
---|
854 | =item $instance->get_wc_root($path) |
---|
855 | |
---|
856 | Return the path to the root working copy directory of the argument. |
---|
857 | |
---|
858 | =item $instance->load_layout_config($root) |
---|
859 | |
---|
860 | Return a HASH (not a reference) containing the layout configuration of $root. |
---|
861 | See %LAYOUT_CONFIG for default settings. $root should be the URL to a |
---|
862 | repository root. |
---|
863 | |
---|
864 | =item $instance->split_by_peg($location) |
---|
865 | |
---|
866 | Split a location string (either a URL@PEG or a PATH@PEG) and return a |
---|
867 | two-element list: either (URL, PEG) or (PATH, PEG). |
---|
868 | |
---|
869 | =item $instance->stdout(@command) |
---|
870 | |
---|
871 | Call a @command, capture and return the STDOUT on success. In scalar context, |
---|
872 | return the STDOUT as-is. In array context, return it as a list of lines with the |
---|
873 | new line characters removed. |
---|
874 | |
---|
875 | =back |
---|
876 | |
---|
877 | =head1 EXCEPTION |
---|
878 | |
---|
879 | Methods in this class may throw an |
---|
880 | L<FCM::System::Exception|FCM::System::Exception> on error. |
---|
881 | |
---|
882 | =head1 FCM::System::CM::SVN::Layout |
---|
883 | |
---|
884 | The FCM::System::CM::SVN::Layout class inherits from |
---|
885 | L<FCM::Class::HASH|FCM::Class::HASH>. An instance represents the layout |
---|
886 | information in a Subversion URL based on the default or specified FCM layout |
---|
887 | information. It has the following attributes: |
---|
888 | |
---|
889 | =over 4 |
---|
890 | |
---|
891 | =item config |
---|
892 | |
---|
893 | is a HASH containing the layout configuration applied to this URL. |
---|
894 | Valid keys and their default values are: |
---|
895 | |
---|
896 | =over 4 |
---|
897 | |
---|
898 | =item depth-project => undef |
---|
899 | Number of sub-directories used by the name of a project. |
---|
900 | |
---|
901 | =item depth-branch => 3 |
---|
902 | Number of sub-directories (under "branches") used by the name of branch. |
---|
903 | |
---|
904 | =item depth-tag => 1 |
---|
905 | Number of sub-directories (under "tags") used by the name of branch. |
---|
906 | |
---|
907 | =item dir-trunk => 'trunk' |
---|
908 | Name of the master/trunk directory. |
---|
909 | |
---|
910 | =item dir-branch => 'branches' |
---|
911 | Name of the directory where all branches live. May be empty. |
---|
912 | |
---|
913 | =item dir-tag => 'tags' |
---|
914 | Name of the directory where all tags live. May be empty. |
---|
915 | |
---|
916 | =item level-owner-branch => 2 |
---|
917 | Sub-directory level in the name of a branch containing the its owner. |
---|
918 | |
---|
919 | =item level-owner-branch => undef |
---|
920 | Sub-directory level in the name of a tag containing the its owner. |
---|
921 | |
---|
922 | =item template-branch => '{category}/{owner}/{name_prefix}{name}' |
---|
923 | Branch name template. |
---|
924 | |
---|
925 | =item template-tag => undef |
---|
926 | Tag name template. |
---|
927 | |
---|
928 | =back |
---|
929 | |
---|
930 | =item url |
---|
931 | |
---|
932 | is the full URL@PEG. |
---|
933 | |
---|
934 | =item root |
---|
935 | |
---|
936 | is the repository root. |
---|
937 | |
---|
938 | =item path |
---|
939 | |
---|
940 | is the path below the repository root. |
---|
941 | |
---|
942 | =item peg_rev |
---|
943 | |
---|
944 | is the (peg) revision of the URL. |
---|
945 | |
---|
946 | =item project |
---|
947 | |
---|
948 | is the project name in the URL. It is undef if the URL does not contain a valid |
---|
949 | project name for the given repository. An empty string is possible, for example, |
---|
950 | if the layout means that the trunk is at the root level. |
---|
951 | |
---|
952 | =item branch |
---|
953 | |
---|
954 | is the "branch" name in the URL, (which may be the name of the master/trunk |
---|
955 | branch or the name of a tag). It is undef if the URL does not contain a valid |
---|
956 | branch name for the given repository. |
---|
957 | |
---|
958 | =item branch_category |
---|
959 | |
---|
960 | is the category (i.e. "trunk", "branch" or "tag") of the branch. |
---|
961 | |
---|
962 | =item branch_owner |
---|
963 | |
---|
964 | is the owner of the branch, if it can be derived from the URL. |
---|
965 | |
---|
966 | =item sub_tree |
---|
967 | |
---|
968 | is the path in the URL under the branch of a project tree. It is undef if the |
---|
969 | URL is not at or below the level of a branch of the project tree. An empty |
---|
970 | string means the that the URL is at root level of the project tree. |
---|
971 | |
---|
972 | =back |
---|
973 | |
---|
974 | An FCM::System::CM::SVN::Layout instance has the following convenient methods: |
---|
975 | |
---|
976 | =over 4 |
---|
977 | |
---|
978 | =item $layout->is_trunk() |
---|
979 | |
---|
980 | The URL is in the trunk of a project. |
---|
981 | |
---|
982 | =item $layout->is_branch() |
---|
983 | |
---|
984 | The URL is in a branch of a project. |
---|
985 | |
---|
986 | =item $layout->is_tag() |
---|
987 | |
---|
988 | The URL is in a tag of a project. |
---|
989 | |
---|
990 | =item $layout->is_owned_by_user($user) |
---|
991 | |
---|
992 | The URL is in a branch owned by $user. If $user is not defined, it defaults to |
---|
993 | the current user ID. |
---|
994 | |
---|
995 | =item $layout->is_shared() |
---|
996 | |
---|
997 | The URL is in a shared branch. |
---|
998 | |
---|
999 | =back |
---|
1000 | |
---|
1001 | =head1 COPYRIGHT |
---|
1002 | |
---|
1003 | Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
1004 | |
---|
1005 | =cut |
---|