New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
SVN.pm in vendors/lib/FCM/System/CM – NEMO

source: vendors/lib/FCM/System/CM/SVN.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing
File size: 30.5 KB
Line 
1#-------------------------------------------------------------------------------
2# (C) British Crown Copyright 2006-17 Met Office.
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#-------------------------------------------------------------------------------
19use strict;
20use warnings;
21
22#-------------------------------------------------------------------------------
23package FCM::System::CM::SVN;
24use base qw{FCM::Class::CODE};
25
26use Cwd qw{cwd};
27use FCM::Context::Event;
28use FCM::Context::Locator;
29use FCM::System::Exception;
30use Memoize qw{memoize};
31use File::Basename qw{dirname};
32use File::Spec::Functions qw{catfile rel2abs};
33use Time::Piece;
34use XML::Parser;
35
36my $E = 'FCM::System::Exception';
37
38# Settings for the default repository layout
39our %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
54our $LAYOUT_CFG_BASE = 'svn-repos-layout.cfg';
55
56# "svn log --xml" handlers.
57# -> element node start tag handlers
58my %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
64my %SVN_LOG_TEXT_HANDLER_FOR = (
65#   tag    => handler
66    'date' => \&_get_log_handle_text_date,
67    'path' => \&_get_log_handle_text_path,
68);
69
70our $SUBVERSION_SERVERS_CONF = catfile((getpwuid($<))[7], qw{.subversion/servers});
71
72my %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".
96sub _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.
114memoize('_get_info');
115sub _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.
142sub _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.
173sub _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.
179sub _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.
190sub _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.
202sub _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.
327sub _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".
356sub _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.
383sub _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.
396sub _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.
410sub _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.
416sub _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.
422sub _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.
439sub _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.
449sub _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.
455memoize('_get_username');
456sub _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.
522sub _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.
557memoize('_load_layout_config');
558sub _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 @.
614sub _split_by_peg {
615    my ($attrib_ref, $url) = @_;
616    $url =~ qr{\A(.*?)(?:@([^@/]+))?\z}msx;
617}
618
619# Calls "svn", return its standard output.
620sub _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
634sub _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.
660package FCM::System::CM::SVN::Layout;
661use 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
677sub is_trunk {
678    $_[0]->{branch_category} && $_[0]->{branch_category} eq 'trunk';
679}
680
681sub is_branch {
682    $_[0]->{branch_category} && $_[0]->{branch_category} eq 'branch';
683}
684
685sub is_tag {
686    $_[0]->{branch_category} && $_[0]->{branch_category} eq 'tag';
687}
688
689sub is_owned_by_user {
690    my ($self, $user) = @_;
691    $user ||= $self->get_username();
692    $self->{branch_owner} && $self->{branch_owner} eq $user;
693}
694
695sub is_shared {
696    my ($self) = @_;
697    $self->{branch_owner}
698        && grep {$_ eq $self->{branch_owner}} qw{Share Config Rel};
699}
700
701sub 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
7231;
724__END__
725
726=head1 NAME
727
728FCM::System::CM::SVN
729
730=head1 DESCRIPTION
731
732Part of L<FCM::System::CM|FCM::System::CM>. Provides an interface for common SVN
733functionalities used in the FCM CM sub-system.
734
735=head1 METHODS
736
737This is a sub-class of L<FCM::Class::CODE|FCM::Class::CODE>.
738
739=over 4
740
741=item $class->new(\%attrib)
742
743Return a new instance of this class. %attrib accepts a single "util" key for an
744instance of an L<FCM::Util|FCM::Util> object.
745
746=item $instance->call(@args)
747
748Call 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
753Invokes "svn info --xml @paths", and returns a LIST of info entries. If @paths
754is not specified, use ("."). If %option is specified, it may contain the keys:
755
756=over 4
757
758=item recursive
759
760If value of this key is not undef, add --recursive to "svn info".
761
762=item revision
763
764If value of this key is not undef, add --revision VALUE to "svn info".
765
766=back
767
768Each info entry is a HASH with keys reflecting the tag or attribute name in an
769entry element. The original hierarchy below the entry element is delimited by a
770colon 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
785Return an instance of L<FCM::System::CM::SVN::Layout|/FCM::System::CM::SVN::Layout>
786containing the repository layout information of $url.
787
788=item $instance->get_layout_common($root, $rev, $path, $is_local)
789
790Return an instance of L<FCM::System::CM::SVN::Layout|/FCM::System::CM::SVN::Layout>
791containing 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
793at $rev. Otherwise, it uses "svn info" instead. If $rev is assumed to be a
794transaction if it is not numeric.
795
796=item $instance->get_list($url_arg, $filter_func)
797
798Call "svn list" multiple times to obtain a recursive listing of files and
799directories 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
801for 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
806where $this_url is the URL of the file/directory found, $this_name is the
807base 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
810The $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
812if $can_return is set to true. If $is_dir is true and $can_recurse is true, the
813get_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
818Invokes "svn log --xml".  If @paths is not specified, use ("."). If %option is
819specified, it may contain the keys:
820
821=over 4
822
823=item revision
824
825If value of this key is not undef, add --revision VALUE to "svn log".
826
827=item stop-on-copy
828
829If value of this key is not undef, add --stop-on-copy to "svn log".
830
831=back
832
833Returns an ARRAY reference. Each element is a data structure that represents a
834log 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
852Return the user name associated with $target.
853
854=item $instance->get_wc_root($path)
855
856Return the path to the root working copy directory of the argument.
857
858=item $instance->load_layout_config($root)
859
860Return a HASH (not a reference) containing the layout configuration of $root.
861See %LAYOUT_CONFIG for default settings. $root should be the URL to a
862repository root.
863
864=item $instance->split_by_peg($location)
865
866Split a location string (either a URL@PEG or a PATH@PEG) and return a
867two-element list: either (URL, PEG) or (PATH, PEG).
868
869=item $instance->stdout(@command)
870
871Call a @command, capture and return the STDOUT on success. In scalar context,
872return the STDOUT as-is. In array context, return it as a list of lines with the
873new line characters removed.
874
875=back
876
877=head1 EXCEPTION
878
879Methods in this class may throw an
880L<FCM::System::Exception|FCM::System::Exception> on error.
881
882=head1 FCM::System::CM::SVN::Layout
883
884The FCM::System::CM::SVN::Layout class inherits from
885L<FCM::Class::HASH|FCM::Class::HASH>. An instance represents the layout
886information in a Subversion URL based on the default or specified FCM layout
887information. It has the following attributes:
888
889=over 4
890
891=item config
892
893is a HASH containing the layout configuration applied to this URL.
894Valid keys and their default values are:
895
896=over 4
897
898=item depth-project => undef
899Number of sub-directories used by the name of a project.
900
901=item depth-branch => 3
902Number of sub-directories (under "branches") used by the name of branch.
903
904=item depth-tag => 1
905Number of sub-directories (under "tags") used by the name of branch.
906
907=item dir-trunk => 'trunk'
908Name of the master/trunk directory.
909
910=item dir-branch => 'branches'
911Name of the directory where all branches live. May be empty.
912
913=item dir-tag => 'tags'
914Name of the directory where all tags live. May be empty.
915
916=item level-owner-branch => 2
917Sub-directory level in the name of a branch containing the its owner.
918
919=item level-owner-branch => undef
920Sub-directory level in the name of a tag containing the its owner.
921
922=item template-branch => '{category}/{owner}/{name_prefix}{name}'
923Branch name template.
924
925=item template-tag => undef
926Tag name template.
927
928=back
929
930=item url
931
932is the full URL@PEG.
933
934=item root
935
936is the repository root.
937
938=item path
939
940is the path below the repository root.
941
942=item peg_rev
943
944is the (peg) revision of the URL.
945
946=item project
947
948is the project name in the URL. It is undef if the URL does not contain a valid
949project name for the given repository. An empty string is possible, for example,
950if the layout means that the trunk is at the root level.
951
952=item branch
953
954is the "branch" name in the URL, (which may be the name of the master/trunk
955branch or the name of a tag). It is undef if the URL does not contain a valid
956branch name for the given repository.
957
958=item branch_category
959
960is the category (i.e. "trunk", "branch" or "tag") of the branch.
961
962=item branch_owner
963
964is the owner of the branch, if it can be derived from the URL.
965
966=item sub_tree
967
968is the path in the URL under the branch of a project tree. It is undef if the
969URL is not at or below the level of a branch of the project tree. An empty
970string means the that the URL is at root level of the project tree.
971
972=back
973
974An FCM::System::CM::SVN::Layout instance has the following convenient methods:
975
976=over 4
977
978=item $layout->is_trunk()
979
980The URL is in the trunk of a project.
981
982=item $layout->is_branch()
983
984The URL is in a branch of a project.
985
986=item $layout->is_tag()
987
988The URL is in a tag of a project.
989
990=item $layout->is_owned_by_user($user)
991
992The URL is in a branch owned by $user. If $user is not defined, it defaults to
993the current user ID.
994
995=item $layout->is_shared()
996
997The URL is in a shared branch.
998
999=back
1000
1001=head1 COPYRIGHT
1002
1003(C) Crown copyright Met Office. All rights reserved.
1004
1005=cut
Note: See TracBrowser for help on using the repository browser.