source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM/System/Misc.pm @ 5135

Last change on this file since 5135 was 5129, checked in by abarral, 4 months ago

Re-add removed by mistake fcm
File size: 11.6 KB
Line 
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# ------------------------------------------------------------------------------
19use strict;
20use warnings;
21# ------------------------------------------------------------------------------
22package FCM::System::Misc;
23use base qw{FCM::Class::CODE};
24
25use Cwd qw{cwd};
26use FCM::Context::Event;
27use FCM::Context::Locator;
28use FCM::System::Exception;
29use FCM::Util::ConfigReader;
30use File::Path qw{mkpath rmtree};
31use File::Spec::Functions qw{catfile};
32use List::Util qw{max};
33use Text::ParseWords qw{shellwords};
34
35# The (keys) named actions of this class and (values) their implementations.
36our %ACTION_OF = (
37    browse       => \&_browse,
38    config_parse => \&_config_parse,
39    export_items => \&_export_items,
40    keyword_find => \&_keyword_find,
41);
42# Alias to exception class
43my $E = 'FCM::System::Exception';
44
45# Creates the class.
46__PACKAGE__->class({util => '&'}, {action_of => \%ACTION_OF});
47
48# Launches a web browser to display some version controlled resources.
49sub _browse {
50    my ($attrib_ref, $option_ref, @args) = @_;
51    my $UTIL = $attrib_ref->{util};
52    my @command = shellwords(
53          exists($option_ref->{browser}) ? $option_ref->{browser}
54        :                                  $UTIL->external_cfg_get('browser')
55    );
56    if (!@args) {
57        @args = (cwd());
58    }
59    for my $value (@args) {
60        my $locator = FCM::Context::Locator->new($value);
61        my $url = $UTIL->loc_browser_url($locator);
62        my %value_of = %{$UTIL->shell_simple([@command, $url])};
63        if ($value_of{rc}) {
64            return $E->throw(
65                $E->SHELL,
66                {command_list => [@command, $url], %value_of},
67                $value_of{e},
68            );
69        }
70        $attrib_ref->{util}->event(FCM::Context::Event->OUT, $value_of{o});
71    }
72    return;
73}
74
75# Parses and displays the content of a FCM configuration file.
76sub _config_parse {
77    my ($attrib_ref, $option_ref, @args) = @_;
78    my $reader_attrib_ref;
79    if (exists($option_ref->{'fcm1'})) {
80        $reader_attrib_ref = \%FCM::Util::ConfigReader::FCM1_ATTRIB;
81    }
82    for my $value (@args) {
83        my $locator = FCM::Context::Locator->new($value);
84        my $iter = $attrib_ref->{util}->config_reader(
85            $locator, $reader_attrib_ref,
86        );
87        while (my $entry = $iter->()) {
88            $attrib_ref->{util}->event(
89                FCM::Context::Event->CONFIG_ENTRY,
90                $entry,
91                exists($option_ref->{'fcm1'}),
92            );
93        }
94    }
95    return;
96}
97
98# Exports directories in a project as sequential versioned items.
99sub _export_items {
100    my ($attrib_ref, $option_ref, $location) = @_;
101    if (!$location) {
102        return $E->throw($E->EXPORT_ITEMS_SRC);
103    }
104    $location ||= q{.};
105    my $UTIL = $attrib_ref->{util};
106    # Options and arguments
107    $option_ref->{directory} ||= cwd();
108    $option_ref->{'config-file'} ||= ['fcm-export-items.cfg'];
109    my $locator = FCM::Context::Locator->new($location);
110    $UTIL->loc_as_invariant($locator);
111    # Timer
112    my $time_start = time();
113    my $timer = $UTIL->timer();
114    my %EVENT = (
115        'create' => sub {
116            $UTIL->event(FCM::Context::Event->EXPORT_ITEM_CREATE, @_);
117        },
118        'delete' => sub {
119            $UTIL->event(FCM::Context::Event->EXPORT_ITEM_DELETE, @_);
120        },
121        'timer' => sub {
122            $UTIL->event(
123                FCM::Context::Event->TIMER, 'export-items', $time_start, @_,
124            );
125        },
126    );
127    $EVENT{'timer'}->();
128    # Reads configuration file
129    my $config_reader = $attrib_ref->{util}->config_reader(
130        FCM::Context::Locator->new($option_ref->{'config-file'}->[0]),
131        {   %FCM::Util::ConfigReader::FCM1_ATTRIB,
132            event_level => $attrib_ref->{util}->util_of_report()->LOW,
133        },
134    );
135    my %conditions_of;
136    while (defined(my $entry = $config_reader->())) {
137        # Value: conditions
138        my @conditions;
139        for my $word (shellwords($entry->get_value())) {
140            my ($operator, $rev) = $word =~ qr{\A ([<>]=?|[!=]=) (.+) \z}imsx;
141            if (!$operator || !$rev) {
142                return $E->throw($E->CONFIG_VALUE, $entry);
143            }
144            push(@conditions, $operator . $rev); # FIXME: keyword?
145        }
146        # Label: targets and namespaces
147        my ($target) = $entry->get_label() =~ qr{\A (.+) / \*\z}msx;
148        if ($target) {
149            my $l_target = $UTIL->loc_cat($locator, $target);
150            $UTIL->loc_find(
151                $l_target,
152                sub {
153                    my ($l_child, $attrib_of_child_ref) = @_;
154                    if (!$attrib_of_child_ref->{is_dir}) {
155                        my $ns_of_child = $attrib_of_child_ref->{ns};
156                        my $iter
157                            = $UTIL->ns_iter($ns_of_child, $UTIL->NS_ITER_UP);
158                        $iter->(); # discard
159                        my $ns = $UTIL->ns_cat($target, $iter->());
160                        if (!exists($conditions_of{$ns})) {
161                            $conditions_of{$ns} = \@conditions;
162                        }
163                    }
164                },
165            );
166        }
167        else {
168            $conditions_of{$entry->get_label()} = \@conditions;
169        }
170    }
171    # Export
172    NS:
173    while (my ($ns, $conditions_ref) = each(%conditions_of)) {
174        # FIXME: this should be encapsulated by the locator util.
175        my @command_list = (
176            qw{svn log -q},
177            $UTIL->loc_cat($locator, $ns)->get_value(),
178        );
179        my %value_of = %{$UTIL->shell_simple(\@command_list)};
180        if ($value_of{rc}) {
181            return $E->throw(
182                $E->SHELL,
183                {command_list => \@command_list, %value_of},
184                $value_of{e},
185            );
186        }
187        my @revs = map {($_ =~ qr{\Ar(\d+)})} split("\n", $value_of{o});
188        my %v_of;
189        my $v = 0;
190        for my $rev (reverse(@revs)) {
191            $v_of{$rev} = 'v' . ++$v;
192        }
193        my %cur_v_of = %v_of;
194        # Exports only revisions matching the conditions
195        for my $condition (@{$conditions_ref}) {
196            for my $rev (keys(%cur_v_of)) {
197                if (!eval($rev . $condition)) {
198                    delete($cur_v_of{$rev});
199                }
200            }
201        }
202        # Destination directory
203        my $path = catfile($option_ref->{directory}, $ns);
204        if (-d $path) {
205            if ($option_ref->{new} || !keys(%cur_v_of)) {
206                rmtree($path);
207            }
208            else {
209                # Delete excluded revisions if they exist in incremental mode
210                if (opendir(my $handle, $path)) {
211                    while (my $item = readdir($handle)) {
212                        if (exists($v_of{$item}) && !exists($cur_v_of{$item})) {
213                            for (($item, $v_of{$item})) {
214                                my $p = catfile($path, $_);
215                                rmtree($p);
216                                $EVENT{'delete'}->($ns, $item, $p);
217                            }
218                        }
219                    }
220                    closedir($handle);
221                }
222            }
223        }
224        if (!keys(%cur_v_of)) {
225            next NS;
226        }
227        if (!-d $path) {
228            mkpath($path);
229        }
230
231        # Exports each revision, and creates symlink for each v
232        while (my ($rev, $v) = each(%cur_v_of)) {
233            my $target = catfile($option_ref->{directory}, $ns, $v);
234            if (-l $target || -f $target) {
235                unlink($target);
236                $EVENT{'delete'}->($ns, $v, $target);
237            }
238            if (!-d $target) {
239                my $url_peg_rev = $UTIL->loc_cat($locator, $ns)->get_value();
240                my ($url) = $url_peg_rev =~ qr{\A(.*?)(?:@[^@/]+)?\z}msx;
241                my @command_list = (qw{svn export -q -r}, $rev, $url, $target);
242                my %value_of = %{$UTIL->shell_simple(\@command_list)};
243                if ($value_of{rc} || !-d $target) {
244                    return $E->throw(
245                        $E->SHELL,
246                        {command_list => \@command_list, %value_of},
247                        $value_of{e},
248                    );
249                }
250                $EVENT{'create'}->($ns, $v, $target);
251            }
252            my $link = catfile($option_ref->{directory}, $ns, $rev);
253            if (-e $link && !-l $link) {
254                rmtree($link);
255                $EVENT{'delete'}->($ns, $rev, $link);
256            }
257            elsif (-l $link && readlink($link) ne $v) {
258                unlink($link);
259                $EVENT{'delete'}->($ns, $rev, $link);
260            }
261            if (!-e $link) {
262                symlink($v, $link);
263                $EVENT{'create'}->($ns, $rev, $link);
264            }
265        }
266
267        # Symbolic link to the "latest" version directory
268        my $link_of_latest = catfile($option_ref->{directory}, $ns, 'latest');
269        my $v_of_latest = $cur_v_of{max(keys(%cur_v_of))};
270        if (-e $link_of_latest && !-l $link_of_latest) {
271            rmtree($link_of_latest);
272            $EVENT{'delete'}->($ns, 'latest', $link_of_latest);
273        }
274        elsif (-l $link_of_latest && readlink($link_of_latest) ne $v_of_latest) {
275            unlink($link_of_latest);
276            $EVENT{'delete'}->($ns, 'latest', $link_of_latest);
277        }
278        if (!-l $link_of_latest) {
279            symlink($v_of_latest, $link_of_latest);
280            $EVENT{'create'}->($ns, 'latest', $link_of_latest);
281        }
282    }
283    $EVENT{'timer'}->($timer->());
284}
285
286# Searches FCM keywords.
287sub _keyword_find {
288    my ($attrib_ref, $option_ref, @args) = @_;
289    my $UTIL = $attrib_ref->{util};
290    my @entries;
291    if (@args) {
292        for my $key (@args) {
293            my $iter = $UTIL->loc_kw_iter(FCM::Context::Locator->new($key));
294            while (my $entry = $iter->()) {
295                if (!$entry->get_implied()) {
296                    $UTIL->loc_kw_load_rev_prop($entry);
297                    push(@entries, $entry);
298                }
299            }
300        }
301    }
302    else {
303        @entries = values(%{$UTIL->loc_kw_ctx()->get_entry_by_key()});
304    }
305    for my $entry (sort {$a->get_key() cmp $b->get_key()} @entries) {
306        $UTIL->event(FCM::Context::Event->KEYWORD_ENTRY, $entry);
307    }
308    return;
309}
310
311# ------------------------------------------------------------------------------
3121;
313__END__
314
315=head1 NAME
316
317FCM::System::Misc
318
319=head1 SYNOPSIS
320
321    use FCM::System::Misc;
322    my $system = FCM::System::Misc->new(\%attrib);
323    $system->keyword_find(@args);
324
325=head1 DESCRIPTION
326
327The rest of the FCM system.
328
329=head1 METHODS
330
331Implements the browse(), config_parse(), export_items() and keyword_find()
332methods for L<FCM::System|FCM::System>. See L<FCM::System|FCM::System> for a
333description of the calling interfaces of these functions.
334
335=head1 DIAGNOSTICS
336
337=head2 FCM::System::Exception
338
339Methods of this class may throw a FCM::System::Exception.
340
341=head1 COPYRIGHT
342
343Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
344
345=cut
Note: See TracBrowser for help on using the repository browser.