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::Util::Locator; |
---|
24 | use base qw{FCM::Class::CODE}; |
---|
25 | |
---|
26 | use FCM::Context::Keyword; |
---|
27 | use FCM::Context::Locator; |
---|
28 | use FCM::Util::Exception; |
---|
29 | use FCM::Util::Locator::FS; |
---|
30 | use FCM::Util::Locator::SSH; |
---|
31 | use FCM::Util::Locator::SVN; |
---|
32 | |
---|
33 | # URI prefix for FCM scheme |
---|
34 | use constant PREFIX => 'fcm'; |
---|
35 | |
---|
36 | # Methods of an instance of this class |
---|
37 | my %ACTION_OF = ( |
---|
38 | as_invariant => \&_as_invariant, |
---|
39 | as_keyword => \&_as_keyword, |
---|
40 | as_normalised => \&_as_normalised, |
---|
41 | as_parsed => \&_as_parsed, |
---|
42 | browser_url => \&_browser_url, |
---|
43 | cat => _locator_func(sub {$_[0]->cat(@_[1 .. $#_])}), |
---|
44 | dir => _locator_func(sub {$_[0]->dir($_[1])}), |
---|
45 | export => \&_export, |
---|
46 | export_ok => \&_export_ok, |
---|
47 | find => \&_find, |
---|
48 | kw_ctx => sub {$_[0]->{kw_ctx}}, |
---|
49 | kw_ctx_load => \&_kw_ctx_load, |
---|
50 | kw_iter => \&_kw_iter, |
---|
51 | kw_load_rev_prop => \&_kw_load_rev_prop, |
---|
52 | kw_prefix => sub {PREFIX}, |
---|
53 | origin => _locator_func(sub {$_[0]->origin($_[1])}), |
---|
54 | reader => \&_reader, |
---|
55 | rel2abs => \&_rel2abs, |
---|
56 | test_exists => \&_test_exists, |
---|
57 | trunk_at_head => \&_trunk_at_head, |
---|
58 | what_type => \&_what_type, |
---|
59 | up_iter => \&_up_iter, |
---|
60 | ); |
---|
61 | # Default browser config |
---|
62 | our %BROWSER_CONFIG = ( |
---|
63 | comp_pat => qr{\A // ([^/]+) /+ ([^/]+)_svn /*(.*) \z}xms, |
---|
64 | rev_tmpl => '@{1}', |
---|
65 | loc_tmpl => 'http://{1}/projects/{2}/intertrac/source:/{3}{4}', |
---|
66 | ); |
---|
67 | # Alias to the exception class |
---|
68 | my $E = 'FCM::Util::Exception'; |
---|
69 | # Loaders for keyword context from configuration entries |
---|
70 | my %KEYWORD_CFG_LOADER_FOR = ( |
---|
71 | 'location' |
---|
72 | => \&_kw_ctx_load_loc, |
---|
73 | 'revision' |
---|
74 | => \&_kw_ctx_load_rev, |
---|
75 | 'browser.comp-pat' |
---|
76 | => _kw_ctx_load_browser_func(sub {$_[0]->set_comp_pat($_[1])}), |
---|
77 | 'browser.loc-tmpl' |
---|
78 | => _kw_ctx_load_browser_func(sub {$_[0]->set_loc_tmpl($_[1])}), |
---|
79 | 'browser.rev-tmpl' |
---|
80 | => _kw_ctx_load_browser_func(sub {$_[0]->set_rev_tmpl($_[1])}), |
---|
81 | ); |
---|
82 | my @KEYWORD_IMPLIED_SUFFICES = ( |
---|
83 | [branches => [qw{-br _br}]], |
---|
84 | [tags => [qw{-tg _tg}]], |
---|
85 | [trunk => [qw{-tr _tr}]], |
---|
86 | ); |
---|
87 | # Patterns for parsing keyword configurations, etc |
---|
88 | my %PATTERN_OF = ( |
---|
89 | # Assignment delimiter, e.g. "label = value" |
---|
90 | delim_of_assign => qr/\s* = \s*/xms, |
---|
91 | # Key of a FCM location keyword, e.g. "um" in "fcm:um" |
---|
92 | parse => qr/ |
---|
93 | \A (?# start) |
---|
94 | ([\w\+\-\.]+) (?# capture 1, 1 or more word, plus, minus or dot) |
---|
95 | (.*) \z (?# capture 2, rest of string) |
---|
96 | /xms, |
---|
97 | ); |
---|
98 | # The name of the property where revision keywords are set in primary locations |
---|
99 | our $REV_PROP_NAME = 'fcm:revision'; |
---|
100 | # The known types |
---|
101 | our @TYPES = qw{svn ssh fs}; |
---|
102 | # The classes for the known types |
---|
103 | our %TYPE_UTIL_CLASS_OF = ( |
---|
104 | fs => 'FCM::Util::Locator::FS', |
---|
105 | ssh => 'FCM::Util::Locator::SSH', |
---|
106 | svn => 'FCM::Util::Locator::SVN', |
---|
107 | ); |
---|
108 | |
---|
109 | # Creates the class. |
---|
110 | __PACKAGE__->class( |
---|
111 | { types => {isa => '@', default => [@TYPES]}, |
---|
112 | type_util_class_of => {isa => '%', default => {%TYPE_UTIL_CLASS_OF}}, |
---|
113 | type_util_of => '%', |
---|
114 | util => '&', |
---|
115 | }, |
---|
116 | { init => sub { |
---|
117 | my ($attrib_ref) = @_; |
---|
118 | my $K = 'FCM::Context::Keyword'; |
---|
119 | $attrib_ref->{browser_config} |
---|
120 | = $K->BROWSER_CONFIG->new(\%BROWSER_CONFIG); |
---|
121 | $attrib_ref->{kw_ctx} = $K->new(); |
---|
122 | for my $type (@{$attrib_ref->{types}}) { |
---|
123 | if (!exists($attrib_ref->{type_util_of}{$type})) { |
---|
124 | my $class = $attrib_ref->{type_util_class_of}{$type}; |
---|
125 | $attrib_ref->{type_util_of}{$type} = $class->new({ |
---|
126 | type_util_of => $attrib_ref->{type_util_of}, |
---|
127 | util => $attrib_ref->{util}, |
---|
128 | }); |
---|
129 | } |
---|
130 | } |
---|
131 | }, |
---|
132 | action_of => \%ACTION_OF, |
---|
133 | }, |
---|
134 | ); |
---|
135 | |
---|
136 | # Determines the invariant value of the $locator. |
---|
137 | sub _as_invariant { |
---|
138 | my ($attrib_ref, $locator) = @_; |
---|
139 | if ($locator->get_value_level() < $locator->L_INVARIANT) { |
---|
140 | _as_normalised($attrib_ref, $locator); |
---|
141 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
142 | if ($util_of_type->can('as_invariant')) { |
---|
143 | my $value = eval { |
---|
144 | $util_of_type->as_invariant($locator->get_value()); |
---|
145 | }; |
---|
146 | if (my $e = $@) { |
---|
147 | return $E->throw($E->LOCATOR_AS_INVARIANT, $locator, $e); |
---|
148 | } |
---|
149 | if ($value) { |
---|
150 | $locator->set_value($value); |
---|
151 | $locator->set_value_level($locator->L_INVARIANT); |
---|
152 | } |
---|
153 | } |
---|
154 | } |
---|
155 | $locator->get_value(); |
---|
156 | } |
---|
157 | |
---|
158 | # Determines the keyword value of the $locator. |
---|
159 | sub _as_keyword { |
---|
160 | my ($attrib_ref, $locator) = @_; |
---|
161 | _as_normalised($attrib_ref, $locator); |
---|
162 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
163 | my ($target, $rev) = $util_of_type->parse($locator->get_value()); |
---|
164 | my $kw_iter = _kw_iter($attrib_ref, $locator); |
---|
165 | my $entry; |
---|
166 | while (!defined($entry) && defined($entry = $kw_iter->())) { |
---|
167 | if ($entry->is_implied()) { |
---|
168 | $entry = undef; |
---|
169 | } |
---|
170 | } |
---|
171 | if (defined($entry)) { |
---|
172 | $target |
---|
173 | = PREFIX . ':' . $entry->get_key() |
---|
174 | . substr($target, length($entry->get_value())); |
---|
175 | } |
---|
176 | if (defined($rev) && $util_of_type->can_work_with_rev($rev)) { |
---|
177 | my $transformed_rev = _transform_rev_keyword( |
---|
178 | $attrib_ref, $locator, $rev, |
---|
179 | sub {$_[0]->get_entry_by_value($_[1])}, |
---|
180 | sub {$_[0]->get_key()}, |
---|
181 | ); |
---|
182 | if ($transformed_rev) { |
---|
183 | $rev = $transformed_rev; |
---|
184 | } |
---|
185 | } |
---|
186 | scalar($util_of_type->parse($target, $rev)); |
---|
187 | } |
---|
188 | |
---|
189 | # Determines the normalised value of the $locator. |
---|
190 | sub _as_normalised { |
---|
191 | my ($attrib_ref, $locator) = @_; |
---|
192 | if ($locator->get_value_level() < $locator->L_NORMALISED) { |
---|
193 | _as_parsed($attrib_ref, $locator); |
---|
194 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
195 | my ($target, $rev) = $util_of_type->parse($locator->get_value()); |
---|
196 | if (defined($rev) && !$util_of_type->can_work_with_rev($rev)) { |
---|
197 | my $origin = $ACTION_OF{origin}->( |
---|
198 | $attrib_ref, FCM::Context::Locator->new($target), |
---|
199 | ); |
---|
200 | $rev = _transform_rev_keyword( |
---|
201 | $attrib_ref, $origin, lc($rev), |
---|
202 | sub {$_[0]->get_entry_by_key($_[1])}, |
---|
203 | sub {$_[0]->get_value()}, |
---|
204 | ); |
---|
205 | if (!$rev) { |
---|
206 | return $E->throw($E->LOCATOR_KEYWORD_REV, $locator); |
---|
207 | } |
---|
208 | } |
---|
209 | $locator->set_value(scalar($util_of_type->parse($target, $rev))); |
---|
210 | $locator->set_value_level($locator->L_NORMALISED); |
---|
211 | } |
---|
212 | $locator->get_value(); |
---|
213 | } |
---|
214 | |
---|
215 | # Determines the parsed value of the $locator. |
---|
216 | sub _as_parsed { |
---|
217 | my ($attrib_ref, $locator) = @_; |
---|
218 | if ($locator->get_value_level() < $locator->L_PARSED) { |
---|
219 | my $value = $locator->get_value(); |
---|
220 | my ($scheme, $sps) = $attrib_ref->{util}->uri_match($value); |
---|
221 | if ($scheme && $scheme eq PREFIX) { |
---|
222 | my ($key, $trail) = $sps =~ $PATTERN_OF{parse}; |
---|
223 | my $entry = $attrib_ref->{kw_ctx}->get_entry_by_key(lc($key)); |
---|
224 | if (!defined($entry)) { |
---|
225 | return $E->throw($E->LOCATOR_KEYWORD_LOC, $locator); |
---|
226 | } |
---|
227 | $value = $entry->get_value() . $trail; |
---|
228 | } |
---|
229 | $locator->set_value($value); |
---|
230 | $locator->set_value_level($locator->L_PARSED); |
---|
231 | } |
---|
232 | $locator->get_value(); |
---|
233 | } |
---|
234 | |
---|
235 | # Determines the browser URL of the $locator. |
---|
236 | sub _browser_url { |
---|
237 | my ($attrib_ref, $locator) = @_; |
---|
238 | _as_normalised($attrib_ref, $locator); |
---|
239 | my %GET = ( |
---|
240 | comp_pat => sub {$_[0]->get_comp_pat()}, |
---|
241 | loc_tmpl => sub {$_[0]->get_loc_tmpl()}, |
---|
242 | rev_tmpl => sub {$_[0]->get_rev_tmpl()}, |
---|
243 | ); |
---|
244 | my %value_of = map {($_, undef)} keys(%GET); |
---|
245 | my $iter = _kw_iter($attrib_ref, $locator); |
---|
246 | while (my $entry = $iter->()) { |
---|
247 | if (defined($entry->get_browser_config())) { |
---|
248 | for my $key (keys(%value_of)) { |
---|
249 | if (!defined($value_of{$key})) { |
---|
250 | my $value = $GET{$key}->($entry->get_browser_config()); |
---|
251 | if (defined($value)) { |
---|
252 | $value_of{$key} = $value; |
---|
253 | } |
---|
254 | } |
---|
255 | } |
---|
256 | } |
---|
257 | } |
---|
258 | for my $key (keys(%value_of)) { |
---|
259 | if (!$value_of{$key}) { |
---|
260 | $value_of{$key} = $GET{$key}->($attrib_ref->{browser_config}); |
---|
261 | } |
---|
262 | } |
---|
263 | # Extracts components from the locator |
---|
264 | my $origin = $ACTION_OF{origin}->($attrib_ref, $locator); |
---|
265 | my ($target, $rev) |
---|
266 | = _util_of_type($attrib_ref, $origin)->parse($origin->get_value()); |
---|
267 | my ($scheme, $sps) = $attrib_ref->{util}->uri_match($target); |
---|
268 | if (!$sps) { |
---|
269 | return $E->throw($E->LOCATOR_BROWSER_URL, $locator); |
---|
270 | } |
---|
271 | my @matches = $sps =~ $value_of{comp_pat}; |
---|
272 | if (!@matches) { |
---|
273 | return $E->throw($E->LOCATOR_BROWSER_URL, $locator); |
---|
274 | } |
---|
275 | # Places the components into the template |
---|
276 | my $result = $value_of{loc_tmpl}; |
---|
277 | for my $field_number (1 .. @matches) { |
---|
278 | my $match = $matches[$field_number - 1]; |
---|
279 | $result =~ s/\{ $field_number \}/$match/xms; |
---|
280 | } |
---|
281 | my $rev_field_number = scalar(@matches) + 1; |
---|
282 | my $rev_string = q{}; |
---|
283 | if ($rev) { |
---|
284 | $rev_string = $value_of{rev_tmpl}; |
---|
285 | $rev_string =~ s/\{1\}/$rev/xms; |
---|
286 | } |
---|
287 | $result =~ s/\{ $rev_field_number \}/$rev_string/xms; |
---|
288 | return $result; |
---|
289 | } |
---|
290 | |
---|
291 | # Exports $locator to a $dest. |
---|
292 | sub _export { |
---|
293 | my ($attrib_ref, $locator, $dest) = @_; |
---|
294 | if (_util_of_type($attrib_ref, $locator)->can('export')) { |
---|
295 | _as_normalised($attrib_ref, $locator); |
---|
296 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
297 | $util_of_type->export($locator->get_value(), $dest); |
---|
298 | } |
---|
299 | } |
---|
300 | |
---|
301 | # Returns true if it is possible to safely export $locator. |
---|
302 | sub _export_ok { |
---|
303 | my ($attrib_ref, $locator) = @_; |
---|
304 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
305 | _as_parsed($attrib_ref, $locator); |
---|
306 | $util_of_type->can('export_ok') |
---|
307 | && $util_of_type->export_ok($locator->get_value()); |
---|
308 | } |
---|
309 | |
---|
310 | # Searches the directory tree of $locator. Calls a function for each node. |
---|
311 | sub _find { |
---|
312 | my ($attrib_ref, $locator, $callback) = @_; |
---|
313 | _as_invariant($attrib_ref, $locator); |
---|
314 | my $type = $locator->get_type(); |
---|
315 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
316 | my $found = $util_of_type->find( |
---|
317 | $locator->get_value(), |
---|
318 | sub { |
---|
319 | my ($value, $target_attrib_ref) = @_; |
---|
320 | my $new_locator; |
---|
321 | if ($value eq $locator->get_value()) { |
---|
322 | $locator->set_last_mod_rev($target_attrib_ref->{last_mod_rev}); |
---|
323 | $locator->set_last_mod_time($target_attrib_ref->{last_mod_time}); |
---|
324 | $new_locator = $locator; |
---|
325 | } |
---|
326 | else { |
---|
327 | $new_locator = FCM::Context::Locator->new($value, { |
---|
328 | last_mod_rev => $target_attrib_ref->{last_mod_rev}, |
---|
329 | last_mod_time => $target_attrib_ref->{last_mod_time}, |
---|
330 | type => $type, |
---|
331 | value_level => FCM::Context::Locator->L_INVARIANT, |
---|
332 | }); |
---|
333 | } |
---|
334 | $callback->($new_locator, $target_attrib_ref); |
---|
335 | }, |
---|
336 | ); |
---|
337 | return ($found ? $found : $E->throw($E->LOCATOR_FIND, $locator)); |
---|
338 | } |
---|
339 | |
---|
340 | # Loads the keyword context from configuration entries. |
---|
341 | sub _kw_ctx_load { |
---|
342 | my ($attrib_ref, @config_entry_iterators) = @_; |
---|
343 | for my $config_entry_iterator (@config_entry_iterators) { |
---|
344 | while (my $config_entry = $config_entry_iterator->()) { |
---|
345 | my $handler = $KEYWORD_CFG_LOADER_FOR{$config_entry->get_label()}; |
---|
346 | if (defined($handler)) { |
---|
347 | $handler->($attrib_ref, $config_entry); |
---|
348 | } |
---|
349 | } |
---|
350 | } |
---|
351 | } |
---|
352 | |
---|
353 | # Loads a location keyword browser config from a configuration entry. |
---|
354 | sub _kw_ctx_load_browser_func { |
---|
355 | my ($setter_ref) = @_; |
---|
356 | sub { |
---|
357 | my ($attrib_ref, $c_entry) = @_; |
---|
358 | my %entry_by_key = %{$attrib_ref->{kw_ctx}->get_entry_by_key()}; |
---|
359 | if (@{$c_entry->get_ns_list()}) { |
---|
360 | for my $key (@{$c_entry->get_ns_list()}) { |
---|
361 | if (exists($entry_by_key{$key})) { |
---|
362 | $setter_ref->( |
---|
363 | $entry_by_key{$key}->get_browser_config(), |
---|
364 | $c_entry->get_value(), |
---|
365 | ); |
---|
366 | } |
---|
367 | } |
---|
368 | } |
---|
369 | else { |
---|
370 | $setter_ref->($attrib_ref->{browser_config}, $c_entry->get_value()); |
---|
371 | } |
---|
372 | } |
---|
373 | } |
---|
374 | |
---|
375 | # Loads the location keyword context from a configuration entry. |
---|
376 | sub _kw_ctx_load_loc { |
---|
377 | my ($attrib_ref, $c_entry) = @_; |
---|
378 | my $key = lc($c_entry->get_ns_list()->[0]); |
---|
379 | my $value = $c_entry->get_value(); |
---|
380 | my $M = $c_entry->get_modifier_of(); |
---|
381 | my $type = (exists($M->{type}) ? $M->{type} : undef); |
---|
382 | if (exists($M->{primary}) && $M->{primary}) { |
---|
383 | my $locator = FCM::Context::Locator->new($value, {type => $type}); |
---|
384 | _as_normalised($attrib_ref, $locator); |
---|
385 | my $entry = $attrib_ref->{kw_ctx}->add_entry( |
---|
386 | $key, $locator->get_value(), {type => $locator->get_type()}, |
---|
387 | ); |
---|
388 | for (@KEYWORD_IMPLIED_SUFFICES) { |
---|
389 | my ($value_suffix, $key_suffix_ref) = @{$_}; |
---|
390 | my $locator = $ACTION_OF{cat}->($attrib_ref, $locator, $value_suffix); |
---|
391 | my $value = $locator->get_value(); |
---|
392 | for my $key_suffix (@{$key_suffix_ref}) { |
---|
393 | my $implied_entry = $entry->get_ctx_of_implied()->add_entry( |
---|
394 | $key . $key_suffix, $value, {implied => 1, type => $type}, |
---|
395 | ); |
---|
396 | $attrib_ref->{kw_ctx}->add_entry($implied_entry); |
---|
397 | } |
---|
398 | } |
---|
399 | } |
---|
400 | else { |
---|
401 | $attrib_ref->{kw_ctx}->add_entry($key, $value, {type => $type}); |
---|
402 | } |
---|
403 | } |
---|
404 | |
---|
405 | # Loads the revision keyword context from a configuration entry. |
---|
406 | sub _kw_ctx_load_rev { |
---|
407 | my ($attrib_ref, $c_entry) = @_; |
---|
408 | for my $ns (map {lc($_)} @{$c_entry->get_ns_list()}) { |
---|
409 | my ($key, $r_key) = split(qr{:}msx, $ns); |
---|
410 | my $entry = $attrib_ref->{kw_ctx}->get_entry_by_key($key); |
---|
411 | if (defined($entry)) { |
---|
412 | $entry->get_ctx_of_rev()->add_entry($r_key, $c_entry->get_value()); |
---|
413 | } |
---|
414 | } |
---|
415 | } |
---|
416 | |
---|
417 | # Returns an iterator that returns location keyword entry context for $locator. |
---|
418 | sub _kw_iter { |
---|
419 | my ($attrib_ref, $locator, $callback_ref) = @_; |
---|
420 | my $origin = $ACTION_OF{origin}->($attrib_ref, $locator); |
---|
421 | my $iter = _up_iter($attrib_ref, $origin); |
---|
422 | sub { |
---|
423 | while (my ($leader) = $iter->()) { |
---|
424 | my $entry = $attrib_ref->{kw_ctx}->get_entry_by_value($leader); |
---|
425 | if (defined($entry)) { |
---|
426 | if (defined($callback_ref)) { |
---|
427 | $callback_ref->($entry); |
---|
428 | } |
---|
429 | return $entry; |
---|
430 | } |
---|
431 | } |
---|
432 | return; |
---|
433 | } |
---|
434 | } |
---|
435 | |
---|
436 | # Loads revision keywords from the "fcm:revision" property of the locator value |
---|
437 | # of a location keyword entry. |
---|
438 | sub _kw_load_rev_prop { |
---|
439 | my ($attrib_ref, $entry) = @_; |
---|
440 | if ($entry->get_loaded_rev_prop() || $entry->get_implied()) { |
---|
441 | return; |
---|
442 | } |
---|
443 | $entry->set_loaded_rev_prop(1); |
---|
444 | my $locator = FCM::Context::Locator->new( |
---|
445 | $entry->get_value(), {type => $entry->get_type()}, |
---|
446 | ); |
---|
447 | my $property = _read_property($attrib_ref, $locator, $REV_PROP_NAME); |
---|
448 | if (!$property) { |
---|
449 | return; |
---|
450 | } |
---|
451 | for my $line (split(qr{\s*\n\s*}xms, $property)) { |
---|
452 | my ($key, $value) = split($PATTERN_OF{delim_of_assign}, $line, 2); |
---|
453 | $entry->get_ctx_of_rev()->add_entry($key, $value); |
---|
454 | } |
---|
455 | } |
---|
456 | |
---|
457 | # Returns a function to "transform" a $locator to another locator. |
---|
458 | sub _locator_func { |
---|
459 | my ($impl_ref) = @_; |
---|
460 | sub { |
---|
461 | my ($attrib_ref, $locator, @args) = @_; |
---|
462 | _as_parsed($attrib_ref, $locator); |
---|
463 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
464 | FCM::Context::Locator->new( |
---|
465 | scalar($impl_ref->($util_of_type, $locator->get_value(), @args)), |
---|
466 | {type => $locator->get_type()}, |
---|
467 | ); |
---|
468 | } |
---|
469 | } |
---|
470 | |
---|
471 | # Returns a file handle to read the content of $locator. |
---|
472 | sub _reader { |
---|
473 | my ($attrib_ref, $locator) = @_; |
---|
474 | _as_normalised($attrib_ref, $locator); |
---|
475 | my $reader = eval { |
---|
476 | _util_of_type($attrib_ref, $locator)->reader($locator->get_value()); |
---|
477 | }; |
---|
478 | if (my $e = $@) { |
---|
479 | return $E->throw($E->LOCATOR_READER, $locator, $e); |
---|
480 | } |
---|
481 | if (!defined($reader)) { |
---|
482 | return $E->throw($E->LOCATOR_READER, $locator); |
---|
483 | } |
---|
484 | return $reader; |
---|
485 | } |
---|
486 | |
---|
487 | # Returns the contents in a named property of $locator |
---|
488 | sub _read_property { |
---|
489 | my ($attrib_ref, $locator, $prop_name) = @_; |
---|
490 | _as_normalised($attrib_ref, $locator); |
---|
491 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
492 | eval {$util_of_type->read_property($locator->get_value(), $prop_name)}; |
---|
493 | } |
---|
494 | |
---|
495 | # If $locator->get_value() is a relative path, set it to a absolute path |
---|
496 | # base on $locator_base->get_value(), if $locator->get_type() does not differ |
---|
497 | # from $locator_base->get_type(). |
---|
498 | sub _rel2abs { |
---|
499 | my ($attrib_ref, $locator, $locator_base) = @_; |
---|
500 | _as_normalised($attrib_ref, $locator_base); |
---|
501 | if ( $locator->get_type() |
---|
502 | && $locator->get_type() ne $locator_base->get_type() |
---|
503 | ) { |
---|
504 | return $locator; |
---|
505 | } |
---|
506 | my $value = $locator->get_value(); |
---|
507 | if ( $attrib_ref->{util}->uri_match($value) |
---|
508 | || index($value, '/') == 0 |
---|
509 | || index($value, '~') == 0 |
---|
510 | ) { |
---|
511 | return $locator; |
---|
512 | } |
---|
513 | my $new_locator = $ACTION_OF{cat}->($attrib_ref, $locator_base, $value); |
---|
514 | $locator->set_value($new_locator->get_value()); |
---|
515 | $locator->set_value_level($new_locator->get_value_level()); |
---|
516 | $locator; |
---|
517 | } |
---|
518 | |
---|
519 | # Test if $locator location exists. |
---|
520 | sub _test_exists { |
---|
521 | my ($attrib_ref, $locator) = @_; |
---|
522 | _as_normalised($attrib_ref, $locator); |
---|
523 | _util_of_type($attrib_ref, $locator)->test_exists($locator->get_value()); |
---|
524 | } |
---|
525 | |
---|
526 | # Transforms a revision from/to a keyword, and returns the result. |
---|
527 | sub _transform_rev_keyword { |
---|
528 | my ($attrib_ref, $locator, $rev, $rev_entry_func, $result_func) = @_; |
---|
529 | my $iter = _kw_iter($attrib_ref, $locator); |
---|
530 | while (my $entry = $iter->()) { |
---|
531 | # $entry->get_ctx_of_rev()->get_entry_by_key($rev) |
---|
532 | # $entry->get_ctx_of_rev()->get_entry_by_value($rev) |
---|
533 | if (defined($entry->get_ctx_of_rev())) { |
---|
534 | if (!$rev_entry_func->($entry->get_ctx_of_rev(), $rev)) { |
---|
535 | _kw_load_rev_prop($attrib_ref, $entry); |
---|
536 | } |
---|
537 | } |
---|
538 | if (defined($entry->get_ctx_of_rev())) { |
---|
539 | my $rev_entry = $rev_entry_func->($entry->get_ctx_of_rev(), $rev); |
---|
540 | if (defined($rev_entry)) { |
---|
541 | # $rev_entry->get_value() |
---|
542 | # $rev_entry->get_key() |
---|
543 | return $result_func->($rev_entry); |
---|
544 | } |
---|
545 | } |
---|
546 | } |
---|
547 | return; |
---|
548 | } |
---|
549 | |
---|
550 | # Returns a string to represent the relative path to the latest main tree. |
---|
551 | sub _trunk_at_head { |
---|
552 | my ($attrib_ref, $locator) = @_; |
---|
553 | my $orig_value = $locator->get_value(); |
---|
554 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
555 | my $head_value = $util_of_type->trunk_at_head($orig_value); |
---|
556 | if (!$head_value || $head_value eq $orig_value) { |
---|
557 | return; |
---|
558 | } |
---|
559 | return FCM::Context::Locator->new($head_value, { |
---|
560 | type => $locator->get_type(), |
---|
561 | }); |
---|
562 | } |
---|
563 | |
---|
564 | # Determines the type of the $locator. |
---|
565 | sub _what_type { |
---|
566 | my ($attrib_ref, $locator) = @_; |
---|
567 | if (!defined($locator->get_type())) { |
---|
568 | _as_parsed($attrib_ref, $locator); |
---|
569 | TYPE: |
---|
570 | for my $key (@{$attrib_ref->{types}}) { |
---|
571 | if (!exists($attrib_ref->{type_util_of}{$key})) { |
---|
572 | next TYPE; |
---|
573 | } |
---|
574 | my $util_of_type = $attrib_ref->{type_util_of}{$key}; |
---|
575 | if ($util_of_type->can_work_with($locator->get_value())) { |
---|
576 | $locator->set_type($key); |
---|
577 | last TYPE; |
---|
578 | } |
---|
579 | } |
---|
580 | } |
---|
581 | return $locator->get_type(); |
---|
582 | } |
---|
583 | |
---|
584 | # Returns an iterator that walks up the hierarchy of the $locator. |
---|
585 | sub _up_iter { |
---|
586 | my ($attrib_ref, $locator) = @_; |
---|
587 | my $util_of_type = _util_of_type($attrib_ref, $locator); |
---|
588 | my ($target, $revision) = $util_of_type->parse($locator->get_value()); |
---|
589 | my $leader = $target; |
---|
590 | sub { |
---|
591 | if (!defined($leader)) { |
---|
592 | $leader = $target; |
---|
593 | return; |
---|
594 | } |
---|
595 | my $return = $leader; |
---|
596 | $leader = $util_of_type->dir($return); |
---|
597 | if ($return eq $leader) { |
---|
598 | $leader = undef; |
---|
599 | } |
---|
600 | return $util_of_type->parse($return, $revision); |
---|
601 | }; |
---|
602 | } |
---|
603 | |
---|
604 | # Returns the utility that implements the functionality for the $locator's type. |
---|
605 | sub _util_of_type { |
---|
606 | my ($attrib_ref, $locator) = @_; |
---|
607 | my $type = _what_type($attrib_ref, $locator); |
---|
608 | if (exists($attrib_ref->{type_util_of}{$type})) { |
---|
609 | return $attrib_ref->{type_util_of}{$type}; |
---|
610 | } |
---|
611 | return $E->throw($E->LOCATOR_TYPE, $locator); |
---|
612 | } |
---|
613 | |
---|
614 | # ------------------------------------------------------------------------------ |
---|
615 | 1; |
---|
616 | __END__ |
---|
617 | |
---|
618 | =head1 NAME |
---|
619 | |
---|
620 | FCM::Util::Locator |
---|
621 | |
---|
622 | =head1 SYNOPSIS |
---|
623 | |
---|
624 | use FCM::Util; |
---|
625 | my $util = FCM::Util->new(\%attrib); |
---|
626 | |
---|
627 | # Usage |
---|
628 | $ctx = $util->loc_kw_ctx(); |
---|
629 | @location_keyword_ctx_list = $util->loc_kw_ctx($locator); |
---|
630 | |
---|
631 | $type = $util->loc_what_type($locator); |
---|
632 | ($time, $rev) = $util->loc_when_modified($locator); |
---|
633 | |
---|
634 | $locator_value = $util->loc_as_normalised($locator); |
---|
635 | $locator_value = $util->loc_as_invariant( $locator); |
---|
636 | $locator_value = $util->loc_as_keyword( $locator); |
---|
637 | |
---|
638 | $url = $util->loc_browser_url($locator); |
---|
639 | |
---|
640 | $locator_of_parent = $util->loc_dir($locator); |
---|
641 | $locator_of_child = $util->loc_cat($locator, @paths); |
---|
642 | $locator_of_origin = $util->loc_origin($locator); |
---|
643 | |
---|
644 | $iter = $util->loc_up_iter($locator); |
---|
645 | while (my $value = $iter->()) { |
---|
646 | # ... |
---|
647 | } |
---|
648 | |
---|
649 | $reader = $util->loc_reader($locator); |
---|
650 | |
---|
651 | =head1 DESCRIPTION |
---|
652 | |
---|
653 | This module is part of L<FCM::Util|FCM::Util>. It implements the loc_* methods. |
---|
654 | |
---|
655 | =head1 IMPLEMENTATION |
---|
656 | |
---|
657 | The manipulations of locator values rely on objects with the following |
---|
658 | interface: |
---|
659 | |
---|
660 | =over 4 |
---|
661 | |
---|
662 | =item $util_of_type->as_invariant($locator_value) |
---|
663 | |
---|
664 | Should return the invariant form of $locator_value. |
---|
665 | |
---|
666 | =item $util_of_type->can_work_with($locator_value) |
---|
667 | |
---|
668 | Should return true if it can work with $locator_value, i.e. $locator_value is a |
---|
669 | valid type of locator for the utility. |
---|
670 | |
---|
671 | =item $util_of_type->can_work_with_rev($revision_value) |
---|
672 | |
---|
673 | Should return true if it can work with $revision_value, i.e. $revision_value is |
---|
674 | a valid revision for the utility. |
---|
675 | |
---|
676 | =item $util_of_type->cat($locator_value, @paths) |
---|
677 | |
---|
678 | Should concatenate $locator_value and @paths with appropriate separators and |
---|
679 | returns the result. |
---|
680 | |
---|
681 | =item $util_of_type->dir($locator_value) |
---|
682 | |
---|
683 | Should return the parent (directory) of $locator_value. |
---|
684 | |
---|
685 | =item $util_of_type->export($locator_value,$dest) |
---|
686 | |
---|
687 | Optional. Exports a clean directory tree from $locator_value to $dest. |
---|
688 | |
---|
689 | =item $util_of_type->export_ok($locator_value) |
---|
690 | |
---|
691 | Optional. Returns true if it is safe to export $locator_value. E.g. it is not |
---|
692 | safe to export a SVN working copy, because it may contain unversioned items. |
---|
693 | |
---|
694 | =item $util_of_type->find($locator_value,$callback) |
---|
695 | |
---|
696 | Should search the directory tree in $locator_value and for each node (directory |
---|
697 | or file, inclusive of $locator_value), invoke |
---|
698 | $callback->($locator_value_of_child,\%attrib_of_child). %attrib_of_child should |
---|
699 | contain the elements as described by $util->find($locator,$callback). |
---|
700 | |
---|
701 | =item $util_of_type->origin($locator_value) |
---|
702 | |
---|
703 | Should return the origin of $locator_value. E.g. the URL of a Subversion working |
---|
704 | copy. |
---|
705 | |
---|
706 | =item $util_of_type->parse($locator_value) |
---|
707 | |
---|
708 | Should return an absolute and tidied version of $locator_value. In list context, |
---|
709 | should return a 2-element list, separate the scalar context return value into |
---|
710 | the components (PATH,REV). |
---|
711 | |
---|
712 | =item $util_of_type->reader($locator_value) |
---|
713 | |
---|
714 | Should return a file handle for reading the content of $locator_value. |
---|
715 | |
---|
716 | =item $util_of_type->read_property($locator_value,$property_name) |
---|
717 | |
---|
718 | Should return the value of the named property in $locator_value, or undef if |
---|
719 | not relevant for the $locator_value. |
---|
720 | |
---|
721 | =item $util_of_type->test_exists($locator_value) |
---|
722 | |
---|
723 | Should return a true value if the location $locator_value exists. |
---|
724 | |
---|
725 | =item $util_of_type->trunk_at_head($locator_value) |
---|
726 | |
---|
727 | If relevant, should append a string to $locator_value that represents the |
---|
728 | recommended relative path to the latest version of the main tree of a project of |
---|
729 | this type. E.g. for "svn", this should be "$locator_value/trunk@HEAD". |
---|
730 | |
---|
731 | =back |
---|
732 | |
---|
733 | =head1 CONSTANTS |
---|
734 | |
---|
735 | These global variables are for reference only. Their values should not be |
---|
736 | modified. Instead, use the appropriate attributes of the $class->new(\%attrib) |
---|
737 | method to modify the behaviour. |
---|
738 | |
---|
739 | =over 4 |
---|
740 | |
---|
741 | =item %FCM::Util::Locator::BROWSER_CONFIG |
---|
742 | |
---|
743 | The default browser configuration. |
---|
744 | |
---|
745 | =item FCM::Util::Locator::PREFIX |
---|
746 | |
---|
747 | The URI prefix for a FCM location keyword. |
---|
748 | |
---|
749 | =item $FCM::Util::Locator::REV_PROP_NAME |
---|
750 | |
---|
751 | The name of the property where revision keywords are set in primary locations. |
---|
752 | |
---|
753 | =item @FCM::Util::Locator::TYPES |
---|
754 | |
---|
755 | The known locator types. |
---|
756 | |
---|
757 | =item %FCM::Util::Locator::TYPE_UTIL_CLASS_OF |
---|
758 | |
---|
759 | Maps the known locator types with their utility classes. |
---|
760 | |
---|
761 | =back |
---|
762 | |
---|
763 | =head1 COPYRIGHT |
---|
764 | |
---|
765 | Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
766 | |
---|
767 | =cut |
---|