[10672] | 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 | # NAME |
---|
| 20 | # FCM1::Extract |
---|
| 21 | # |
---|
| 22 | # DESCRIPTION |
---|
| 23 | # This is the top level class for the FCM extract system. |
---|
| 24 | # |
---|
| 25 | # ------------------------------------------------------------------------------ |
---|
| 26 | |
---|
| 27 | package FCM1::Extract; |
---|
| 28 | @ISA = qw(FCM1::ConfigSystem); |
---|
| 29 | |
---|
| 30 | # Standard pragma |
---|
| 31 | use warnings; |
---|
| 32 | use strict; |
---|
| 33 | |
---|
| 34 | # Standard modules |
---|
| 35 | use File::Path; |
---|
| 36 | use File::Spec; |
---|
| 37 | |
---|
| 38 | # FCM component modules |
---|
| 39 | use FCM1::CfgFile; |
---|
| 40 | use FCM1::CfgLine; |
---|
| 41 | use FCM1::Config; |
---|
| 42 | use FCM1::ConfigSystem; |
---|
| 43 | use FCM1::Dest; |
---|
| 44 | use FCM1::ExtractFile; |
---|
| 45 | use FCM1::ExtractSrc; |
---|
| 46 | use FCM1::Keyword; |
---|
| 47 | use FCM1::ReposBranch; |
---|
| 48 | use FCM1::SrcDirLayer; |
---|
| 49 | use FCM1::Util; |
---|
| 50 | |
---|
| 51 | # List of scalar property methods for this class |
---|
| 52 | my @scalar_properties = ( |
---|
| 53 | 'bdeclare', # list of build declarations |
---|
| 54 | 'branches', # list of repository branches |
---|
| 55 | 'conflict', # conflict mode |
---|
| 56 | 'rdest' , # remote destination information |
---|
| 57 | ); |
---|
| 58 | |
---|
| 59 | # List of hash property methods for this class |
---|
| 60 | my @hash_properties = ( |
---|
| 61 | 'srcdirs' , # list of source directory extract info |
---|
| 62 | 'files', # list of files processed key=pkgname, value=FCM1::ExtractFile |
---|
| 63 | ); |
---|
| 64 | |
---|
| 65 | # ------------------------------------------------------------------------------ |
---|
| 66 | # SYNOPSIS |
---|
| 67 | # $obj = FCM1::Extract->new; |
---|
| 68 | # |
---|
| 69 | # DESCRIPTION |
---|
| 70 | # This method constructs a new instance of the FCM1::Extract class. |
---|
| 71 | # ------------------------------------------------------------------------------ |
---|
| 72 | |
---|
| 73 | sub new { |
---|
| 74 | my $this = shift; |
---|
| 75 | my %args = @_; |
---|
| 76 | my $class = ref $this || $this; |
---|
| 77 | |
---|
| 78 | my $self = FCM1::ConfigSystem->new (%args); |
---|
| 79 | |
---|
| 80 | $self->{$_} = undef for (@scalar_properties); |
---|
| 81 | |
---|
| 82 | $self->{$_} = {} for (@hash_properties); |
---|
| 83 | |
---|
| 84 | bless $self, $class; |
---|
| 85 | |
---|
| 86 | # List of sub-methods for parse_cfg |
---|
| 87 | push @{ $self->cfg_methods }, (qw/rdest bld conflict project/); |
---|
| 88 | |
---|
| 89 | # System type |
---|
| 90 | $self->type ('ext'); |
---|
| 91 | |
---|
| 92 | return $self; |
---|
| 93 | } |
---|
| 94 | |
---|
| 95 | # ------------------------------------------------------------------------------ |
---|
| 96 | # SYNOPSIS |
---|
| 97 | # $value = $obj->X; |
---|
| 98 | # $obj->X ($value); |
---|
| 99 | # |
---|
| 100 | # DESCRIPTION |
---|
| 101 | # Details of these properties are explained in @scalar_properties. |
---|
| 102 | # ------------------------------------------------------------------------------ |
---|
| 103 | |
---|
| 104 | for my $name (@scalar_properties) { |
---|
| 105 | no strict 'refs'; |
---|
| 106 | |
---|
| 107 | *$name = sub { |
---|
| 108 | my $self = shift; |
---|
| 109 | |
---|
| 110 | # Argument specified, set property to specified argument |
---|
| 111 | if (@_) { |
---|
| 112 | $self->{$name} = $_[0]; |
---|
| 113 | } |
---|
| 114 | |
---|
| 115 | # Default value for property |
---|
| 116 | if (not defined $self->{$name}) { |
---|
| 117 | if ($name eq 'bdeclare' or $name eq 'branches') { |
---|
| 118 | # Reference to an array |
---|
| 119 | $self->{$name} = []; |
---|
| 120 | |
---|
| 121 | } elsif ($name eq 'rdest') { |
---|
| 122 | # New extract destination local/remote |
---|
| 123 | $self->{$name} = FCM1::Dest->new (DEST0 => $self->dest(), TYPE => 'ext'); |
---|
| 124 | |
---|
| 125 | } elsif ($name eq 'conflict') { |
---|
| 126 | # Conflict mode, default to "merge" |
---|
| 127 | $self->{$name} = 'merge'; |
---|
| 128 | } |
---|
| 129 | } |
---|
| 130 | |
---|
| 131 | return $self->{$name}; |
---|
| 132 | } |
---|
| 133 | } |
---|
| 134 | |
---|
| 135 | # ------------------------------------------------------------------------------ |
---|
| 136 | # SYNOPSIS |
---|
| 137 | # %hash = %{ $obj->X () }; |
---|
| 138 | # $obj->X (\%hash); |
---|
| 139 | # |
---|
| 140 | # $value = $obj->X ($index); |
---|
| 141 | # $obj->X ($index, $value); |
---|
| 142 | # |
---|
| 143 | # DESCRIPTION |
---|
| 144 | # Details of these properties are explained in @hash_properties. |
---|
| 145 | # |
---|
| 146 | # If no argument is set, this method returns a hash containing a list of |
---|
| 147 | # objects. If an argument is set and it is a reference to a hash, the objects |
---|
| 148 | # are replaced by the specified hash. |
---|
| 149 | # |
---|
| 150 | # If a scalar argument is specified, this method returns a reference to an |
---|
| 151 | # object, if the indexed object exists or undef if the indexed object does |
---|
| 152 | # not exist. If a second argument is set, the $index element of the hash will |
---|
| 153 | # be set to the value of the argument. |
---|
| 154 | # ------------------------------------------------------------------------------ |
---|
| 155 | |
---|
| 156 | for my $name (@hash_properties) { |
---|
| 157 | no strict 'refs'; |
---|
| 158 | |
---|
| 159 | *$name = sub { |
---|
| 160 | my ($self, $arg1, $arg2) = @_; |
---|
| 161 | |
---|
| 162 | # Ensure property is defined as a reference to a hash |
---|
| 163 | $self->{$name} = {} if not defined ($self->{$name}); |
---|
| 164 | |
---|
| 165 | # Argument 1 can be a reference to a hash or a scalar index |
---|
| 166 | my ($index, %hash); |
---|
| 167 | |
---|
| 168 | if (defined $arg1) { |
---|
| 169 | if (ref ($arg1) eq 'HASH') { |
---|
| 170 | %hash = %$arg1; |
---|
| 171 | |
---|
| 172 | } else { |
---|
| 173 | $index = $arg1; |
---|
| 174 | } |
---|
| 175 | } |
---|
| 176 | |
---|
| 177 | if (defined $index) { |
---|
| 178 | # A scalar index is defined, set and/or return the value of an element |
---|
| 179 | $self->{$name}{$index} = $arg2 if defined $arg2; |
---|
| 180 | |
---|
| 181 | return ( |
---|
| 182 | exists $self->{$name}{$index} ? $self->{$name}{$index} : undef |
---|
| 183 | ); |
---|
| 184 | |
---|
| 185 | } else { |
---|
| 186 | # A scalar index is not defined, set and/or return the hash |
---|
| 187 | $self->{$name} = \%hash if defined $arg1; |
---|
| 188 | return $self->{$name}; |
---|
| 189 | } |
---|
| 190 | } |
---|
| 191 | } |
---|
| 192 | |
---|
| 193 | # ------------------------------------------------------------------------------ |
---|
| 194 | # SYNOPSIS |
---|
| 195 | # $rc = $self->check_lock_is_allowed ($lock); |
---|
| 196 | # |
---|
| 197 | # DESCRIPTION |
---|
| 198 | # This method returns true if it is OK for $lock to exist in the destination. |
---|
| 199 | # ------------------------------------------------------------------------------ |
---|
| 200 | |
---|
| 201 | sub check_lock_is_allowed { |
---|
| 202 | my ($self, $lock) = @_; |
---|
| 203 | |
---|
| 204 | # Allow existence of build lock in inherited extract |
---|
| 205 | return ($lock eq $self->dest->bldlock and @{ $self->inherited }); |
---|
| 206 | } |
---|
| 207 | |
---|
| 208 | # ------------------------------------------------------------------------------ |
---|
| 209 | # SYNOPSIS |
---|
| 210 | # $rc = $self->invoke_extract (); |
---|
| 211 | # |
---|
| 212 | # DESCRIPTION |
---|
| 213 | # This method invokes the extract stage of the extract system. It returns |
---|
| 214 | # true on success. |
---|
| 215 | # ------------------------------------------------------------------------------ |
---|
| 216 | |
---|
| 217 | sub invoke_extract { |
---|
| 218 | my $self = shift; |
---|
| 219 | |
---|
| 220 | my $rc = 1; |
---|
| 221 | |
---|
| 222 | my @methods = ( |
---|
| 223 | 'expand_cfg', # expand URL, revision keywords, relative path, etc |
---|
| 224 | 'create_dir_stack', # analyse the branches to create an extract sequence |
---|
| 225 | 'extract_src', # use the sequence to extract source to destination |
---|
| 226 | 'write_cfg', # generate final configuration file |
---|
| 227 | 'write_cfg_bld', # generate build configuration file |
---|
| 228 | ); |
---|
| 229 | |
---|
| 230 | for my $method (@methods) { |
---|
| 231 | $rc = $self->$method if $rc; |
---|
| 232 | } |
---|
| 233 | |
---|
| 234 | return $rc; |
---|
| 235 | } |
---|
| 236 | |
---|
| 237 | # ------------------------------------------------------------------------------ |
---|
| 238 | # SYNOPSIS |
---|
| 239 | # $rc = $self->invoke_mirror (); |
---|
| 240 | # |
---|
| 241 | # DESCRIPTION |
---|
| 242 | # This method invokes the mirror stage of the extract system. It returns |
---|
| 243 | # true on success. |
---|
| 244 | # ------------------------------------------------------------------------------ |
---|
| 245 | |
---|
| 246 | sub invoke_mirror { |
---|
| 247 | my $self = shift; |
---|
| 248 | return $self->rdest->mirror ([qw/bldcfg extcfg srcdir/]); |
---|
| 249 | } |
---|
| 250 | |
---|
| 251 | # ------------------------------------------------------------------------------ |
---|
| 252 | # SYNOPSIS |
---|
| 253 | # $rc = $self->invoke_system (); |
---|
| 254 | # |
---|
| 255 | # DESCRIPTION |
---|
| 256 | # This method invokes the extract system. It returns true on success. |
---|
| 257 | # ------------------------------------------------------------------------------ |
---|
| 258 | |
---|
| 259 | sub invoke_system { |
---|
| 260 | my $self = shift; |
---|
| 261 | |
---|
| 262 | my $rc = 1; |
---|
| 263 | |
---|
| 264 | $rc = $self->invoke_stage ('Extract', 'invoke_extract'); |
---|
| 265 | $rc = $self->invoke_stage ('Mirror', 'invoke_mirror') |
---|
| 266 | if $rc and $self->rdest->rootdir; |
---|
| 267 | |
---|
| 268 | return $rc; |
---|
| 269 | } |
---|
| 270 | |
---|
| 271 | # ------------------------------------------------------------------------------ |
---|
| 272 | # SYNOPSIS |
---|
| 273 | # $rc = $self->parse_cfg_rdest(\@cfg_lines); |
---|
| 274 | # |
---|
| 275 | # DESCRIPTION |
---|
| 276 | # This method parses the remote destination settings in the @cfg_lines. |
---|
| 277 | # ------------------------------------------------------------------------------ |
---|
| 278 | |
---|
| 279 | sub parse_cfg_rdest { |
---|
| 280 | my ($self, $cfg_lines_ref) = @_; |
---|
| 281 | |
---|
| 282 | # RDEST declarations |
---|
| 283 | # ---------------------------------------------------------------------------- |
---|
| 284 | for my $line (grep {$_->slabel_starts_with_cfg('RDEST')} @{$cfg_lines_ref}) { |
---|
| 285 | my ($d, $method) = map {lc($_)} $line->slabel_fields(); |
---|
| 286 | $method ||= 'rootdir'; |
---|
| 287 | if ($self->rdest()->can($method)) { |
---|
| 288 | $self->rdest()->$method(expand_tilde($line->value())); |
---|
| 289 | $line->parsed(1); |
---|
| 290 | } |
---|
| 291 | } |
---|
| 292 | |
---|
| 293 | # MIRROR declaration, deprecated = RDEST::MIRROR_CMD |
---|
| 294 | # ---------------------------------------------------------------------------- |
---|
| 295 | for my $line (grep {$_->slabel_starts_with_cfg('MIRROR')} @{$cfg_lines_ref}) { |
---|
| 296 | $self->rdest()->mirror_cmd($line->value()); |
---|
| 297 | $line->parsed(1); |
---|
| 298 | } |
---|
| 299 | |
---|
| 300 | return 1; |
---|
| 301 | } |
---|
| 302 | |
---|
| 303 | # ------------------------------------------------------------------------------ |
---|
| 304 | # SYNOPSIS |
---|
| 305 | # $rc = $self->parse_cfg_bld (\@cfg_lines); |
---|
| 306 | # |
---|
| 307 | # DESCRIPTION |
---|
| 308 | # This method parses the build configurations in the @cfg_lines. |
---|
| 309 | # ------------------------------------------------------------------------------ |
---|
| 310 | |
---|
| 311 | sub parse_cfg_bld { |
---|
| 312 | my ($self, $cfg_lines) = @_; |
---|
| 313 | |
---|
| 314 | # BLD declarations |
---|
| 315 | # ---------------------------------------------------------------------------- |
---|
| 316 | for my $line (grep {$_->slabel_starts_with_cfg ('BDECLARE')} @$cfg_lines) { |
---|
| 317 | # Remove BLD from label |
---|
| 318 | my @words = $line->slabel_fields; |
---|
| 319 | |
---|
| 320 | # Check that a declaration follows BLD |
---|
| 321 | next if @words <= 1; |
---|
| 322 | |
---|
| 323 | push @{ $self->bdeclare }, FCM1::CfgLine->new ( |
---|
| 324 | LABEL => join ($FCM1::Config::DELIMITER, @words), |
---|
| 325 | PREFIX => $self->cfglabel ('BDECLARE'), |
---|
| 326 | VALUE => $line->value, |
---|
| 327 | ); |
---|
| 328 | $line->parsed (1); |
---|
| 329 | } |
---|
| 330 | |
---|
| 331 | return 1; |
---|
| 332 | } |
---|
| 333 | |
---|
| 334 | # ------------------------------------------------------------------------------ |
---|
| 335 | # SYNOPSIS |
---|
| 336 | # $rc = $self->parse_cfg_conflict (\@cfg_lines); |
---|
| 337 | # |
---|
| 338 | # DESCRIPTION |
---|
| 339 | # This method parses the conflict settings in the @cfg_lines. |
---|
| 340 | # ------------------------------------------------------------------------------ |
---|
| 341 | |
---|
| 342 | sub parse_cfg_conflict { |
---|
| 343 | my ($self, $cfg_lines) = @_; |
---|
| 344 | |
---|
| 345 | # Deprecated: Override mode setting |
---|
| 346 | # ---------------------------------------------------------------------------- |
---|
| 347 | for my $line (grep {$_->slabel_starts_with_cfg ('OVERRIDE')} @$cfg_lines) { |
---|
| 348 | next if ($line->slabel_fields) > 1; |
---|
| 349 | $self->conflict ($line->bvalue ? 'override' : 'fail'); |
---|
| 350 | $line->parsed (1); |
---|
| 351 | $line->warning($line->slabel . ' is deprecated. Use ' . |
---|
| 352 | $line->cfglabel('CONFLICT') . ' override|merge|fail.'); |
---|
| 353 | } |
---|
| 354 | |
---|
| 355 | # Conflict mode setting |
---|
| 356 | # ---------------------------------------------------------------------------- |
---|
| 357 | my @conflict_modes = qw/fail merge override/; |
---|
| 358 | my $conflict_modes_pattern = join ('|', @conflict_modes); |
---|
| 359 | for my $line (grep {$_->slabel_starts_with_cfg ('CONFLICT')} @$cfg_lines) { |
---|
| 360 | if ($line->value =~ /$conflict_modes_pattern/i) { |
---|
| 361 | $self->conflict (lc ($line->value)); |
---|
| 362 | $line->parsed (1); |
---|
| 363 | |
---|
| 364 | } elsif ($line->value =~ /^[012]$/) { |
---|
| 365 | $self->conflict ($conflict_modes[$line->value]); |
---|
| 366 | $line->parsed (1); |
---|
| 367 | |
---|
| 368 | } else { |
---|
| 369 | $line->error ($line->value, ': invalid value'); |
---|
| 370 | } |
---|
| 371 | } |
---|
| 372 | |
---|
| 373 | return 1; |
---|
| 374 | } |
---|
| 375 | |
---|
| 376 | # ------------------------------------------------------------------------------ |
---|
| 377 | # SYNOPSIS |
---|
| 378 | # $rc = $self->parse_cfg_project (\@cfg_lines); |
---|
| 379 | # |
---|
| 380 | # DESCRIPTION |
---|
| 381 | # This method parses the project settings in the @cfg_lines. |
---|
| 382 | # ------------------------------------------------------------------------------ |
---|
| 383 | |
---|
| 384 | sub parse_cfg_project { |
---|
| 385 | my ($self, $cfg_lines) = @_; |
---|
| 386 | |
---|
| 387 | # Flag to indicate that a declared branch revision must match with its changed |
---|
| 388 | # revision |
---|
| 389 | # ---------------------------------------------------------------------------- |
---|
| 390 | for my $line (grep {$_->slabel_starts_with_cfg ('REVMATCH')} @$cfg_lines) { |
---|
| 391 | next if ($line->slabel_fields) > 1; |
---|
| 392 | $self->setting ([qw/EXT_REVMATCH/], $line->bvalue); |
---|
| 393 | $line->parsed (1); |
---|
| 394 | } |
---|
| 395 | |
---|
| 396 | # Repository, revision and source directories |
---|
| 397 | # ---------------------------------------------------------------------------- |
---|
| 398 | for my $name (qw/repos revision dirs expdirs/) { |
---|
| 399 | my @lines = grep { |
---|
| 400 | $_->slabel_starts_with_cfg (uc ($name)) or |
---|
| 401 | $name eq 'revision' and $_->slabel_starts_with_cfg ('VERSION'); |
---|
| 402 | } @$cfg_lines; |
---|
| 403 | for my $line (@lines) { |
---|
| 404 | my @names = $line->slabel_fields; |
---|
| 405 | shift @names; |
---|
| 406 | |
---|
| 407 | # Detemine package and tag |
---|
| 408 | my $tag = pop @names; |
---|
| 409 | my $pckroot = $names[0]; |
---|
| 410 | my $pck = join ($FCM1::Config::DELIMITER, @names); |
---|
| 411 | |
---|
| 412 | # Check that $tag and $pckroot are defined |
---|
| 413 | next unless $tag and $pckroot; |
---|
| 414 | |
---|
| 415 | # Check if branch already exists. |
---|
| 416 | # If so, set $branch to point to existing branch |
---|
| 417 | my $branch = undef; |
---|
| 418 | for (@{ $self->branches }) { |
---|
| 419 | next unless $_->package eq $pckroot and $_->tag eq $tag; |
---|
| 420 | |
---|
| 421 | $branch = $_; |
---|
| 422 | last; |
---|
| 423 | } |
---|
| 424 | |
---|
| 425 | # Otherwise, create a new branch |
---|
| 426 | if (not $branch) { |
---|
| 427 | $branch = FCM1::ReposBranch->new (PACKAGE => $pckroot, TAG => $tag,); |
---|
| 428 | |
---|
| 429 | push @{ $self->branches }, $branch; |
---|
| 430 | } |
---|
| 431 | |
---|
| 432 | if ($name eq 'repos' or $name eq 'revision') { |
---|
| 433 | # Branch location or revision |
---|
| 434 | $branch->$name ($line->value); |
---|
| 435 | |
---|
| 436 | } else { # $name eq 'dirs' or $name eq 'expdirs' |
---|
| 437 | # Source directory or expandable source directory |
---|
| 438 | if ($pck eq $pckroot and $line->value !~ m#^/#) { |
---|
| 439 | # Sub-package name not set and source directory quoted as a relative |
---|
| 440 | # path, determine package name from path name |
---|
| 441 | $pck = join ( |
---|
| 442 | $FCM1::Config::DELIMITER, |
---|
| 443 | ($pckroot, File::Spec->splitdir ($line->value)), |
---|
| 444 | ); |
---|
| 445 | } |
---|
| 446 | |
---|
| 447 | # A "/" is equivalent to the top (empty) package |
---|
| 448 | my $value = ($line->value =~ m#^/+$#) ? '' : $line->value; |
---|
| 449 | $branch->$name ($pck, $value); |
---|
| 450 | } |
---|
| 451 | |
---|
| 452 | $line->parsed (1); |
---|
| 453 | } |
---|
| 454 | } |
---|
| 455 | |
---|
| 456 | return 1; |
---|
| 457 | } |
---|
| 458 | |
---|
| 459 | # ------------------------------------------------------------------------------ |
---|
| 460 | # SYNOPSIS |
---|
| 461 | # $rc = $obj->expand_cfg (); |
---|
| 462 | # |
---|
| 463 | # DESCRIPTION |
---|
| 464 | # This method expands the settings of the extract configuration. |
---|
| 465 | # ------------------------------------------------------------------------------ |
---|
| 466 | |
---|
| 467 | sub expand_cfg { |
---|
| 468 | my $self = shift; |
---|
| 469 | |
---|
| 470 | my $rc = 1; |
---|
| 471 | for my $use (@{ $self->inherit }) { |
---|
| 472 | $rc = $use->expand_cfg if $rc; |
---|
| 473 | } |
---|
| 474 | |
---|
| 475 | return $rc unless $rc; |
---|
| 476 | |
---|
| 477 | # Establish a set of source directories from the "base repository" |
---|
| 478 | my %base_branches = (); |
---|
| 479 | |
---|
| 480 | # Inherit "base" set of source directories from re-used extracts |
---|
| 481 | for my $use (@{ $self->inherit }) { |
---|
| 482 | my @branches = @{ $use->branches }; |
---|
| 483 | |
---|
| 484 | for my $branch (@branches) { |
---|
| 485 | my $package = $branch->package; |
---|
| 486 | $base_branches{$package} = $branch unless exists $base_branches{$package}; |
---|
| 487 | } |
---|
| 488 | } |
---|
| 489 | |
---|
| 490 | for my $branch (@{ $self->branches }) { |
---|
| 491 | # Expand URL keywords if necessary |
---|
| 492 | if ($branch->repos) { |
---|
| 493 | my $repos = FCM1::Util::tidy_url(FCM1::Keyword::expand($branch->repos())); |
---|
| 494 | $branch->repos ($repos) if $repos ne $branch->repos; |
---|
| 495 | } |
---|
| 496 | |
---|
| 497 | # Check that repository type and revision are set |
---|
| 498 | if ($branch->repos and &is_url ($branch->repos)) { |
---|
| 499 | $branch->type ('svn') unless $branch->type; |
---|
| 500 | $branch->revision ('head') unless $branch->revision; |
---|
| 501 | |
---|
| 502 | } else { |
---|
| 503 | $branch->type ('user') unless $branch->type; |
---|
| 504 | $branch->revision ('user') unless $branch->revision; |
---|
| 505 | } |
---|
| 506 | |
---|
| 507 | $rc = $branch->expand_revision if $rc; # Get revision number from keywords |
---|
| 508 | $rc = $branch->expand_path if $rc; # Expand relative path to full path |
---|
| 509 | $rc = $branch->expand_all if $rc; # Search sub-directories |
---|
| 510 | last unless $rc; |
---|
| 511 | |
---|
| 512 | my $package = $branch->package; |
---|
| 513 | |
---|
| 514 | if (exists $base_branches{$package}) { |
---|
| 515 | # A base branch for this package exists |
---|
| 516 | |
---|
| 517 | # If current branch has no source directory, use the set provided by the |
---|
| 518 | # base branch |
---|
| 519 | my %dirs = %{ $branch->dirs }; |
---|
| 520 | $branch->add_base_dirs ($base_branches{$package}) unless keys %dirs; |
---|
| 521 | |
---|
| 522 | } else { |
---|
| 523 | # This package does not yet have a base branch, set this branch as base |
---|
| 524 | $base_branches{$package} = $branch; |
---|
| 525 | } |
---|
| 526 | } |
---|
| 527 | |
---|
| 528 | return $rc; |
---|
| 529 | } |
---|
| 530 | |
---|
| 531 | # ------------------------------------------------------------------------------ |
---|
| 532 | # SYNOPSIS |
---|
| 533 | # $rc = $obj->create_dir_stack (); |
---|
| 534 | # |
---|
| 535 | # DESCRIPTION |
---|
| 536 | # This method creates a hash of source directories to be processed. If the |
---|
| 537 | # flag INHERITED is set to true, the source directories are assumed processed |
---|
| 538 | # and extracted. |
---|
| 539 | # ------------------------------------------------------------------------------ |
---|
| 540 | |
---|
| 541 | sub create_dir_stack { |
---|
| 542 | my $self = shift; |
---|
| 543 | my %args = @_; |
---|
| 544 | |
---|
| 545 | # Inherit from USE ext cfg |
---|
| 546 | for my $use (@{ $self->inherit }) { |
---|
| 547 | $use->create_dir_stack () or return 0; |
---|
| 548 | my %use_srcdirs = %{ $use->srcdirs }; |
---|
| 549 | |
---|
| 550 | while (my ($key, $value) = each %use_srcdirs) { |
---|
| 551 | $self->srcdirs ($key, $value); |
---|
| 552 | |
---|
| 553 | # Re-set destination to current destination |
---|
| 554 | my @path = split (/$FCM1::Config::DELIMITER/, $key); |
---|
| 555 | $self->srcdirs ($key)->{DEST} = File::Spec->catfile ( |
---|
| 556 | $self->dest->srcdir, @path, |
---|
| 557 | ); |
---|
| 558 | } |
---|
| 559 | } |
---|
| 560 | |
---|
| 561 | # Build stack from current ext cfg |
---|
| 562 | for my $branch (@{ $self->branches }) { |
---|
| 563 | my %branch_dirs = %{ $branch->dirs }; |
---|
| 564 | |
---|
| 565 | for my $dir (keys %branch_dirs) { |
---|
| 566 | # Check whether source directory is already in the list |
---|
| 567 | if (not $self->srcdirs ($dir)) { # if not, create it |
---|
| 568 | $self->srcdirs ($dir, { |
---|
| 569 | DEST => File::Spec->catfile ( |
---|
| 570 | $self->dest->srcdir, split (/$FCM1::Config::DELIMITER/, $dir) |
---|
| 571 | ), |
---|
| 572 | STACK => [], |
---|
| 573 | FILES => {}, |
---|
| 574 | }); |
---|
| 575 | } |
---|
| 576 | |
---|
| 577 | my $stack = $self->srcdirs ($dir)->{STACK}; # copy reference |
---|
| 578 | |
---|
| 579 | # Create a new layer in the input stack |
---|
| 580 | my $layer = FCM1::SrcDirLayer->new ( |
---|
| 581 | NAME => $dir, |
---|
| 582 | PACKAGE => $branch->package, |
---|
| 583 | TAG => $branch->tag, |
---|
| 584 | LOCATION => $branch->dirs ($dir), |
---|
| 585 | REPOSROOT => $branch->repos, |
---|
| 586 | REVISION => $branch->revision, |
---|
| 587 | TYPE => $branch->type, |
---|
| 588 | EXTRACTED => @{ $self->inherited } |
---|
| 589 | ? $self->srcdirs ($dir)->{DEST} : undef, |
---|
| 590 | ); |
---|
| 591 | |
---|
| 592 | # Check whether layer is already in the stack |
---|
| 593 | my $exist = grep { |
---|
| 594 | $_->location eq $layer->location and $_->revision eq $layer->revision; |
---|
| 595 | } @{ $stack }; |
---|
| 596 | |
---|
| 597 | if (not $exist) { |
---|
| 598 | # If not already exist, put layer into stack |
---|
| 599 | |
---|
| 600 | # Note: user stack always comes last |
---|
| 601 | if (! $layer->user and exists $stack->[-1] and $stack->[-1]->user) { |
---|
| 602 | my $lastlayer = pop @{ $stack }; |
---|
| 603 | push @{ $stack }, $layer; |
---|
| 604 | $layer = $lastlayer; |
---|
| 605 | } |
---|
| 606 | |
---|
| 607 | push @{ $stack }, $layer; |
---|
| 608 | |
---|
| 609 | } elsif ($layer->user) { |
---|
| 610 | |
---|
| 611 | # User layer already exists, overwrite it |
---|
| 612 | $stack->[-1] = $layer; |
---|
| 613 | |
---|
| 614 | } |
---|
| 615 | } |
---|
| 616 | } |
---|
| 617 | |
---|
| 618 | # Use the cache to sort the source directory layer hash |
---|
| 619 | return $self->compare_setting (METHOD_LIST => ['sort_dir_stack']); |
---|
| 620 | } |
---|
| 621 | |
---|
| 622 | # ------------------------------------------------------------------------------ |
---|
| 623 | # SYNOPSIS |
---|
| 624 | # ($rc, \@new_lines) = $self->sort_dir_stack ($old_lines); |
---|
| 625 | # |
---|
| 626 | # DESCRIPTION |
---|
| 627 | # This method sorts thesource directories hash to be processed. |
---|
| 628 | # ------------------------------------------------------------------------------ |
---|
| 629 | |
---|
| 630 | sub sort_dir_stack { |
---|
| 631 | my ($self, $old_lines) = @_; |
---|
| 632 | |
---|
| 633 | my $rc = 0; |
---|
| 634 | |
---|
| 635 | my %old = (); |
---|
| 636 | if ($old_lines) { |
---|
| 637 | for my $line (@$old_lines) { |
---|
| 638 | $old{$line->label} = $line->value; |
---|
| 639 | } |
---|
| 640 | } |
---|
| 641 | |
---|
| 642 | my %new; |
---|
| 643 | |
---|
| 644 | # Compare each layer to base layer, discard unnecessary layers |
---|
| 645 | DIR: for my $srcdir (keys %{ $self->srcdirs }) { |
---|
| 646 | my @stack = (); |
---|
| 647 | |
---|
| 648 | while (my $layer = shift @{ $self->srcdirs ($srcdir)->{STACK} }) { |
---|
| 649 | if ($layer->user) { |
---|
| 650 | # Local file system branch, check that the declared location exists |
---|
| 651 | if (-d $layer->location) { |
---|
| 652 | # Local file system branch always takes precedence |
---|
| 653 | push @stack, $layer; |
---|
| 654 | |
---|
| 655 | } else { |
---|
| 656 | w_report 'ERROR: ', $layer->location, ': declared source directory ', |
---|
| 657 | 'does not exists '; |
---|
| 658 | $rc = undef; |
---|
| 659 | last DIR; |
---|
| 660 | } |
---|
| 661 | |
---|
| 662 | } else { |
---|
| 663 | my $key = join ($FCM1::Config::DELIMITER, ( |
---|
| 664 | $srcdir, $layer->location, $layer->revision |
---|
| 665 | )); |
---|
| 666 | |
---|
| 667 | unless ($layer->extracted and $layer->commit) { |
---|
| 668 | # See if commit revision information is cached |
---|
| 669 | if (keys %old and exists $old{$key}) { |
---|
| 670 | $layer->commit ($old{$key}); |
---|
| 671 | |
---|
| 672 | } else { |
---|
| 673 | $layer->get_commit; |
---|
| 674 | $rc = 1; |
---|
| 675 | } |
---|
| 676 | |
---|
| 677 | # Check source directory for commit revision, if necessary |
---|
| 678 | if (not $layer->commit) { |
---|
| 679 | w_report 'Error: cannot determine the last changed revision of ', |
---|
| 680 | $layer->location; |
---|
| 681 | $rc = undef; |
---|
| 682 | last DIR; |
---|
| 683 | } |
---|
| 684 | |
---|
| 685 | # Set cache directory for layer |
---|
| 686 | my $tag_ver = $layer->tag . '__' . $layer->commit; |
---|
| 687 | $layer->cachedir (File::Spec->catfile ( |
---|
| 688 | $self->dest->cachedir, |
---|
| 689 | split (/$FCM1::Config::DELIMITER/, $srcdir), |
---|
| 690 | $tag_ver, |
---|
| 691 | )); |
---|
| 692 | } |
---|
| 693 | |
---|
| 694 | # New line in cache config file |
---|
| 695 | $new{$key} = $layer->commit; |
---|
| 696 | |
---|
| 697 | # Push this layer in the stack: |
---|
| 698 | # 1. it has a different revision compared to the top layer |
---|
| 699 | # 2. it is the top layer (base line code) |
---|
| 700 | if (@stack > 0) { |
---|
| 701 | push @stack, $layer if $layer->commit != $stack[0]->commit; |
---|
| 702 | |
---|
| 703 | } else { |
---|
| 704 | push @stack, $layer; |
---|
| 705 | } |
---|
| 706 | |
---|
| 707 | } |
---|
| 708 | } |
---|
| 709 | |
---|
| 710 | $self->srcdirs ($srcdir)->{STACK} = \@stack; |
---|
| 711 | } |
---|
| 712 | |
---|
| 713 | # Write "commit cache" file |
---|
| 714 | my @new_lines; |
---|
| 715 | if (defined ($rc)) { |
---|
| 716 | for my $key (sort keys %new) { |
---|
| 717 | push @new_lines, FCM1::CfgLine->new (label => $key, value => $new{$key}); |
---|
| 718 | } |
---|
| 719 | } |
---|
| 720 | |
---|
| 721 | return ($rc, \@new_lines); |
---|
| 722 | } |
---|
| 723 | |
---|
| 724 | # ------------------------------------------------------------------------------ |
---|
| 725 | # SYNOPSIS |
---|
| 726 | # $rc = $self->extract_src (); |
---|
| 727 | # |
---|
| 728 | # DESCRIPTION |
---|
| 729 | # This internal method performs the extract of the source directories and |
---|
| 730 | # files if necessary. |
---|
| 731 | # ------------------------------------------------------------------------------ |
---|
| 732 | |
---|
| 733 | sub extract_src { |
---|
| 734 | my $self = shift; |
---|
| 735 | my $rc = 1; |
---|
| 736 | |
---|
| 737 | # Ensure destinations exist and are directories |
---|
| 738 | for my $srcdir (values %{ $self->srcdirs }) { |
---|
| 739 | last if not $rc; |
---|
| 740 | if (-f $srcdir->{DEST}) { |
---|
| 741 | w_report $srcdir->{DEST}, |
---|
| 742 | ': destination exists and is not a directory, abort.'; |
---|
| 743 | $rc = 0; |
---|
| 744 | } |
---|
| 745 | } |
---|
| 746 | |
---|
| 747 | # Retrieve previous/record current extract configuration for each file. |
---|
| 748 | $rc = $self->compare_setting ( |
---|
| 749 | CACHEBASE => $self->setting ('CACHE_FILE_SRC'), |
---|
| 750 | METHOD_LIST => ['compare_setting_srcfiles'], |
---|
| 751 | ) if $rc; |
---|
| 752 | |
---|
| 753 | return $rc; |
---|
| 754 | } |
---|
| 755 | |
---|
| 756 | # ------------------------------------------------------------------------------ |
---|
| 757 | # SYNOPSIS |
---|
| 758 | # ($rc, \@new_lines) = $self->compare_setting_srcfiles ($old_lines); |
---|
| 759 | # |
---|
| 760 | # DESCRIPTION |
---|
| 761 | # For each file to be extracted, this method creates an instance of an |
---|
| 762 | # FCM1::ExtractFile object. It then compares its file's sources to determine |
---|
| 763 | # if they have changed. If so, it will allow the FCM1::ExtractFile to |
---|
| 764 | # "re-extract" the file to the destination. Otherwise, it will set |
---|
| 765 | # FCM1::ExtractFile->dest_status to a null string to denote an "unchanged" |
---|
| 766 | # dest_status. |
---|
| 767 | # |
---|
| 768 | # SEE ALSO |
---|
| 769 | # FCM1::ConfigSystem->compare_setting. |
---|
| 770 | # ------------------------------------------------------------------------------ |
---|
| 771 | |
---|
| 772 | sub compare_setting_srcfiles { |
---|
| 773 | my ($self, $old_lines) = @_; |
---|
| 774 | my $rc = 1; |
---|
| 775 | |
---|
| 776 | # Retrieve previous extract configuration for each file |
---|
| 777 | # ---------------------------------------------------------------------------- |
---|
| 778 | my %old = (); |
---|
| 779 | if ($old_lines) { |
---|
| 780 | for my $line (@$old_lines) { |
---|
| 781 | $old{$line->label} = $line->value; |
---|
| 782 | } |
---|
| 783 | } |
---|
| 784 | |
---|
| 785 | # Build up a sequence using a FCM1::ExtractFile object for each file |
---|
| 786 | # ---------------------------------------------------------------------------- |
---|
| 787 | for my $srcdir (values %{ $self->srcdirs }) { |
---|
| 788 | my %pkgnames0; # (to be) list of package names in the base layer |
---|
| 789 | for my $i (0 .. @{ $srcdir->{STACK} } - 1) { |
---|
| 790 | my $layer = $srcdir->{STACK}->[$i]; |
---|
| 791 | # Update the cache for each layer of the stack if necessary |
---|
| 792 | $layer->update_cache unless $layer->extracted or -d $layer->localdir; |
---|
| 793 | |
---|
| 794 | # Get list of files in the cache or local directory |
---|
| 795 | my %pkgnames; |
---|
| 796 | for my $file (($layer->get_files)) { |
---|
| 797 | my $pkgname = join ( |
---|
| 798 | '/', split (/$FCM1::Config::DELIMITER/, $layer->name), $file |
---|
| 799 | ); |
---|
| 800 | $pkgnames0{$pkgname} = 1 if $i == 0; # store package name in base layer |
---|
| 801 | $pkgnames{$pkgname} = 1; # store package name in the current layer |
---|
| 802 | if (not $self->files ($pkgname)) { |
---|
| 803 | $self->files ($pkgname, FCM1::ExtractFile->new ( |
---|
| 804 | conflict => $self->conflict, |
---|
| 805 | dest => $self->dest->srcpath, |
---|
| 806 | pkgname => $pkgname, |
---|
| 807 | )); |
---|
| 808 | |
---|
| 809 | # Base is empty |
---|
| 810 | $self->files ($pkgname)->src->[0] = FCM1::ExtractSrc->new ( |
---|
| 811 | id => $layer->tag, |
---|
| 812 | pkgname => $pkgname, |
---|
| 813 | ) if $i > 0; |
---|
| 814 | } |
---|
| 815 | my $cache = File::Spec->catfile ($layer->localdir, $file); |
---|
| 816 | push @{ $self->files ($pkgname)->src }, FCM1::ExtractSrc->new ( |
---|
| 817 | cache => $cache, |
---|
| 818 | id => $layer->tag, |
---|
| 819 | pkgname => $pkgname, |
---|
| 820 | rev => ($layer->user ? (stat ($cache))[9] : $layer->commit), |
---|
| 821 | uri => join ('/', $layer->location, $file), |
---|
| 822 | ); |
---|
| 823 | } |
---|
| 824 | |
---|
| 825 | # List of removed files in this layer (relative to base layer) |
---|
| 826 | if ($i > 0) { |
---|
| 827 | for my $pkgname (keys %pkgnames0) { |
---|
| 828 | push @{ $self->files ($pkgname)->src }, FCM1::ExtractSrc->new ( |
---|
| 829 | id => $layer->tag, |
---|
| 830 | pkgname => $pkgname, |
---|
| 831 | ) if not exists $pkgnames{$pkgname} |
---|
| 832 | } |
---|
| 833 | } |
---|
| 834 | } |
---|
| 835 | } |
---|
| 836 | |
---|
| 837 | # Compare with old settings |
---|
| 838 | # ---------------------------------------------------------------------------- |
---|
| 839 | my %new = (); |
---|
| 840 | for my $key (sort keys %{ $self->files }) { |
---|
| 841 | # Set up value for cache |
---|
| 842 | my @sources = (); |
---|
| 843 | for my $src (@{ $self->files ($key)->src }) { |
---|
| 844 | push @sources, (defined ($src->uri) ? ($src->uri . '@' . $src->rev) : ''); |
---|
| 845 | } |
---|
| 846 | |
---|
| 847 | my $value = join ($FCM1::Config::DELIMITER, @sources); |
---|
| 848 | |
---|
| 849 | # Set FCM1::ExtractFile->dest_status to "unchanged" if value is unchanged |
---|
| 850 | if (exists($old{$key}) && $old{$key} eq $value && !grep {!$_} @sources) { |
---|
| 851 | $self->files($key)->dest_status(''); |
---|
| 852 | } |
---|
| 853 | |
---|
| 854 | # Write current settings |
---|
| 855 | $new{$key} = $value; |
---|
| 856 | } |
---|
| 857 | |
---|
| 858 | # Delete those that exist in previous extract but not in current |
---|
| 859 | # ---------------------------------------------------------------------------- |
---|
| 860 | for my $key (sort keys %old) { |
---|
| 861 | next if exists $new{$key}; |
---|
| 862 | $self->files ($key, FCM1::ExtractFile->new ( |
---|
| 863 | dest => $self->dest->srcpath, |
---|
| 864 | pkgname => $key, |
---|
| 865 | )); |
---|
| 866 | } |
---|
| 867 | |
---|
| 868 | # Extract each file, if necessary |
---|
| 869 | # ---------------------------------------------------------------------------- |
---|
| 870 | for my $key (sort keys %{ $self->files }) { |
---|
| 871 | $rc = $self->files ($key)->run if defined ($rc); |
---|
| 872 | last if not defined ($rc); |
---|
| 873 | } |
---|
| 874 | |
---|
| 875 | # Report status |
---|
| 876 | # ---------------------------------------------------------------------------- |
---|
| 877 | if (defined ($rc) and $self->verbose) { |
---|
| 878 | my %src_status_count = (); |
---|
| 879 | my %dest_status_count = (); |
---|
| 880 | for my $key (sort keys %{ $self->files }) { |
---|
| 881 | # Report changes in destination in verbose 1 or above |
---|
| 882 | my $dest_status = $self->files ($key)->dest_status; |
---|
| 883 | my $src_status = $self->files ($key)->src_status; |
---|
| 884 | next unless $self->verbose and $dest_status; |
---|
| 885 | |
---|
| 886 | if ($dest_status and $dest_status ne '?') { |
---|
| 887 | if (exists $dest_status_count{$dest_status}) { |
---|
| 888 | $dest_status_count{$dest_status}++; |
---|
| 889 | |
---|
| 890 | } else { |
---|
| 891 | $dest_status_count{$dest_status} = 1; |
---|
| 892 | } |
---|
| 893 | } |
---|
| 894 | |
---|
| 895 | if ($src_status and $src_status ne '?') { |
---|
| 896 | if (exists $src_status_count{$src_status}) { |
---|
| 897 | $src_status_count{$src_status}++; |
---|
| 898 | |
---|
| 899 | } else { |
---|
| 900 | $src_status_count{$src_status} = 1; |
---|
| 901 | } |
---|
| 902 | } |
---|
| 903 | |
---|
| 904 | # Destination status in column 1, source status in column 2 |
---|
| 905 | if ($self->verbose > 1) { |
---|
| 906 | my @srcs = @{$self->files ($key)->src_actual}; |
---|
| 907 | print ($dest_status ? $dest_status : ' '); |
---|
| 908 | print ($src_status ? $src_status : ' '); |
---|
| 909 | print ' ' x 5, $key; |
---|
| 910 | print ' (', join (', ', map {$_->id} @srcs), ')' if @srcs; |
---|
| 911 | print "\n"; |
---|
| 912 | } |
---|
| 913 | } |
---|
| 914 | |
---|
| 915 | # Report number of files in each dest_status category |
---|
| 916 | if (%dest_status_count) { |
---|
| 917 | print 'Column 1: ' if $self->verbose > 1; |
---|
| 918 | print 'Destination status summary:', "\n"; |
---|
| 919 | for my $key (sort keys %FCM1::ExtractFile::DEST_STATUS_CODE) { |
---|
| 920 | next unless $key; |
---|
| 921 | next if not exists ($dest_status_count{$key}); |
---|
| 922 | print ' No of files '; |
---|
| 923 | print '[', $key, '] ' if $self->verbose > 1; |
---|
| 924 | print $FCM1::ExtractFile::DEST_STATUS_CODE{$key}, ': ', |
---|
| 925 | $dest_status_count{$key}, "\n"; |
---|
| 926 | } |
---|
| 927 | } |
---|
| 928 | |
---|
| 929 | # Report number of files in each dest_status category |
---|
| 930 | if (%src_status_count) { |
---|
| 931 | print 'Column 2: ' if $self->verbose > 1; |
---|
| 932 | print 'Source status summary:', "\n"; |
---|
| 933 | for my $key (sort keys %FCM1::ExtractFile::SRC_STATUS_CODE) { |
---|
| 934 | next unless $key; |
---|
| 935 | next if not exists ($src_status_count{$key}); |
---|
| 936 | print ' No of files '; |
---|
| 937 | print '[', $key, '] ' if $self->verbose > 1; |
---|
| 938 | print $FCM1::ExtractFile::SRC_STATUS_CODE{$key}, ': ', |
---|
| 939 | $src_status_count{$key}, "\n"; |
---|
| 940 | } |
---|
| 941 | } |
---|
| 942 | } |
---|
| 943 | |
---|
| 944 | # Record configuration of current extract for each file |
---|
| 945 | # ---------------------------------------------------------------------------- |
---|
| 946 | my @new_lines; |
---|
| 947 | if (defined ($rc)) { |
---|
| 948 | for my $key (sort keys %new) { |
---|
| 949 | push @new_lines, FCM1::CfgLine->new (label => $key, value => $new{$key}); |
---|
| 950 | } |
---|
| 951 | } |
---|
| 952 | |
---|
| 953 | return ($rc, \@new_lines); |
---|
| 954 | } |
---|
| 955 | |
---|
| 956 | # ------------------------------------------------------------------------------ |
---|
| 957 | # SYNOPSIS |
---|
| 958 | # @array = $self->sort_bdeclare (); |
---|
| 959 | # |
---|
| 960 | # DESCRIPTION |
---|
| 961 | # This method returns sorted build declarations, filtering out repeated |
---|
| 962 | # entries, where possible. |
---|
| 963 | # ------------------------------------------------------------------------------ |
---|
| 964 | |
---|
| 965 | sub sort_bdeclare { |
---|
| 966 | my $self = shift; |
---|
| 967 | |
---|
| 968 | # Get list of build configuration labels that can be declared multiple times |
---|
| 969 | my %cfg_keyword = map { |
---|
| 970 | ($self->cfglabel ($_), 1) |
---|
| 971 | } split (/$FCM1::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD')); |
---|
| 972 | |
---|
| 973 | my @bdeclares = (); |
---|
| 974 | for my $d (reverse @{ $self->bdeclare }) { |
---|
| 975 | # Reconstruct array from bottom up |
---|
| 976 | # * always add declarations that can be declared multiple times |
---|
| 977 | # * otherwise add only if it is declared below |
---|
| 978 | unshift @bdeclares, $d |
---|
| 979 | if exists $cfg_keyword{uc (($d->slabel_fields)[0])} or |
---|
| 980 | not grep {$_->slabel eq $d->slabel} @bdeclares; |
---|
| 981 | } |
---|
| 982 | |
---|
| 983 | return (sort {$a->slabel cmp $b->slabel} @bdeclares); |
---|
| 984 | } |
---|
| 985 | |
---|
| 986 | # ------------------------------------------------------------------------------ |
---|
| 987 | # SYNOPSIS |
---|
| 988 | # @cfglines = $obj->to_cfglines (); |
---|
| 989 | # |
---|
| 990 | # DESCRIPTION |
---|
| 991 | # See description of FCM1::ConfigSystem->to_cfglines for further information. |
---|
| 992 | # ------------------------------------------------------------------------------ |
---|
| 993 | |
---|
| 994 | sub to_cfglines { |
---|
| 995 | my ($self) = @_; |
---|
| 996 | |
---|
| 997 | return ( |
---|
| 998 | FCM1::ConfigSystem::to_cfglines($self), |
---|
| 999 | |
---|
| 1000 | $self->rdest->to_cfglines (), |
---|
| 1001 | FCM1::CfgLine->new (), |
---|
| 1002 | |
---|
| 1003 | @{ $self->bdeclare } ? ( |
---|
| 1004 | FCM1::CfgLine::comment_block ('Build declarations'), |
---|
| 1005 | map { |
---|
| 1006 | FCM1::CfgLine->new (label => $_->label, value => $_->value) |
---|
| 1007 | } ($self->sort_bdeclare), |
---|
| 1008 | FCM1::CfgLine->new (), |
---|
| 1009 | ) : (), |
---|
| 1010 | |
---|
| 1011 | FCM1::CfgLine::comment_block ('Project and branches'), |
---|
| 1012 | (map {($_->to_cfglines ())} @{ $self->branches }), |
---|
| 1013 | |
---|
| 1014 | ($self->conflict ne 'merge') ? ( |
---|
| 1015 | FCM1::CfgLine->new ( |
---|
| 1016 | label => $self->cfglabel ('CONFLICT'), value => $self->conflict, |
---|
| 1017 | ), |
---|
| 1018 | FCM1::CfgLine->new (), |
---|
| 1019 | ) : (), |
---|
| 1020 | ); |
---|
| 1021 | } |
---|
| 1022 | |
---|
| 1023 | # ------------------------------------------------------------------------------ |
---|
| 1024 | # SYNOPSIS |
---|
| 1025 | # @cfglines = $obj->to_cfglines_bld (); |
---|
| 1026 | # |
---|
| 1027 | # DESCRIPTION |
---|
| 1028 | # Returns a list of configuration lines of the current extract suitable for |
---|
| 1029 | # feeding into the build system. |
---|
| 1030 | # ------------------------------------------------------------------------------ |
---|
| 1031 | |
---|
| 1032 | sub to_cfglines_bld { |
---|
| 1033 | my ($self) = @_; |
---|
| 1034 | |
---|
| 1035 | my $dest = $self->rdest->rootdir ? 'rdest' : 'dest'; |
---|
| 1036 | my $root = File::Spec->catfile ('$HERE', '..'); |
---|
| 1037 | |
---|
| 1038 | my @inherits; |
---|
| 1039 | my @no_inherits; |
---|
| 1040 | if (@{ $self->inherit }) { |
---|
| 1041 | # List of inherited builds |
---|
| 1042 | for (@{ $self->inherit }) { |
---|
| 1043 | push @inherits, FCM1::CfgLine->new ( |
---|
| 1044 | label => $self->cfglabel ('USE'), value => $_->$dest->rootdir |
---|
| 1045 | ); |
---|
| 1046 | } |
---|
| 1047 | |
---|
| 1048 | # List of files that should not be inherited |
---|
| 1049 | for my $key (sort keys %{ $self->files }) { |
---|
| 1050 | next unless $self->files ($key)->dest_status eq 'd'; |
---|
| 1051 | my $label = join ('::', ( |
---|
| 1052 | $self->cfglabel ('INHERIT'), |
---|
| 1053 | $self->cfglabel ('FILE'), |
---|
| 1054 | split (m#/#, $self->files ($key)->pkgname), |
---|
| 1055 | )); |
---|
| 1056 | push @no_inherits, FCM1::CfgLine->new (label => $label, value => 'false'); |
---|
| 1057 | } |
---|
| 1058 | } |
---|
| 1059 | |
---|
| 1060 | return ( |
---|
| 1061 | FCM1::CfgLine::comment_block ('File header'), |
---|
| 1062 | (map |
---|
| 1063 | {my ($lbl, $val) = @{$_}; FCM1::CfgLine->new(label => $lbl, value => $val)} |
---|
| 1064 | ( |
---|
| 1065 | [$self->cfglabel('CFGFILE') . $FCM1::Config::DELIMITER . 'TYPE' , 'bld'], |
---|
| 1066 | [$self->cfglabel('CFGFILE') . $FCM1::Config::DELIMITER . 'VERSION', '1.0'], |
---|
| 1067 | [], |
---|
| 1068 | ) |
---|
| 1069 | ), |
---|
| 1070 | |
---|
| 1071 | @{ $self->inherit } ? ( |
---|
| 1072 | @inherits, |
---|
| 1073 | @no_inherits, |
---|
| 1074 | FCM1::CfgLine->new (), |
---|
| 1075 | ) : (), |
---|
| 1076 | |
---|
| 1077 | FCM1::CfgLine::comment_block ('Destination'), |
---|
| 1078 | FCM1::CfgLine->new (label => $self->cfglabel ('DEST'), value => $root), |
---|
| 1079 | FCM1::CfgLine->new (), |
---|
| 1080 | |
---|
| 1081 | @{ $self->bdeclare } ? ( |
---|
| 1082 | FCM1::CfgLine::comment_block ('Build declarations'), |
---|
| 1083 | map { |
---|
| 1084 | FCM1::CfgLine->new (label => $_->slabel, value => $_->value) |
---|
| 1085 | } ($self->sort_bdeclare), |
---|
| 1086 | FCM1::CfgLine->new (), |
---|
| 1087 | ) : (), |
---|
| 1088 | ); |
---|
| 1089 | } |
---|
| 1090 | |
---|
| 1091 | # ------------------------------------------------------------------------------ |
---|
| 1092 | # SYNOPSIS |
---|
| 1093 | # $rc = $self->write_cfg (); |
---|
| 1094 | # |
---|
| 1095 | # DESCRIPTION |
---|
| 1096 | # This method writes the configuration file at the end of the run. It calls |
---|
| 1097 | # $self->write_cfg_system ($cfg) to write any system specific settings. |
---|
| 1098 | # ------------------------------------------------------------------------------ |
---|
| 1099 | |
---|
| 1100 | sub write_cfg { |
---|
| 1101 | my $self = shift; |
---|
| 1102 | |
---|
| 1103 | my $cfg = FCM1::CfgFile->new (TYPE => $self->type); |
---|
| 1104 | $cfg->lines ([$self->to_cfglines()]); |
---|
| 1105 | $cfg->print_cfg ($self->dest->extcfg); |
---|
| 1106 | |
---|
| 1107 | return 1; |
---|
| 1108 | } |
---|
| 1109 | |
---|
| 1110 | # ------------------------------------------------------------------------------ |
---|
| 1111 | # SYNOPSIS |
---|
| 1112 | # $rc = $self->write_cfg_bld (); |
---|
| 1113 | # |
---|
| 1114 | # DESCRIPTION |
---|
| 1115 | # This internal method writes the build configuration file. |
---|
| 1116 | # ------------------------------------------------------------------------------ |
---|
| 1117 | |
---|
| 1118 | sub write_cfg_bld { |
---|
| 1119 | my $self = shift; |
---|
| 1120 | |
---|
| 1121 | my $cfg = FCM1::CfgFile->new (TYPE => 'bld'); |
---|
| 1122 | $cfg->lines ([$self->to_cfglines_bld()]); |
---|
| 1123 | $cfg->print_cfg ($self->dest->bldcfg); |
---|
| 1124 | |
---|
| 1125 | return 1; |
---|
| 1126 | } |
---|
| 1127 | |
---|
| 1128 | # ------------------------------------------------------------------------------ |
---|
| 1129 | |
---|
| 1130 | 1; |
---|
| 1131 | |
---|
| 1132 | __END__ |
---|