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