[10669] | 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 | # ------------------------------------------------------------------------------ |
---|
| 19 | use strict; |
---|
| 20 | use warnings; |
---|
| 21 | # ------------------------------------------------------------------------------ |
---|
| 22 | |
---|
| 23 | package FCM::Util; |
---|
| 24 | use base qw{FCM::Class::CODE}; |
---|
| 25 | |
---|
| 26 | use Digest::MD5; |
---|
| 27 | use Digest::SHA; |
---|
| 28 | use FCM::Context::Event; |
---|
| 29 | use FCM::Context::Locator; |
---|
| 30 | use FCM::Util::ConfigReader; |
---|
| 31 | use FCM::Util::ConfigUpgrade; |
---|
| 32 | use FCM::Util::Event; |
---|
| 33 | use FCM::Util::Exception; |
---|
| 34 | use FCM::Util::Locator; |
---|
| 35 | use FCM::Util::Reporter; |
---|
| 36 | use FCM::Util::Shell; |
---|
| 37 | use FCM::Util::TaskRunner; |
---|
| 38 | use File::Basename qw{basename dirname}; |
---|
| 39 | use File::Path qw{mkpath}; |
---|
| 40 | use File::Spec::Functions qw{catfile}; |
---|
| 41 | use FindBin; |
---|
| 42 | use Scalar::Util qw{blessed reftype}; |
---|
| 43 | use Text::ParseWords qw{shellwords}; |
---|
| 44 | use Time::HiRes qw{gettimeofday tv_interval}; |
---|
| 45 | |
---|
| 46 | use constant {NS_ITER_UP => 1}; |
---|
| 47 | |
---|
| 48 | # The (keys) named actions of this class and (values) their implementations. |
---|
| 49 | our %ACTION_OF = ( |
---|
| 50 | cfg_init => \&_cfg_init, |
---|
| 51 | class_load => \&_class_load, |
---|
| 52 | config_reader => _util_of_func('config_reader', 'main'), |
---|
| 53 | external_cfg_get => \&_external_cfg_get, |
---|
| 54 | event => \&_event, |
---|
| 55 | file_checksum => \&_file_checksum, |
---|
| 56 | file_ext => \&_file_ext, |
---|
| 57 | file_head => \&_file_head, |
---|
| 58 | file_load => \&_file_load, |
---|
| 59 | file_load_handle => \&_file_load_handle, |
---|
| 60 | file_md5 => \&_file_md5, |
---|
| 61 | file_save => \&_file_save, |
---|
| 62 | file_tilde_expand => \&_file_tilde_expand, |
---|
| 63 | hash_cmp => \&_hash_cmp, |
---|
| 64 | loc_as_invariant => _util_of_loc_func('as_invariant'), |
---|
| 65 | loc_as_keyword => _util_of_loc_func('as_keyword'), |
---|
| 66 | loc_as_normalised => _util_of_loc_func('as_normalised'), |
---|
| 67 | loc_as_parsed => _util_of_loc_func('as_parsed'), |
---|
| 68 | loc_browser_url => _util_of_loc_func('browser_url'), |
---|
| 69 | loc_cat => _util_of_loc_func('cat'), |
---|
| 70 | loc_dir => _util_of_loc_func('dir'), |
---|
| 71 | loc_export => _util_of_loc_func('export'), |
---|
| 72 | loc_export_ok => _util_of_loc_func('export_ok'), |
---|
| 73 | loc_exists => _util_of_loc_func('test_exists'), |
---|
| 74 | loc_find => _util_of_loc_func('find'), |
---|
| 75 | loc_kw_ctx => _util_of_loc_func('kw_ctx'), |
---|
| 76 | loc_kw_ctx_load => _util_of_loc_func('kw_ctx_load'), |
---|
| 77 | loc_kw_iter => _util_of_loc_func('kw_iter'), |
---|
| 78 | loc_kw_load_rev_prop => _util_of_loc_func('kw_load_rev_prop'), |
---|
| 79 | loc_kw_prefix => _util_of_func('locator', 'kw_prefix'), |
---|
| 80 | loc_origin => _util_of_loc_func('origin'), |
---|
| 81 | loc_reader => _util_of_loc_func('reader'), |
---|
| 82 | loc_rel2abs => _util_of_loc_func('rel2abs'), |
---|
| 83 | loc_trunk_at_head => _util_of_loc_func('trunk_at_head'), |
---|
| 84 | loc_what_type => _util_of_loc_func('what_type'), |
---|
| 85 | loc_up_iter => _util_of_loc_func('up_iter'), |
---|
| 86 | ns_cat => \&_ns_cat, |
---|
| 87 | ns_common => \&_ns_common, |
---|
| 88 | ns_in_set => \&_ns_in_set, |
---|
| 89 | ns_iter => \&_ns_iter, |
---|
| 90 | ns_sep => sub {$_[0]->{ns_sep}}, |
---|
| 91 | report => _util_of_func('reporter', 'report'), |
---|
| 92 | shell => _util_of_func('shell', 'invoke'), |
---|
| 93 | shell_simple => _util_of_func('shell', 'invoke_simple'), |
---|
| 94 | shell_which => _util_of_func('shell', 'which'), |
---|
| 95 | task_runner => _util_of_func('task_runner', 'main'), |
---|
| 96 | timer => \&_timer, |
---|
| 97 | uri_match => \&_uri_match, |
---|
| 98 | util_of_event => _util_impl_func('event'), |
---|
| 99 | util_of_report => _util_impl_func('reporter'), |
---|
| 100 | version => \&_version, |
---|
| 101 | ); |
---|
| 102 | # The default paths to the configuration files. |
---|
| 103 | our @FCM1_KEYWORD_FILES = ( |
---|
| 104 | catfile((getpwuid($<))[7], qw{.fcm}), |
---|
| 105 | ); |
---|
| 106 | our @CONF_PATHS = ( |
---|
| 107 | catfile($FindBin::Bin, qw{.. etc fcm}), |
---|
| 108 | catfile((getpwuid($<))[7], qw{.met-um fcm}), |
---|
| 109 | catfile((getpwuid($<))[7], qw{.metomi fcm}), |
---|
| 110 | ); |
---|
| 111 | our %CFG_BASENAME_OF = ( |
---|
| 112 | external => 'external.cfg', |
---|
| 113 | keyword => 'keyword.cfg', |
---|
| 114 | ); |
---|
| 115 | # Values of external commands |
---|
| 116 | our %EXTERNAL_VALUE_OF = ( |
---|
| 117 | 'browser' => 'firefox', |
---|
| 118 | 'diff3' => 'diff3', |
---|
| 119 | 'diff3.flags' => '-E -m', |
---|
| 120 | 'graphic-diff' => 'xxdiff', |
---|
| 121 | 'graphic-merge' => 'xxdiff', |
---|
| 122 | 'ssh' => 'ssh', |
---|
| 123 | 'ssh.flags' => '-n -oBatchMode=yes', |
---|
| 124 | 'rsync' => 'rsync', |
---|
| 125 | 'rsync.flags' => '-a --exclude=.* --delete-excluded --timeout=900' |
---|
| 126 | . ' --rsh="ssh -oBatchMode=yes"', |
---|
| 127 | ); |
---|
| 128 | # The name-space separator |
---|
| 129 | our $NS_SEP = '/'; |
---|
| 130 | # The (keys) named utilities and their implementation classes. |
---|
| 131 | our %UTIL_CLASS_OF = ( |
---|
| 132 | config_reader => 'FCM::Util::ConfigReader', |
---|
| 133 | event => 'FCM::Util::Event', |
---|
| 134 | locator => 'FCM::Util::Locator', |
---|
| 135 | reporter => 'FCM::Util::Reporter', |
---|
| 136 | shell => 'FCM::Util::Shell', |
---|
| 137 | task_runner => 'FCM::Util::TaskRunner', |
---|
| 138 | ); |
---|
| 139 | |
---|
| 140 | # Alias |
---|
| 141 | my $E = 'FCM::Util::Exception'; |
---|
| 142 | |
---|
| 143 | # Regular expression: match a URI |
---|
| 144 | my $RE_URI = qr/ |
---|
| 145 | \A (?# start) |
---|
| 146 | ( (?# capture 1, scheme, start) |
---|
| 147 | [A-Za-z] (?# alpha) |
---|
| 148 | [\w\+\-\.]* (?# optional alpha, numeric, plus, minus and dot) |
---|
| 149 | ) (?# capture 1, scheme, end) |
---|
| 150 | : (?# colon) |
---|
| 151 | (.*) (?# capture 2, opaque, rest of string) |
---|
| 152 | \z (?# end) |
---|
| 153 | /xms; |
---|
| 154 | |
---|
| 155 | # Creates the class. |
---|
| 156 | __PACKAGE__->class( |
---|
| 157 | { cfg_basename_of => {isa => '%', default => {%CFG_BASENAME_OF}}, |
---|
| 158 | conf_paths => {isa => '@', default => [@CONF_PATHS]}, |
---|
| 159 | event => '&', |
---|
| 160 | external_value_of => {isa => '%', default => {%EXTERNAL_VALUE_OF}}, |
---|
| 161 | ns_sep => {isa => '$', default => $NS_SEP}, |
---|
| 162 | util_class_of => {isa => '%', default => {%UTIL_CLASS_OF}}, |
---|
| 163 | util_of => '%', |
---|
| 164 | }, |
---|
| 165 | {init => \&_init, action_of => \%ACTION_OF}, |
---|
| 166 | ); |
---|
| 167 | |
---|
| 168 | # Initialises attributes. |
---|
| 169 | sub _init { |
---|
| 170 | my ($attrib_ref, $self) = @_; |
---|
| 171 | # Initialise the utilities |
---|
| 172 | while (my ($key, $util_class) = each(%{$attrib_ref->{util_class_of}})) { |
---|
| 173 | if (!defined($attrib_ref->{util_of}{$key})) { |
---|
| 174 | _class_load($attrib_ref, $util_class); |
---|
| 175 | $attrib_ref->{util_of}{$key} = $util_class->new({util => $self}); |
---|
| 176 | } |
---|
| 177 | } |
---|
| 178 | if (exists($ENV{FCM_CONF_PATH})) { |
---|
| 179 | $attrib_ref->{conf_paths} = [shellwords($ENV{FCM_CONF_PATH})]; |
---|
| 180 | } |
---|
| 181 | } |
---|
| 182 | |
---|
| 183 | # Loads the named configuration from its configuration files. |
---|
| 184 | sub _cfg_init { |
---|
| 185 | my ($attrib_ref, $basename, $action_ref) = @_; |
---|
| 186 | if (exists($ENV{FCM_CONF_PATH})) { |
---|
| 187 | $attrib_ref->{conf_paths} = [shellwords($ENV{FCM_CONF_PATH})]; |
---|
| 188 | } |
---|
| 189 | for my $path ( |
---|
| 190 | grep {-f} map {catfile($_, $basename)} @{$attrib_ref->{conf_paths}} |
---|
| 191 | ) { |
---|
| 192 | my $config_reader = $ACTION_OF{config_reader}->( |
---|
| 193 | $attrib_ref, FCM::Context::Locator->new($path), |
---|
| 194 | ); |
---|
| 195 | $action_ref->($config_reader); |
---|
| 196 | } |
---|
| 197 | } |
---|
| 198 | |
---|
| 199 | # Loads a class/package. |
---|
| 200 | sub _class_load { |
---|
| 201 | my ($attrib_ref, $name, $test_method) = @_; |
---|
| 202 | $test_method ||= 'new'; |
---|
| 203 | if (!UNIVERSAL::can($name, $test_method)) { |
---|
| 204 | eval('require ' . $name); |
---|
| 205 | if (my $e = $@) { |
---|
| 206 | return $E->throw($E->CLASS_LOADER, $name, $e); |
---|
| 207 | } |
---|
| 208 | } |
---|
| 209 | return $name; |
---|
| 210 | } |
---|
| 211 | |
---|
| 212 | # Invokes an event. |
---|
| 213 | sub _event { |
---|
| 214 | my ($attrib_ref, $event, @args) = @_; |
---|
| 215 | if (!blessed($event)) { |
---|
| 216 | $event = FCM::Context::Event->new({code => $event, args => \@args}), |
---|
| 217 | } |
---|
| 218 | $attrib_ref->{'util_of'}{'event'}->main($event); |
---|
| 219 | } |
---|
| 220 | |
---|
| 221 | # Returns the value of an external tool. |
---|
| 222 | { my $EXTERNAL_CFG_INIT; |
---|
| 223 | sub _external_cfg_get { |
---|
| 224 | my ($attrib_ref, $key) = @_; |
---|
| 225 | my $value_hash_ref = $attrib_ref->{external_value_of}; |
---|
| 226 | if (!$EXTERNAL_CFG_INIT) { |
---|
| 227 | $EXTERNAL_CFG_INIT = 1; |
---|
| 228 | _cfg_init( |
---|
| 229 | $attrib_ref, |
---|
| 230 | $attrib_ref->{cfg_basename_of}{external}, |
---|
| 231 | sub { |
---|
| 232 | my $config_reader = shift(); |
---|
| 233 | while (defined(my $entry = $config_reader->())) { |
---|
| 234 | my $k = $entry->get_label(); |
---|
| 235 | if ($k && exists($value_hash_ref->{$k})) { |
---|
| 236 | $value_hash_ref->{$k} = $entry->get_value(); |
---|
| 237 | } |
---|
| 238 | } |
---|
| 239 | } |
---|
| 240 | ); |
---|
| 241 | } |
---|
| 242 | if (!$key || !exists($value_hash_ref->{$key})) { |
---|
| 243 | return; |
---|
| 244 | } |
---|
| 245 | return $value_hash_ref->{$key}; |
---|
| 246 | } |
---|
| 247 | } |
---|
| 248 | |
---|
| 249 | # Returns the checksum of the content in a file system path. |
---|
| 250 | sub _file_checksum { |
---|
| 251 | my ($attrib_ref, $path, $algorithm) = @_; |
---|
| 252 | my $handle = _file_load_handle($attrib_ref, $path); |
---|
| 253 | binmode($handle); |
---|
| 254 | $algorithm ||= 'md5'; |
---|
| 255 | my $digest = $algorithm eq 'md5' |
---|
| 256 | ? Digest::MD5->new() : Digest::SHA->new($algorithm); |
---|
| 257 | $digest->addfile($handle); |
---|
| 258 | my $checksum = $digest->hexdigest(); |
---|
| 259 | close($handle); |
---|
| 260 | return $checksum; |
---|
| 261 | } |
---|
| 262 | |
---|
| 263 | # Returns the file extension of a file system path. |
---|
| 264 | sub _file_ext { |
---|
| 265 | my ($attrib_ref, $path) = @_; |
---|
| 266 | my $pos_of_dot = rindex($path, q{.}); |
---|
| 267 | if ($pos_of_dot == -1) { |
---|
| 268 | return (wantarray() ? (undef, $path) : undef); |
---|
| 269 | } |
---|
| 270 | my $ext = substr($path, $pos_of_dot + 1); |
---|
| 271 | wantarray() ? ($ext, substr($path, 0, $pos_of_dot)) : $ext; |
---|
| 272 | } |
---|
| 273 | |
---|
| 274 | # Loads the first $n lines from a file system path. |
---|
| 275 | sub _file_head { |
---|
| 276 | my ($attrib_ref, $path, $n) = @_; |
---|
| 277 | $n ||= 1; |
---|
| 278 | my $handle = _file_load_handle(@_); |
---|
| 279 | my $content = q{}; |
---|
| 280 | for (1 .. $n) { |
---|
| 281 | $content .= readline($handle); |
---|
| 282 | } |
---|
| 283 | close($handle); |
---|
| 284 | (wantarray() ? (map {$_ . "\n"} split("\n", $content)) : $content); |
---|
| 285 | } |
---|
| 286 | |
---|
| 287 | # Loads the contents from a file system path. |
---|
| 288 | sub _file_load { |
---|
| 289 | my ($attrib_ref, $path) = @_; |
---|
| 290 | my $handle = _file_load_handle(@_); |
---|
| 291 | my $content = do {local($/); readline($handle)}; |
---|
| 292 | close($handle); |
---|
| 293 | (wantarray() ? (map {$_ . "\n"} split("\n", $content)) : $content); |
---|
| 294 | } |
---|
| 295 | |
---|
| 296 | # Opens a file handle to read from a file system path. |
---|
| 297 | sub _file_load_handle { |
---|
| 298 | my ($attrib_ref, $path) = @_; |
---|
| 299 | open(my($handle), '<', $path) || return $E->throw($E->IO, $path, $!); |
---|
| 300 | $handle; |
---|
| 301 | } |
---|
| 302 | |
---|
| 303 | # Returns the MD5 checksum of the content in a file system path. |
---|
| 304 | sub _file_md5 { |
---|
| 305 | my ($attrib_ref, $path) = @_; |
---|
| 306 | _file_checksum($attrib_ref, $path, 'md5'); |
---|
| 307 | } |
---|
| 308 | |
---|
| 309 | # Saves content to a file system path. |
---|
| 310 | sub _file_save { |
---|
| 311 | my ($attrib_ref, $path, $content) = @_; |
---|
| 312 | if (!-e dirname($path)) { |
---|
| 313 | eval {mkpath(dirname($path))}; |
---|
| 314 | if (my $e = $@) { |
---|
| 315 | return $E->throw($E->IO, $path, $e); |
---|
| 316 | } |
---|
| 317 | } |
---|
| 318 | open(my($handle), '>', $path) || return $E->throw($E->IO, $path, $!); |
---|
| 319 | if (ref($content) && ref($content) eq 'ARRAY') { |
---|
| 320 | print($handle @{$content}) || return $E->throw($E->IO, $path, $!); |
---|
| 321 | } |
---|
| 322 | else { |
---|
| 323 | print($handle $content) || return $E->throw($E->IO, $path, $!); |
---|
| 324 | } |
---|
| 325 | close($handle) || return $E->throw($E->IO, $path, $!); |
---|
| 326 | } |
---|
| 327 | |
---|
| 328 | # Expand leading ~ and ~USER syntax in $path and return the resulting string. |
---|
| 329 | sub _file_tilde_expand { |
---|
| 330 | my ($attrib_ref, $path) = @_; |
---|
| 331 | $path =~ s{\A~([^/]*)}{$1 ? (getpwnam($1))[7] : (getpwuid($<))[7]}exms; |
---|
| 332 | return $path; |
---|
| 333 | } |
---|
| 334 | |
---|
| 335 | # Compares contents of 2 HASH references. |
---|
| 336 | sub _hash_cmp { |
---|
| 337 | my ($attrib_ref, $hash_1_ref, $hash_2_ref, $keys_only) = @_; |
---|
| 338 | my %hash_2 = %{$hash_2_ref}; |
---|
| 339 | my %modified; |
---|
| 340 | while (my ($key, $v1) = each(%{$hash_1_ref})) { |
---|
| 341 | if (exists($hash_2{$key})) { |
---|
| 342 | my $v2 = $hash_2{$key}; |
---|
| 343 | if ( !$keys_only |
---|
| 344 | && ( |
---|
| 345 | defined($v1) && defined($v2) && $v1 ne $v2 |
---|
| 346 | || defined($v1) && !defined($v2) |
---|
| 347 | || !defined($v1) && defined($v2) |
---|
| 348 | ) |
---|
| 349 | ) { |
---|
| 350 | $modified{$key} = 0; |
---|
| 351 | } |
---|
| 352 | delete($hash_2{$key}); |
---|
| 353 | } |
---|
| 354 | else { |
---|
| 355 | $modified{$key} = -1; |
---|
| 356 | } |
---|
| 357 | } |
---|
| 358 | while (my $key = each(%hash_2)) { |
---|
| 359 | if (!exists($hash_1_ref->{$key})) { |
---|
| 360 | $modified{$key} = 1; |
---|
| 361 | } |
---|
| 362 | } |
---|
| 363 | return %modified; |
---|
| 364 | } |
---|
| 365 | |
---|
| 366 | # Concatenates 2 name-spaces. |
---|
| 367 | sub _ns_cat { |
---|
| 368 | my ($attrib_ref, @ns_list) = @_; |
---|
| 369 | join( |
---|
| 370 | $attrib_ref->{ns_sep}, |
---|
| 371 | grep {$_ && $_ ne $attrib_ref->{ns_sep}} @ns_list, |
---|
| 372 | ); |
---|
| 373 | } |
---|
| 374 | |
---|
| 375 | # Returns the common parts of 2 name-spaces. |
---|
| 376 | sub _ns_common { |
---|
| 377 | my ($attrib_ref, $ns1, $ns2) = @_; |
---|
| 378 | my $iter1 = _ns_iter($attrib_ref, $ns1); |
---|
| 379 | my $iter2 = _ns_iter($attrib_ref, $ns2); |
---|
| 380 | my $common_ns = q{}; |
---|
| 381 | while (defined(my $s1 = $iter1->()) && defined(my $s2 = $iter2->())) { |
---|
| 382 | if ($s1 ne $s2) { |
---|
| 383 | return $common_ns; |
---|
| 384 | } |
---|
| 385 | $common_ns = $s1; |
---|
| 386 | } |
---|
| 387 | return $common_ns; |
---|
| 388 | } |
---|
| 389 | |
---|
| 390 | # Returns true if $ns is in one of the name-spaces given by keys(%set). |
---|
| 391 | sub _ns_in_set { |
---|
| 392 | my ($attrib_ref, $ns, $ns_set_ref) = @_; |
---|
| 393 | if (!keys(%{$ns_set_ref})) { |
---|
| 394 | return; |
---|
| 395 | } |
---|
| 396 | my @ns_list; |
---|
| 397 | my $ns_iter = _ns_iter($attrib_ref, $ns); |
---|
| 398 | while (defined(my $n = $ns_iter->())) { |
---|
| 399 | push(@ns_list, $n); |
---|
| 400 | } |
---|
| 401 | grep {exists($ns_set_ref->{$_})} @ns_list; |
---|
| 402 | } |
---|
| 403 | |
---|
| 404 | # Returns an iterator to walk up/down a name-space. |
---|
| 405 | sub _ns_iter { |
---|
| 406 | my ($attrib_ref, $ns, $up) = @_; |
---|
| 407 | if ($ns eq $attrib_ref->{ns_sep}) { |
---|
| 408 | $ns = q{}; |
---|
| 409 | } |
---|
| 410 | my @give = split($attrib_ref->{ns_sep}, $ns); |
---|
| 411 | my @take = (); |
---|
| 412 | my $next = q{}; |
---|
| 413 | if ($up) { |
---|
| 414 | @give = reverse(@give); |
---|
| 415 | $next = $ns; |
---|
| 416 | } |
---|
| 417 | sub { |
---|
| 418 | my $ret = $next; |
---|
| 419 | $next = undef; |
---|
| 420 | if (@give) { |
---|
| 421 | push(@take, shift(@give)); |
---|
| 422 | $next = join($attrib_ref->{ns_sep}, ($up ? reverse(@give) : @take)); |
---|
| 423 | } |
---|
| 424 | return $ret; |
---|
| 425 | }; |
---|
| 426 | } |
---|
| 427 | |
---|
| 428 | # Returns a timer. |
---|
| 429 | sub _timer { |
---|
| 430 | my ($attrib_ref, $start_ref) = @_; |
---|
| 431 | $start_ref ||= [gettimeofday()]; |
---|
| 432 | sub {tv_interval($start_ref)}; |
---|
| 433 | } |
---|
| 434 | |
---|
| 435 | # Matches a URI. |
---|
| 436 | sub _uri_match { |
---|
| 437 | my ($attrib_ref, $string) = @_; |
---|
| 438 | $string =~ $RE_URI; |
---|
| 439 | } |
---|
| 440 | |
---|
| 441 | # Returns a function to return/set the object in the "util_of" basket. |
---|
| 442 | sub _util_impl_func { |
---|
| 443 | my ($id) = @_; |
---|
| 444 | sub { |
---|
| 445 | my ($attrib_ref, $value) = @_; |
---|
| 446 | if (defined($value) && ref($value) && reftype($value) eq 'CODE') { |
---|
| 447 | $attrib_ref->{'util_of'}{$id} = $value; |
---|
| 448 | } |
---|
| 449 | $attrib_ref->{'util_of'}{$id}; |
---|
| 450 | }; |
---|
| 451 | } |
---|
| 452 | |
---|
| 453 | # Returns a function to delegate a method to a utility in the "util_of" basket. |
---|
| 454 | sub _util_of_func { |
---|
| 455 | my ($id, $method) = @_; |
---|
| 456 | sub { |
---|
| 457 | my $attrib_ref = shift(); |
---|
| 458 | $attrib_ref->{util_of}{$id}->(($method ? ($method) : ()), @_); |
---|
| 459 | }; |
---|
| 460 | } |
---|
| 461 | |
---|
| 462 | # Returns a function to delegate a method to the locator utility. |
---|
| 463 | { my $KEYWORD_CFG_INIT; |
---|
| 464 | sub _util_of_loc_func { |
---|
| 465 | my ($method) = @_; |
---|
| 466 | sub { |
---|
| 467 | my $attrib_ref = shift(); |
---|
| 468 | if (!$KEYWORD_CFG_INIT) { |
---|
| 469 | $KEYWORD_CFG_INIT = 1; |
---|
| 470 | my $config_upgrade = FCM::Util::ConfigUpgrade->new(); |
---|
| 471 | for my $path (grep {-f} @FCM1_KEYWORD_FILES) { |
---|
| 472 | my $config_reader = $ACTION_OF{config_reader}->( |
---|
| 473 | $attrib_ref, |
---|
| 474 | FCM::Context::Locator->new($path), |
---|
| 475 | \%FCM::Util::ConfigReader::FCM1_ATTRIB, |
---|
| 476 | ); |
---|
| 477 | $ACTION_OF{loc_kw_ctx_load}->( |
---|
| 478 | $attrib_ref, |
---|
| 479 | sub {$config_upgrade->upgrade($config_reader->())}, |
---|
| 480 | ); |
---|
| 481 | } |
---|
| 482 | _cfg_init( |
---|
| 483 | $attrib_ref, |
---|
| 484 | $attrib_ref->{cfg_basename_of}{keyword}, |
---|
| 485 | sub {$ACTION_OF{loc_kw_ctx_load}->($attrib_ref, @_)}, |
---|
| 486 | ); |
---|
| 487 | } |
---|
| 488 | $attrib_ref->{util_of}{locator}->($method, @_); |
---|
| 489 | }; |
---|
| 490 | } |
---|
| 491 | } |
---|
| 492 | |
---|
| 493 | # Returns the FCM version string. |
---|
| 494 | { my $FCM_VERSION; |
---|
| 495 | sub _version { |
---|
| 496 | my ($attrib_ref) = @_; |
---|
| 497 | if (!defined($FCM_VERSION)) { |
---|
| 498 | my $fcm_home = dirname($FindBin::Bin); |
---|
| 499 | # Try "git describe" |
---|
| 500 | my $value_hash_ref = eval { |
---|
| 501 | $ACTION_OF{shell_simple}->( |
---|
| 502 | $attrib_ref, |
---|
| 503 | ['git', "--git-dir=$FindBin::Bin/../.git", 'describe'], |
---|
| 504 | ); |
---|
| 505 | }; |
---|
| 506 | if (my $e = $@) { |
---|
| 507 | if (!$E->caught($e)) { |
---|
| 508 | die($e); |
---|
| 509 | } |
---|
| 510 | $@ = undef; |
---|
| 511 | } |
---|
| 512 | my $version; |
---|
| 513 | if ($value_hash_ref->{o} && !$value_hash_ref->{rc}) { |
---|
| 514 | chomp($value_hash_ref->{o}); |
---|
| 515 | $version = $value_hash_ref->{o}; |
---|
| 516 | } |
---|
| 517 | else { |
---|
| 518 | # Read fcm-version.js file |
---|
| 519 | my $path = catfile($fcm_home, qw{doc etc fcm-version.js}); |
---|
| 520 | open(my($handle), '<', $path) || die("$path: $!"); |
---|
| 521 | my $content = do {local($/); readline($handle)}; |
---|
| 522 | close($handle); |
---|
| 523 | ($version) = $content =~ qr{\AFCM\.VERSION="(.*)";}msx; |
---|
| 524 | } |
---|
| 525 | $FCM_VERSION = sprintf("%s (%s)", $version, $fcm_home); |
---|
| 526 | } |
---|
| 527 | return $FCM_VERSION; |
---|
| 528 | } |
---|
| 529 | } |
---|
| 530 | |
---|
| 531 | # ------------------------------------------------------------------------------ |
---|
| 532 | 1; |
---|
| 533 | __END__ |
---|
| 534 | |
---|
| 535 | =head1 NAME |
---|
| 536 | |
---|
| 537 | FCM::Util |
---|
| 538 | |
---|
| 539 | =head1 SYNOPSIS |
---|
| 540 | |
---|
| 541 | use FCM::Util; |
---|
| 542 | $u = FCM::Util->new(); |
---|
| 543 | $u->class_load('Foo'); |
---|
| 544 | |
---|
| 545 | =head1 DESCRIPTION |
---|
| 546 | |
---|
| 547 | Utilities used by the FCM system. |
---|
| 548 | |
---|
| 549 | =head1 METHODS |
---|
| 550 | |
---|
| 551 | =over 4 |
---|
| 552 | |
---|
| 553 | =item $class->new(\%attrib) |
---|
| 554 | |
---|
| 555 | Returns a new instance. The %attrib hash can be used configure the behaviour of |
---|
| 556 | the instance: |
---|
| 557 | |
---|
| 558 | =over 4 |
---|
| 559 | |
---|
| 560 | =item conf_paths |
---|
| 561 | |
---|
| 562 | The search paths to the configuration files. The default is the value in |
---|
| 563 | @FCM::Util::CONF_PATHS. |
---|
| 564 | |
---|
| 565 | =item cfg_basename_of |
---|
| 566 | |
---|
| 567 | A HASH to map the named configuration with the base names of their paths. |
---|
| 568 | (default=%CFG_BASENAME_OF) |
---|
| 569 | |
---|
| 570 | =item external_value_of |
---|
| 571 | |
---|
| 572 | A HASH to map the named external tools with their default values. |
---|
| 573 | (default=%EXTERNAL_VALUE_OF) |
---|
| 574 | |
---|
| 575 | =item event |
---|
| 576 | |
---|
| 577 | A CODE to handle event. |
---|
| 578 | |
---|
| 579 | =item ns_sep |
---|
| 580 | |
---|
| 581 | The name space separator. (default=/) |
---|
| 582 | |
---|
| 583 | =item util_class_of |
---|
| 584 | |
---|
| 585 | A HASH to map (keys) utility names to (values) their implementation classes. See |
---|
| 586 | %FCM::System::UTIL_CLASS_OF. |
---|
| 587 | |
---|
| 588 | =item util_of |
---|
| 589 | |
---|
| 590 | A HASH to map (keys) utility names to (values) their implementation instances. |
---|
| 591 | |
---|
| 592 | =back |
---|
| 593 | |
---|
| 594 | =item $u->cfg_init($basename,\&action) |
---|
| 595 | |
---|
| 596 | Search site/user configuration given by $basename. Invoke the callback |
---|
| 597 | &action($config_reader) for each configuration file found. |
---|
| 598 | |
---|
| 599 | =item $u->class_load($name,$test_method) |
---|
| 600 | |
---|
| 601 | If $name can call $test_method, returns $name. (If $test_method is not defined, |
---|
| 602 | the default is "new".) Otherwise, calls require($name). Returns $name. |
---|
| 603 | |
---|
| 604 | =item $u->config_reader($locator,\%reader_attrib) |
---|
| 605 | |
---|
| 606 | Returns an iterator for getting the configuration entries from $locator (which |
---|
| 607 | should be an instance of L<FCM::Context::Locator|FCM::Context::Locator>. |
---|
| 608 | |
---|
| 609 | The iterator returns the next useful entry of the configuration file as an |
---|
| 610 | object of L<FCM::Context::ConfigEntry|FCM::Context::ConfigEntry>. It returns |
---|
| 611 | under if there is no more useful entry to return. |
---|
| 612 | |
---|
| 613 | The %reader_attrib may be used to override the default attributes. The HASH |
---|
| 614 | should contain a {parser} and a {processor}. The {parser} is a CODE reference to |
---|
| 615 | parse a declaration in the configuration file into an entry. The {processor} is |
---|
| 616 | a CODE reference to process the entry. If the {processor} returns true, the |
---|
| 617 | entry is considered a special entry (e.g. a variable declaration or an |
---|
| 618 | C<include> declaration) that is processed, and will not be returned by the |
---|
| 619 | iterator. |
---|
| 620 | |
---|
| 621 | The %reader_attrib can be defined using the following pre-defined sets: |
---|
| 622 | |
---|
| 623 | =over 4 |
---|
| 624 | |
---|
| 625 | =item %FCM::Util::ConfigReader::FCM1_ATTRIB |
---|
| 626 | |
---|
| 627 | Using this will generate a reader for configuration files written in the FCM 1 |
---|
| 628 | format. |
---|
| 629 | |
---|
| 630 | =item %FCM::Util::ConfigReader::FCM2_ATTRIB |
---|
| 631 | |
---|
| 632 | Using this will generate a reader for configuration files written in the FCM 2 |
---|
| 633 | format. (default) |
---|
| 634 | |
---|
| 635 | =back |
---|
| 636 | |
---|
| 637 | In addition, $reader_attrib{event_level} can be used to adjust the event |
---|
| 638 | verbosity level. |
---|
| 639 | |
---|
| 640 | The parser and the processor are called with a %state, which contains the |
---|
| 641 | current state of the reader, and has the following elements: |
---|
| 642 | |
---|
| 643 | =over 4 |
---|
| 644 | |
---|
| 645 | =item cont |
---|
| 646 | |
---|
| 647 | This is set to true if there is a continue marker at the end of the current |
---|
| 648 | line. The next line should be parsed as part of the current context. |
---|
| 649 | |
---|
| 650 | =item ctx |
---|
| 651 | |
---|
| 652 | The context of the current entry, which should be an instance of |
---|
| 653 | L<FCM::Context::ConfigEntry|FCM::Context::ConfigEntry>. |
---|
| 654 | |
---|
| 655 | =item line |
---|
| 656 | |
---|
| 657 | The content of the current line. |
---|
| 658 | |
---|
| 659 | =item stack |
---|
| 660 | |
---|
| 661 | An ARRAY reference that represents an include stack. The top of the stack |
---|
| 662 | (the final element) represents the most current file being read. An include file |
---|
| 663 | will be put on top of the stack, and removed when EOF is reached. When the stack |
---|
| 664 | is empty, the iterator is exhausted. |
---|
| 665 | |
---|
| 666 | Each element of the stack is an 4-element ARRAY reference. Element 1 is the |
---|
| 667 | L<FCM::Context::Locator|FCM::Context::Locator> object that represents the |
---|
| 668 | current file. Element 2 is the line number of the current file. Element 3 is the |
---|
| 669 | file handle for reading the current file. Element 4 is a CODE reference with an |
---|
| 670 | interface $f->($path), for turning $path from a relative location under the |
---|
| 671 | container of the current file into an absolute location. |
---|
| 672 | |
---|
| 673 | =item var |
---|
| 674 | |
---|
| 675 | A HASH reference containing the variables (from the environment and local to the |
---|
| 676 | configuration file) that can be used for substitution. |
---|
| 677 | |
---|
| 678 | =back |
---|
| 679 | |
---|
| 680 | =item $u->external_cfg_get($key) |
---|
| 681 | |
---|
| 682 | Returns the value of a named tool. |
---|
| 683 | |
---|
| 684 | =item $u->event($event,@args) |
---|
| 685 | |
---|
| 686 | Raises an event. The 1st argument $event can either be a blessed reference of |
---|
| 687 | L<FCM::Context::Event|FCM::Context::Event> or a valid event code. If the former |
---|
| 688 | is true, @args is not used, otherwise, @args should be the event arguments for |
---|
| 689 | the specified event code. |
---|
| 690 | |
---|
| 691 | =item $u->file_checksum($path, $algorithm) |
---|
| 692 | |
---|
| 693 | Returns the checksum of $path. If $algorithm is not specified, the default |
---|
| 694 | algorithm to use is MD5. Otherwise, any algorithm supported by Perl's |
---|
| 695 | Digest::SHA module can be used. |
---|
| 696 | |
---|
| 697 | =item $u->file_ext($path) |
---|
| 698 | |
---|
| 699 | Returns file extension of $path. E.g.: |
---|
| 700 | |
---|
| 701 | my $path = '/foo/bar.baz'; |
---|
| 702 | my $extension = $u->file_ext($path); # 'baz' |
---|
| 703 | my ($extension, $root) = $u->file_ext($path); # ('baz', '/foo/bar') |
---|
| 704 | |
---|
| 705 | =item $u->file_head($path, $n) |
---|
| 706 | |
---|
| 707 | Loads $n lines (or 1 line if $n not specified) from a $path in the file system. |
---|
| 708 | In scalar context, returns the content in a scalar. In list context, separate |
---|
| 709 | the content by the new line character "\n", and returns the resulting list. |
---|
| 710 | |
---|
| 711 | =item $u->file_load($path) |
---|
| 712 | |
---|
| 713 | Loads contents from a $path in the file system. In scalar context, returns the |
---|
| 714 | content in a scalar. In list context, separate the content by the new line |
---|
| 715 | character "\n", and returns the resulting list. |
---|
| 716 | |
---|
| 717 | =item $u->file_load_handle($path) |
---|
| 718 | |
---|
| 719 | Returns a file handle for loading contents from $path. |
---|
| 720 | |
---|
| 721 | =item $u->file_md5($path) |
---|
| 722 | |
---|
| 723 | Deprecated. Equivalent to $u->file_checksum($path, 'md5'). |
---|
| 724 | |
---|
| 725 | =item $u->file_save($path, $content) |
---|
| 726 | |
---|
| 727 | Saves $content to a $path in the file system. |
---|
| 728 | |
---|
| 729 | =item $u->file_tilde_expand($path) |
---|
| 730 | |
---|
| 731 | Expand any leading "~" or "~USER" syntax to the HOME directory of the current |
---|
| 732 | user or the HOME directory of USER. Return the modified string. |
---|
| 733 | |
---|
| 734 | =item $u->hash_cmp(\%hash_1,\%hash_2,$keys_only) |
---|
| 735 | |
---|
| 736 | Compares the contents of 2 HASH references. If $keys_only is specified, only |
---|
| 737 | compares the keys. Returns a HASH where each element represents a difference |
---|
| 738 | between %hash_1 and %hash_2 - if the value is positive, the key exists in |
---|
| 739 | %hash_2 but not %hash_1, if the value is negative, the key exists in %hash_1 but |
---|
| 740 | not %hash_2, and if the value is zero, the key exists in both, but the values |
---|
| 741 | are different. |
---|
| 742 | |
---|
| 743 | =item $u->loc_as_invariant($locator) |
---|
| 744 | |
---|
| 745 | If the $locator->get_value_level() is below FCM::Context::Locator->L_INVARIANT, |
---|
| 746 | determines the invariant value of $locator, and sets its value to the result. |
---|
| 747 | Returns $locator->get_value(). |
---|
| 748 | |
---|
| 749 | See L<FCM::Context::Locator|FCM::Context::Locator> for information on locator |
---|
| 750 | value level. |
---|
| 751 | |
---|
| 752 | =item $u->loc_as_keyword($locator) |
---|
| 753 | |
---|
| 754 | Calls $u->loc_as_normalised($locator) if $locator->get_value_level() is below |
---|
| 755 | FCM::Context::Locator->L_NORMALISED. Returns the value of the locator as an FCM |
---|
| 756 | keyword, where possible. |
---|
| 757 | |
---|
| 758 | =item $u->loc_as_normalised($locator) |
---|
| 759 | |
---|
| 760 | If the $locator->get_value_level() is below FCM::Context::Locator->L_NORMALISED, |
---|
| 761 | determines the normalised value of $locator, and sets its value to the result. |
---|
| 762 | Returns $locator->get_value(). |
---|
| 763 | |
---|
| 764 | See L<FCM::Context::Locator|FCM::Context::Locator> for information on locator |
---|
| 765 | value level. |
---|
| 766 | |
---|
| 767 | =item $u->loc_as_parsed($locator) |
---|
| 768 | |
---|
| 769 | If the $locator->get_value_level() is below FCM::Context::Locator->L_PARSED, |
---|
| 770 | determines the parsed value of $locator, and sets its value to the result. |
---|
| 771 | Returns $locator->get_value(). |
---|
| 772 | |
---|
| 773 | See L<FCM::Context::Locator|FCM::Context::Locator> for information on locator |
---|
| 774 | value level. |
---|
| 775 | |
---|
| 776 | =item $u->loc_browser_url($locator) |
---|
| 777 | |
---|
| 778 | Calls $u->loc_as_normalised($locator) if $locator->get_value_level() is below |
---|
| 779 | FCM::Context::Locator->L_NORMALISED. Returns the value of the locator as a |
---|
| 780 | browser URL, where possible. |
---|
| 781 | |
---|
| 782 | =item $u->loc_cat($locator,@paths) |
---|
| 783 | |
---|
| 784 | Calls $u->loc_as_parsed($locator) if $locator->get_value_level() is below |
---|
| 785 | FCM::Context::Locator->L_PARSED. Concatenates the value of the $locator with the |
---|
| 786 | given @paths according to the $locator type. Returns a new FCM::Context::Locator |
---|
| 787 | that represents the concatenated value. |
---|
| 788 | |
---|
| 789 | =item $u->loc_dir($locator) |
---|
| 790 | |
---|
| 791 | Calls $u->loc_as_parsed($locator) if $locator->get_value_level() is below |
---|
| 792 | FCM::Context::Locator->L_PARSED. Determines the "directory" name of the value of |
---|
| 793 | the $locator according to the $locator type. Returns a new FCM::Context::Locator |
---|
| 794 | that represents the resulting value. |
---|
| 795 | |
---|
| 796 | =item $u->loc_exists($locator) |
---|
| 797 | |
---|
| 798 | Calls $u->loc_as_normalised($locator) if $locator->get_value_level() is below |
---|
| 799 | FCM::Context::Locator->L_NORMALISED. Return a true value if the location |
---|
| 800 | represented by $locator exists. |
---|
| 801 | |
---|
| 802 | =item $u->loc_export($locator,$dest) |
---|
| 803 | |
---|
| 804 | Calls $u->loc_as_normalised($locator) if $locator->get_value_level() is below |
---|
| 805 | FCM::Context::Locator->L_NORMALISED. Exports the file or directory tree |
---|
| 806 | represented by $locator to a file system $dest. |
---|
| 807 | |
---|
| 808 | =item $u->loc_export_ok($locator) |
---|
| 809 | |
---|
| 810 | Calls $u->loc_as_parsed($locator) if $locator->get_value_level() is below |
---|
| 811 | FCM::Context::Locator->L_PARSED. Returns true if it is possible and safe to |
---|
| 812 | call $u->loc_export($locator). |
---|
| 813 | |
---|
| 814 | =item $u->loc_find($locator,\&callback) |
---|
| 815 | |
---|
| 816 | Searches the directory tree of $locator. Invokes &callback for each node with |
---|
| 817 | the following interface: |
---|
| 818 | |
---|
| 819 | $callback_ref->($locator_of_child_node, \%target_attrib); |
---|
| 820 | |
---|
| 821 | where %target_attrib contains the keys: |
---|
| 822 | |
---|
| 823 | =over 4 |
---|
| 824 | |
---|
| 825 | =item {is_dir} |
---|
| 826 | |
---|
| 827 | This is set to true if the child node is a directory. |
---|
| 828 | |
---|
| 829 | =item {last_modified_rev} |
---|
| 830 | |
---|
| 831 | This is set to the last modified revision of the child node, if relevant. |
---|
| 832 | |
---|
| 833 | =item {last_modified_time} |
---|
| 834 | |
---|
| 835 | This is set to the last modified time of the child node. |
---|
| 836 | |
---|
| 837 | =item {ns} |
---|
| 838 | |
---|
| 839 | This is set to the relative name-space (i.e. the relative path) of the child |
---|
| 840 | node. |
---|
| 841 | |
---|
| 842 | =back |
---|
| 843 | |
---|
| 844 | =item $u->loc_kw_ctx() |
---|
| 845 | |
---|
| 846 | Returns the keyword context (an instance of FCM::Context::Keyword). |
---|
| 847 | |
---|
| 848 | =item $u->loc_kw_ctx_load(@config_entry_iterators) |
---|
| 849 | |
---|
| 850 | Loads configuration entries into the keyword context. The |
---|
| 851 | @config_entry_iterators should be a list of CODE references, with the following |
---|
| 852 | calling interfaces: |
---|
| 853 | |
---|
| 854 | while (my $config_entry = $config_entry_iterator->()) { |
---|
| 855 | # ... $config_entry should be an instance of FCM::Context::ConfigEntry |
---|
| 856 | } |
---|
| 857 | |
---|
| 858 | =item $u->loc_kw_iter($locator) |
---|
| 859 | |
---|
| 860 | Returns an iterator. When called, the iterator returns location keyword entry |
---|
| 861 | context (as an instance of |
---|
| 862 | L<FCM::Context::Keyword::Entry::Location|FCM::Context::Keyword>) for $locator |
---|
| 863 | until exhausted. |
---|
| 864 | |
---|
| 865 | my $iterator = $u->loc_kw_iter($locator) |
---|
| 866 | while (my $kw_ctx_entry = $iterator->()) { |
---|
| 867 | # ... do something with $kw_ctx_entry |
---|
| 868 | } |
---|
| 869 | |
---|
| 870 | =item $u->loc_kw_load_rev_prop($entry) |
---|
| 871 | |
---|
| 872 | Loads the revision keywords to $entry |
---|
| 873 | (L<FCM::Context::Keyword::Entry::Location|FCM::Context::Keyword>), assuming that |
---|
| 874 | $entry is not an implied location keyword, and that the keyword locator points |
---|
| 875 | to a VCS location that supports setting up revision keywords in properties. |
---|
| 876 | |
---|
| 877 | =item $u->loc_kw_prefix() |
---|
| 878 | |
---|
| 879 | Returns the prefix of a FCM keyword. This should be "fcm". |
---|
| 880 | |
---|
| 881 | =item $u->loc_origin($locator) |
---|
| 882 | |
---|
| 883 | Calls $u->loc_as_parsed($locator) if $locator->get_value_level() is below |
---|
| 884 | FCM::Context::Locator->L_PARSED. Determines the origin of $locator, and returns |
---|
| 885 | a new FCM::Context::Locator that represents the result. E.g. if $locator points |
---|
| 886 | to a Subversion working copy, it returns a new locator that represents the URL |
---|
| 887 | of the working copy. |
---|
| 888 | |
---|
| 889 | =item $u->loc_reader($locator) |
---|
| 890 | |
---|
| 891 | Calls $u->loc_as_normalised($locator) if $locator->get_value_level() is below |
---|
| 892 | FCM::Context::Locator->L_NORMALISED. Returns a file handle for reading the |
---|
| 893 | content from $locator. |
---|
| 894 | |
---|
| 895 | =item $u->loc_rel2abs($locator,$locator_base) |
---|
| 896 | |
---|
| 897 | If the value of $locator is a relative path, sets it to an absolute path base on |
---|
| 898 | the $locator_base, provided that $locator and $locator_base is the same type. |
---|
| 899 | |
---|
| 900 | =item $u->loc_trunk_at_head($locator) |
---|
| 901 | |
---|
| 902 | Returns a string to represent the relative path to the latest main tree, if it |
---|
| 903 | is relevant for $locator. |
---|
| 904 | |
---|
| 905 | =item $u->loc_what_type($locator) |
---|
| 906 | |
---|
| 907 | Sets $locator->get_type() and returns its value. Currently, this can either be |
---|
| 908 | "svn" for a locator pointing to a Subversion resource or "fs" for a locator |
---|
| 909 | pointing to a file system resource. |
---|
| 910 | |
---|
| 911 | =item $u->loc_up_iter($locator) |
---|
| 912 | |
---|
| 913 | Returns an iterator that walks up the hierarchy of the $locator, according to |
---|
| 914 | its type. |
---|
| 915 | |
---|
| 916 | =item $u->ns_cat(@name_spaces) |
---|
| 917 | |
---|
| 918 | Concatenates name-spaces and returns the result. |
---|
| 919 | |
---|
| 920 | =item $u->ns_common($ns1,$ns2) |
---|
| 921 | |
---|
| 922 | Returns the common parts of 2 name-spaces. For example, if $ns1 is |
---|
| 923 | "egg/ham/bacon" and $ns2 is "egg/ham/sausage", it should return "egg/ham". |
---|
| 924 | |
---|
| 925 | =item $u->ns_in_set($ns,\%set) |
---|
| 926 | |
---|
| 927 | Returns true if $ns is in a name-space given by the keys of %set. |
---|
| 928 | |
---|
| 929 | =item $u->ns_iter($ns,$up) |
---|
| 930 | |
---|
| 931 | Returns an iterator that walks up or down a name-space. E.g.: |
---|
| 932 | |
---|
| 933 | $iter_ref = $u->ns_iter('a/bee/cee', $u->NS_ITER_UP); |
---|
| 934 | while (defined(my $item = $iter_ref->())) { |
---|
| 935 | print("[$item]"); |
---|
| 936 | } |
---|
| 937 | # should print: [a/bee/cee][a/bee][a][] |
---|
| 938 | |
---|
| 939 | $iter_ref = $u->ns_iter('a/bee/cee'); |
---|
| 940 | while (defined(my $item = $iter_ref->())) { |
---|
| 941 | print("[$item]"); |
---|
| 942 | } |
---|
| 943 | # should print: [][a][a/bee][a/bee/cee] |
---|
| 944 | |
---|
| 945 | =item $u->ns_sep() |
---|
| 946 | |
---|
| 947 | Returns the name-space separator, (i.e. normally "/"). |
---|
| 948 | |
---|
| 949 | =item $u->report(\%option,$message) |
---|
| 950 | |
---|
| 951 | Reports messages using $u->util_of_report(). The default is an instance of |
---|
| 952 | L<FCM::Util::Reporter|FCM::Util::Reporter>. See |
---|
| 953 | L<FCM::Util::Reporter|FCM::Util::Reporter> for detail. |
---|
| 954 | |
---|
| 955 | =item $u->shell($command,\%action_of) |
---|
| 956 | |
---|
| 957 | Invokes the $command, which can be scalar or a reference to an ARRAY. If a |
---|
| 958 | scalar is specified, it will be separated into an array using the shellwords() |
---|
| 959 | function in L<Text::ParseWords|Text::ParseWords>. If it is a reference to an |
---|
| 960 | ARRAY, the ARRAY will be passed to open3() as is. |
---|
| 961 | |
---|
| 962 | The %action_of should contain the actions for i: standard input, e: standard |
---|
| 963 | error output and o: standard output. The default for each of these is an |
---|
| 964 | anonymous subroutinue that does nothing. |
---|
| 965 | |
---|
| 966 | Each time the pipe to the child standard input is available for writing, it will |
---|
| 967 | call $action_of{i}->(). If it returns a defined value, the value will be written |
---|
| 968 | to the pipe. If it returns undef, the pipe will be closed. |
---|
| 969 | |
---|
| 970 | Each time the pipe from the child standard (error) output is available for |
---|
| 971 | reading, it will read some values to a buffer, and invoke the callback |
---|
| 972 | $action_of{o}->($buffer) (or $action_of{e}->($buffer)). The return value of the |
---|
| 973 | callback will be ignored. |
---|
| 974 | |
---|
| 975 | On normal completion, it returns the status code of the command and raises an |
---|
| 976 | FCM::Context::Event->SHELL event: |
---|
| 977 | |
---|
| 978 | Any abnormal failure will cause an instance of FCM::Util::Exception to be |
---|
| 979 | thrown. (The return of a non-zero status code by the child is considered a |
---|
| 980 | normal completion.) |
---|
| 981 | |
---|
| 982 | =item $u->shell_simple($command) |
---|
| 983 | |
---|
| 984 | Wraps $u->shell(), and returns a HASH reference containing {e} (the |
---|
| 985 | standard error), {o} (the standard output) and {rc} (the return code). |
---|
| 986 | |
---|
| 987 | =item $u->shell_which($name) |
---|
| 988 | |
---|
| 989 | Returns the full path of an executable command $name if it can be found in the |
---|
| 990 | system PATH. |
---|
| 991 | |
---|
| 992 | =item $u->task_runner($action_code_ref,$n_workers) |
---|
| 993 | |
---|
| 994 | Returns a runner of tasks. It can be configured to work in serial (default) or |
---|
| 995 | parallel. The runner has the following methods: |
---|
| 996 | |
---|
| 997 | $n_done = $runner->main($get_code_ref,$put_code_ref); |
---|
| 998 | $runner->destroy(); |
---|
| 999 | |
---|
| 1000 | For each $task (L<FCM::Context::Task|FCM::Context::Task>) returned by the |
---|
| 1001 | $get_code_ref->() iterator, invokes $action_ref->($task->get_ctx()). When |
---|
| 1002 | $action_ref returns, send the $task back to the caller by calling |
---|
| 1003 | $put_code_ref->($task). When it is done, the runner returns the number of tasks |
---|
| 1004 | it has done. |
---|
| 1005 | |
---|
| 1006 | The $runner->destroy() method should be called to destroy the $runner when it is |
---|
| 1007 | not longer used. |
---|
| 1008 | |
---|
| 1009 | =item $u->timer(\@start) |
---|
| 1010 | |
---|
| 1011 | Returns a CODE reference, which can be called to return the elapsed time. The |
---|
| 1012 | @start argument is optional. If specified, it should be in a format as returned |
---|
| 1013 | by Time::HiRes::gettimeofday(). If not specified, the current gettimeofday() is |
---|
| 1014 | used. |
---|
| 1015 | |
---|
| 1016 | =item $u->uri_match($string) |
---|
| 1017 | |
---|
| 1018 | Returns true if $string is a URI. In array context, returns the scheme and the |
---|
| 1019 | opague part of the URI if $string is a URI, or an empty list otherwise. |
---|
| 1020 | |
---|
| 1021 | =item $u->util_of_event($value) |
---|
| 1022 | |
---|
| 1023 | Returns and/or sets the L<FCM::Util::Event|FCM::Util::Event> object that is used |
---|
| 1024 | to handle the $u->report() method. |
---|
| 1025 | |
---|
| 1026 | =item $u->util_of_report($value) |
---|
| 1027 | |
---|
| 1028 | Returns and/or sets the L<FCM::Util::Reporter|FCM::Util::Reporter> object that |
---|
| 1029 | is used to handle the $u->report() method. |
---|
| 1030 | |
---|
| 1031 | =item $u->version() |
---|
| 1032 | |
---|
| 1033 | Returns the FCM version string in the form C<VERSION (BIN)> where VERSION is the |
---|
| 1034 | version string returned by "git describe" or the version file and BIN is |
---|
| 1035 | absolute path of the "fcm" command. |
---|
| 1036 | |
---|
| 1037 | =back |
---|
| 1038 | |
---|
| 1039 | =head1 DIAGNOSTICS |
---|
| 1040 | |
---|
| 1041 | =head2 FCM::Util::Exception |
---|
| 1042 | |
---|
| 1043 | This exception is a sub-class of L<FCM::Exception|FCM::Exception> and is thrown |
---|
| 1044 | by methods of this class on error. |
---|
| 1045 | |
---|
| 1046 | =head1 COPYRIGHT |
---|
| 1047 | |
---|
| 1048 | (C) Crown copyright Met Office. All rights reserved. |
---|
| 1049 | |
---|
| 1050 | =cut |
---|