[1980] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # NAME |
---|
| 3 | # Fcm::Dest |
---|
| 4 | # |
---|
| 5 | # DESCRIPTION |
---|
| 6 | # This class contains methods to set up a destination location of an FCM |
---|
| 7 | # extract/build. |
---|
| 8 | # |
---|
| 9 | # COPYRIGHT |
---|
| 10 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 11 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 12 | # which you should have received as part of this distribution. |
---|
| 13 | # ------------------------------------------------------------------------------ |
---|
| 14 | use warnings; |
---|
| 15 | use strict; |
---|
| 16 | |
---|
| 17 | package Fcm::Dest; |
---|
| 18 | use base qw{Fcm::Base}; |
---|
| 19 | |
---|
| 20 | use Carp qw{croak} ; |
---|
| 21 | use Cwd qw{cwd} ; |
---|
| 22 | use Fcm::CfgLine ; |
---|
| 23 | use Fcm::Timer qw{timestamp_command} ; |
---|
| 24 | use Fcm::Util qw{run_command touch_file w_report}; |
---|
| 25 | use File::Basename qw{basename dirname} ; |
---|
| 26 | use File::Find qw{find} ; |
---|
| 27 | use File::Path qw{mkpath rmtree} ; |
---|
| 28 | use File::Spec ; |
---|
| 29 | use Sys::Hostname qw{hostname} ; |
---|
| 30 | use Text::ParseWords qw{shellwords} ; |
---|
| 31 | |
---|
| 32 | # Useful variables |
---|
| 33 | # ------------------------------------------------------------------------------ |
---|
| 34 | # List of configuration files |
---|
| 35 | our @cfgfiles = ( |
---|
| 36 | 'bldcfg', # default location of the build configuration file |
---|
| 37 | 'extcfg', # default location of the extract configuration file |
---|
| 38 | ); |
---|
| 39 | |
---|
| 40 | # List of cache and configuration files, according to the dest type |
---|
| 41 | our @cfgfiles_type = ( |
---|
| 42 | 'cache', # default location of the cache file |
---|
| 43 | 'cfg', # default location of the configuration file |
---|
| 44 | 'parsedcfg', # default location of the as-parsed configuration file |
---|
| 45 | ); |
---|
| 46 | |
---|
| 47 | # List of lock files |
---|
| 48 | our @lockfiles = ( |
---|
| 49 | 'bldlock', # the build lock file |
---|
| 50 | 'extlock', # the extract lock file |
---|
| 51 | ); |
---|
| 52 | |
---|
| 53 | # List of misc files |
---|
| 54 | our @miscfiles_bld = ( |
---|
| 55 | 'bldrunenvsh', # the build run environment shell script |
---|
| 56 | 'bldmakefile', # the build Makefile |
---|
| 57 | ); |
---|
| 58 | |
---|
| 59 | # List of sub-directories created by extract |
---|
| 60 | our @subdirs_ext = ( |
---|
| 61 | 'cfgdir', # sub-directory for configuration files |
---|
| 62 | 'srcdir', # sub-directory for source tree |
---|
| 63 | ); |
---|
| 64 | |
---|
| 65 | # List of sub-directories that can be archived by "tar" at end of build |
---|
| 66 | our @subdirs_tar = ( |
---|
| 67 | 'donedir', # sub-directory for "done" files |
---|
| 68 | 'flagsdir', # sub-directory for "flags" files |
---|
| 69 | 'incdir', # sub-directory for include files |
---|
| 70 | 'ppsrcdir', # sub-directory for pre-process source tree |
---|
| 71 | 'objdir', # sub-directory for object files |
---|
| 72 | ); |
---|
| 73 | |
---|
| 74 | # List of sub-directories created by build |
---|
| 75 | our @subdirs_bld = ( |
---|
| 76 | 'bindir', # sub-directory for executables |
---|
| 77 | 'etcdir', # sub-directory for miscellaneous files |
---|
| 78 | 'libdir', # sub-directory for object libraries |
---|
| 79 | 'tmpdir', # sub-directory for temporary build files |
---|
| 80 | @subdirs_tar, # -see above- |
---|
| 81 | ); |
---|
| 82 | |
---|
| 83 | # List of sub-directories under rootdir |
---|
| 84 | our @subdirs = ( |
---|
| 85 | 'cachedir', # sub-directory for caches |
---|
| 86 | @subdirs_ext, # -see above- |
---|
| 87 | @subdirs_bld, # -see above- |
---|
| 88 | ); |
---|
| 89 | |
---|
| 90 | # List of inherited search paths |
---|
| 91 | # "rootdir" + all @subdirs, with "XXXdir" replaced with "XXXpath" |
---|
| 92 | our @paths = ( |
---|
| 93 | 'rootpath', |
---|
| 94 | (map {my $key = $_; $key =~ s{dir\z}{path}msx; $key} @subdirs), |
---|
| 95 | ); |
---|
| 96 | |
---|
| 97 | # List of properties and their default values. |
---|
| 98 | my %PROP_OF = ( |
---|
| 99 | # the original destination (if current destination is a mirror) |
---|
| 100 | 'dest0' => undef, |
---|
| 101 | # list of inherited Fcm::Dest objects |
---|
| 102 | 'inherit' => [], |
---|
| 103 | # remote login name |
---|
| 104 | 'logname' => scalar(getpwuid($<)), |
---|
| 105 | # lock file |
---|
| 106 | 'lockfile' => undef, |
---|
| 107 | # remote machine |
---|
| 108 | 'machine' => hostname(), |
---|
| 109 | # mirror command to use |
---|
| 110 | 'mirror_cmd' => 'rsync', |
---|
| 111 | # (for rsync) remote mkdir, the remote shell command |
---|
| 112 | 'rsh_mkdir_rsh' => 'ssh', |
---|
| 113 | # (for rsync) remote mkdir, the remote shell command flags |
---|
| 114 | 'rsh_mkdir_rshflags' => '-n -oBatchMode=yes', |
---|
| 115 | # (for rsync) remote mkdir, the remote shell command |
---|
| 116 | 'rsh_mkdir_mkdir' => 'mkdir', |
---|
| 117 | # (for rsync) remote mkdir, the remote shell command flags |
---|
| 118 | 'rsh_mkdir_mkdirflags' => '-p', |
---|
| 119 | # (for rsync) remote mkdir, the remote shell command |
---|
| 120 | 'rsync' => 'rsync', |
---|
| 121 | # (for rsync) remote mkdir, the remote shell command flags |
---|
| 122 | 'rsyncflags' => q{-a --exclude='.*' --delete-excluded} |
---|
| 123 | . q{ --timeout=900 --rsh='ssh -oBatchMode=yes'}, |
---|
| 124 | # destination root directory |
---|
| 125 | 'rootdir' => undef, |
---|
| 126 | # destination type, "bld" (default) or "ext" |
---|
| 127 | 'type' => 'bld', |
---|
| 128 | ); |
---|
| 129 | # Hook for property setter |
---|
| 130 | my %PROP_HOOK_OF = ( |
---|
| 131 | 'inherit' => \&_reset_inherit, |
---|
| 132 | 'rootdir' => \&_reset_rootdir, |
---|
| 133 | ); |
---|
| 134 | |
---|
| 135 | # Mirror implementations |
---|
| 136 | my %MIRROR_IMPL_OF = ( |
---|
| 137 | rdist => \&_mirror_with_rdist, |
---|
| 138 | rsync => \&_mirror_with_rsync, |
---|
| 139 | ); |
---|
| 140 | |
---|
| 141 | # ------------------------------------------------------------------------------ |
---|
| 142 | # SYNOPSIS |
---|
| 143 | # $obj = Fcm::Dest->new(%args); |
---|
| 144 | # |
---|
| 145 | # DESCRIPTION |
---|
| 146 | # This method constructs a new instance of the Fcm::Dest class. See above for |
---|
| 147 | # allowed list of properties. (KEYS should be in uppercase.) |
---|
| 148 | # ------------------------------------------------------------------------------ |
---|
| 149 | |
---|
| 150 | sub new { |
---|
| 151 | my ($class, %args) = @_; |
---|
| 152 | my $self = bless(Fcm::Base->new(%args), $class); |
---|
| 153 | while (my ($key, $value) = each(%args)) { |
---|
| 154 | $key = lc($key); |
---|
| 155 | if (exists($PROP_OF{$key})) { |
---|
| 156 | $self->{$key} = $value; |
---|
| 157 | } |
---|
| 158 | } |
---|
| 159 | for my $key (@subdirs, @paths, @lockfiles, @cfgfiles) { |
---|
| 160 | $self->{$key} = undef; |
---|
| 161 | } |
---|
| 162 | return $self; |
---|
| 163 | } |
---|
| 164 | |
---|
| 165 | # ------------------------------------------------------------------------------ |
---|
| 166 | # SYNOPSIS |
---|
| 167 | # $self->DESTROY; |
---|
| 168 | # |
---|
| 169 | # DESCRIPTION |
---|
| 170 | # This method is called automatically when the Fcm::Dest object is |
---|
| 171 | # destroyed. |
---|
| 172 | # ------------------------------------------------------------------------------ |
---|
| 173 | |
---|
| 174 | sub DESTROY { |
---|
| 175 | my $self = shift; |
---|
| 176 | |
---|
| 177 | # Remove the lockfile if it is set |
---|
| 178 | unlink $self->lockfile if $self->lockfile and -w $self->lockfile; |
---|
| 179 | |
---|
| 180 | return; |
---|
| 181 | } |
---|
| 182 | |
---|
| 183 | # ------------------------------------------------------------------------------ |
---|
| 184 | # SYNOPSIS |
---|
| 185 | # $value = $obj->X($value); |
---|
| 186 | # |
---|
| 187 | # DESCRIPTION |
---|
| 188 | # Details of these properties are explained in %PROP_OF. |
---|
| 189 | # ------------------------------------------------------------------------------ |
---|
| 190 | |
---|
| 191 | while (my ($key, $default) = each(%PROP_OF)) { |
---|
| 192 | no strict 'refs'; |
---|
| 193 | *{$key} = sub { |
---|
| 194 | my $self = shift(); |
---|
| 195 | # Set property to specified value |
---|
| 196 | if (@_) { |
---|
| 197 | $self->{$key} = $_[0]; |
---|
| 198 | if (exists($PROP_HOOK_OF{$key})) { |
---|
| 199 | $PROP_HOOK_OF{$key}->($self, $key); |
---|
| 200 | } |
---|
| 201 | } |
---|
| 202 | # Sets default where possible |
---|
| 203 | if (!defined($self->{$key})) { |
---|
| 204 | $self->{$key} = $default; |
---|
| 205 | } |
---|
| 206 | return $self->{$key}; |
---|
| 207 | }; |
---|
| 208 | } |
---|
| 209 | |
---|
| 210 | # Remote shell property: deprecated. |
---|
| 211 | sub remote_shell { |
---|
| 212 | my $self = shift(); |
---|
| 213 | $self->rsh_mkdir_rsh(@_); |
---|
| 214 | } |
---|
| 215 | |
---|
| 216 | # Resets properties associated with root directory. |
---|
| 217 | sub _reset_rootdir { |
---|
| 218 | my $self = shift(); |
---|
| 219 | for my $key (@cfgfiles, @lockfiles, @miscfiles_bld, @subdirs) { |
---|
| 220 | $self->{$key} = undef; |
---|
| 221 | } |
---|
| 222 | } |
---|
| 223 | |
---|
| 224 | # Reset properties associated with inherited paths. |
---|
| 225 | sub _reset_inherit { |
---|
| 226 | my $self = shift(); |
---|
| 227 | for my $key (@paths) { |
---|
| 228 | $self->{$key} = undef; |
---|
| 229 | } |
---|
| 230 | } |
---|
| 231 | |
---|
| 232 | # ------------------------------------------------------------------------------ |
---|
| 233 | # SYNOPSIS |
---|
| 234 | # $value = $obj->X; |
---|
| 235 | # |
---|
| 236 | # DESCRIPTION |
---|
| 237 | # This method returns X, where X is a location derived from rootdir, and can |
---|
| 238 | # be one of: |
---|
| 239 | # bindir, bldcfg, blddir, bldlock, bldrunenv, cache, cachedir, cfg, cfgdir, |
---|
| 240 | # donedir, etcdir, extcfg, extlock, flagsdir, incdir, libdir, parsedcfg, |
---|
| 241 | # ppsrcdir, objdir, or tmpdir. |
---|
| 242 | # |
---|
| 243 | # Details of these properties are explained earlier. |
---|
| 244 | # ------------------------------------------------------------------------------ |
---|
| 245 | |
---|
| 246 | for my $name (@cfgfiles, @cfgfiles_type, @lockfiles, @miscfiles_bld, @subdirs) { |
---|
| 247 | no strict 'refs'; |
---|
| 248 | |
---|
| 249 | *$name = sub { |
---|
| 250 | my $self = shift; |
---|
| 251 | |
---|
| 252 | # If variable not set, derive it from rootdir |
---|
| 253 | if ($self->rootdir and not defined $self->{$name}) { |
---|
| 254 | if ($name eq 'cache') { |
---|
| 255 | # Cache file under root/.cache |
---|
| 256 | $self->{$name} = File::Spec->catfile ( |
---|
| 257 | $self->cachedir, $self->setting ('CACHE'), |
---|
| 258 | ); |
---|
| 259 | |
---|
| 260 | } elsif ($name eq 'cfg') { |
---|
| 261 | # Configuration file of current type |
---|
| 262 | my $method = $self->type . 'cfg'; |
---|
| 263 | $self->{$name} = $self->$method; |
---|
| 264 | |
---|
| 265 | } elsif (grep {$name eq $_} @cfgfiles) { |
---|
| 266 | # Configuration files under the root/cfg |
---|
| 267 | (my $label = uc ($name)) =~ s/CFG//; |
---|
| 268 | $self->{$name} = File::Spec->catfile ( |
---|
| 269 | $self->cfgdir, $self->setting ('CFG_NAME', $label), |
---|
| 270 | ); |
---|
| 271 | |
---|
| 272 | } elsif (grep {$name eq $_} @lockfiles) { |
---|
| 273 | # Lock file |
---|
| 274 | $self->{$name} = File::Spec->catfile ( |
---|
| 275 | $self->rootdir, $self->setting ('LOCK', uc ($name)), |
---|
| 276 | ); |
---|
| 277 | |
---|
| 278 | } elsif (grep {$name eq $_} @miscfiles_bld) { |
---|
| 279 | # Misc file |
---|
| 280 | $self->{$name} = File::Spec->catfile ( |
---|
| 281 | $self->rootdir, $self->setting ('BLD_MISC', uc ($name)), |
---|
| 282 | ); |
---|
| 283 | |
---|
| 284 | } elsif ($name eq 'parsedcfg') { |
---|
| 285 | # As-parsed configuration file of current type |
---|
| 286 | $self->{$name} = File::Spec->catfile ( |
---|
| 287 | dirname ($self->cfg), |
---|
| 288 | $self->setting (qw/CFG_NAME PARSED/) . basename ($self->cfg), |
---|
| 289 | ) |
---|
| 290 | |
---|
| 291 | } elsif (grep {$name eq $_} @subdirs) { |
---|
| 292 | # Sub-directories under the root |
---|
| 293 | (my $label = uc ($name)) =~ s/DIR//; |
---|
| 294 | $self->{$name} = File::Spec->catfile ( |
---|
| 295 | $self->rootdir, |
---|
| 296 | $self->setting ('DIR', $label), |
---|
| 297 | ($name eq 'cachedir' ? '.' . $self->type : ()), |
---|
| 298 | ); |
---|
| 299 | } |
---|
| 300 | } |
---|
| 301 | |
---|
| 302 | return $self->{$name}; |
---|
| 303 | } |
---|
| 304 | } |
---|
| 305 | |
---|
| 306 | # ------------------------------------------------------------------------------ |
---|
| 307 | # SYNOPSIS |
---|
| 308 | # $value = $obj->X; |
---|
| 309 | # |
---|
| 310 | # DESCRIPTION |
---|
| 311 | # This method returns X, an array containing the search path of a destination |
---|
| 312 | # directory, which can be one of: |
---|
| 313 | # binpath, bldpath, cachepath, cfgpath, donepath, etcpath, flagspath, |
---|
| 314 | # incpath, libpath, ppsrcpath, objpath, rootpath, srcpath, or tmppath, |
---|
| 315 | # |
---|
| 316 | # Details of these properties are explained earlier. |
---|
| 317 | # ------------------------------------------------------------------------------ |
---|
| 318 | |
---|
| 319 | for my $name (@paths) { |
---|
| 320 | no strict 'refs'; |
---|
| 321 | |
---|
| 322 | *$name = sub { |
---|
| 323 | my $self = shift; |
---|
| 324 | |
---|
| 325 | (my $dir = $name) =~ s/path/dir/; |
---|
| 326 | |
---|
| 327 | if ($self->$dir and not defined $self->{$name}) { |
---|
| 328 | my @path = (); |
---|
| 329 | |
---|
| 330 | # Recursively inherit the search path |
---|
| 331 | for my $d (@{ $self->inherit }) { |
---|
| 332 | unshift @path, $d->$dir; |
---|
| 333 | } |
---|
| 334 | |
---|
| 335 | # Place the path of the current build in the front |
---|
| 336 | unshift @path, $self->$dir; |
---|
| 337 | |
---|
| 338 | $self->{$name} = \@path; |
---|
| 339 | } |
---|
| 340 | |
---|
| 341 | return $self->{$name}; |
---|
| 342 | } |
---|
| 343 | } |
---|
| 344 | |
---|
| 345 | # ------------------------------------------------------------------------------ |
---|
| 346 | # SYNOPSIS |
---|
| 347 | # $rc = $obj->archive (); |
---|
| 348 | # |
---|
| 349 | # DESCRIPTION |
---|
| 350 | # This method creates TAR archives for selected sub-directories. |
---|
| 351 | # ------------------------------------------------------------------------------ |
---|
| 352 | |
---|
| 353 | sub archive { |
---|
| 354 | my $self = shift; |
---|
| 355 | |
---|
| 356 | # Save current directory |
---|
| 357 | my $cwd = cwd (); |
---|
| 358 | |
---|
| 359 | my $tar = $self->setting (qw/OUTFILE_EXT TAR/); |
---|
| 360 | my $verbose = $self->verbose; |
---|
| 361 | |
---|
| 362 | for my $name (@subdirs_tar) { |
---|
| 363 | my $dir = $self->$name; |
---|
| 364 | |
---|
| 365 | # Ignore unless sub-directory exists |
---|
| 366 | next unless -d $dir; |
---|
| 367 | |
---|
| 368 | # Change to container directory |
---|
| 369 | my $base = basename ($dir); |
---|
| 370 | print 'cd ', dirname ($dir), "\n" if $verbose > 2; |
---|
| 371 | chdir dirname ($dir); |
---|
| 372 | |
---|
| 373 | # Run "tar" command |
---|
| 374 | my $rc = &run_command ( |
---|
| 375 | [qw/tar -czf/, $base . $tar, $base], |
---|
| 376 | PRINT => $verbose > 1, ERROR => 'warn', |
---|
| 377 | ); |
---|
| 378 | |
---|
| 379 | # Remove sub-directory |
---|
| 380 | &run_command ([qw/rm -rf/, $base], PRINT => $verbose > 1) if not $rc; |
---|
| 381 | } |
---|
| 382 | |
---|
| 383 | # Change back to "current" directory |
---|
| 384 | print 'cd ', $cwd, "\n" if $verbose > 2; |
---|
| 385 | chdir $cwd; |
---|
| 386 | |
---|
| 387 | return 1; |
---|
| 388 | } |
---|
| 389 | |
---|
| 390 | # ------------------------------------------------------------------------------ |
---|
| 391 | # SYNOPSIS |
---|
| 392 | # $authority = $obj->authority(); |
---|
| 393 | # |
---|
| 394 | # DESCRIPTION |
---|
| 395 | # Returns LOGNAME@MACHINE for this destination if LOGNAME is defined and not |
---|
| 396 | # the same as the user ID of the current process. Returns MACHINE if LOGNAME |
---|
| 397 | # is the same as the user ID of the current process, but MACHINE is not the |
---|
| 398 | # same as the current hostname. Returns an empty string if LOGNAME and |
---|
| 399 | # MACHINE are not defined or are the same as in the current process. |
---|
| 400 | # ------------------------------------------------------------------------------ |
---|
| 401 | |
---|
| 402 | sub authority { |
---|
| 403 | my $self = shift; |
---|
| 404 | my $return = ''; |
---|
| 405 | |
---|
| 406 | if ($self->logname ne $self->config->user_id) { |
---|
| 407 | $return = $self->logname . '@' . $self->machine; |
---|
| 408 | |
---|
| 409 | } elsif ($self->machine ne &hostname()) { |
---|
| 410 | $return = $self->machine; |
---|
| 411 | } |
---|
| 412 | |
---|
| 413 | return $return; |
---|
| 414 | } |
---|
| 415 | |
---|
| 416 | # ------------------------------------------------------------------------------ |
---|
| 417 | # SYNOPSIS |
---|
| 418 | # $rc = $obj->clean([ITEM => <list>,] [MODE => 'ALL|CONTENT|EMPTY',]); |
---|
| 419 | # |
---|
| 420 | # DESCRIPTION |
---|
| 421 | # This method removes files/directories from the destination. If ITEM is set, |
---|
| 422 | # it must be a reference to a list of method names for files/directories to |
---|
| 423 | # be removed. Otherwise, the list is determined by the destination type. If |
---|
| 424 | # MODE is ALL, all directories/files created by the extract/build are |
---|
| 425 | # removed. If MODE is CONTENT, only contents within sub-directories are |
---|
| 426 | # removed. If MODE is EMPTY (default), only empty sub-directories are |
---|
| 427 | # removed. |
---|
| 428 | # ------------------------------------------------------------------------------ |
---|
| 429 | |
---|
| 430 | sub clean { |
---|
| 431 | my ($self, %args) = @_; |
---|
| 432 | my $mode = exists $args{MODE} ? $args{MODE} : 'EMPTY'; |
---|
| 433 | my $rc = 1; |
---|
| 434 | my @names |
---|
| 435 | = $args{ITEM} ? @{$args{ITEM}} |
---|
| 436 | : $self->type() eq 'ext' ? ('cachedir', @subdirs_ext) |
---|
| 437 | : ('cachedir', @subdirs_bld, @miscfiles_bld) |
---|
| 438 | ; |
---|
| 439 | my @items; |
---|
| 440 | if ($mode eq 'CONTENT') { |
---|
| 441 | for my $name (@names) { |
---|
| 442 | my $item = $self->$name(); |
---|
| 443 | push(@items, _directory_contents($item)); |
---|
| 444 | } |
---|
| 445 | } |
---|
| 446 | else { |
---|
| 447 | for my $name (@names) { |
---|
| 448 | my $item = $self->$name(); |
---|
| 449 | if ($mode eq 'ALL' || -d $item && !_directory_contents($item)) { |
---|
| 450 | push(@items, $item); |
---|
| 451 | } |
---|
| 452 | } |
---|
| 453 | } |
---|
| 454 | for my $item (@items) { |
---|
| 455 | if ($self->verbose() >= 2) { |
---|
| 456 | printf("%s: remove\n", $item); |
---|
| 457 | } |
---|
| 458 | eval {rmtree($item)}; |
---|
| 459 | if ($@) { |
---|
| 460 | w_report($@); |
---|
| 461 | $rc = 0; |
---|
| 462 | } |
---|
| 463 | } |
---|
| 464 | return $rc; |
---|
| 465 | } |
---|
| 466 | |
---|
| 467 | # ------------------------------------------------------------------------------ |
---|
| 468 | # SYNOPSIS |
---|
| 469 | # $rc = $obj->create ([DIR => <dir-list>,]); |
---|
| 470 | # |
---|
| 471 | # DESCRIPTION |
---|
| 472 | # This method creates the directories of a destination. If DIR is set, it |
---|
| 473 | # must be a reference to a list of sub-directories to be created. Otherwise, |
---|
| 474 | # the sub-directory list is determined by the destination type. It returns |
---|
| 475 | # true if the destination is created or if it exists and is writable. |
---|
| 476 | # ------------------------------------------------------------------------------ |
---|
| 477 | |
---|
| 478 | sub create { |
---|
| 479 | my ($self, %args) = @_; |
---|
| 480 | |
---|
| 481 | my $rc = 1; |
---|
| 482 | |
---|
| 483 | my @dirs; |
---|
| 484 | if (exists $args{DIR} and $args{DIR}) { |
---|
| 485 | # Create only selected sub-directories |
---|
| 486 | @dirs = @{ $args{DIR} }; |
---|
| 487 | |
---|
| 488 | } else { |
---|
| 489 | # Create rootdir, cachedir and read-write sub-directories for extract/build |
---|
| 490 | @dirs = ( |
---|
| 491 | qw/rootdir cachedir/, |
---|
| 492 | ($self->type eq 'ext' ? @subdirs_ext : @subdirs_bld), |
---|
| 493 | ); |
---|
| 494 | } |
---|
| 495 | |
---|
| 496 | for my $name (@dirs) { |
---|
| 497 | my $dir = $self->$name; |
---|
| 498 | |
---|
| 499 | # Create directory if it does not already exist |
---|
| 500 | if (not -d $dir) { |
---|
| 501 | print 'Make directory: ', $dir, "\n" if $self->verbose > 1; |
---|
| 502 | mkpath $dir; |
---|
| 503 | } |
---|
| 504 | |
---|
| 505 | # Check whether directory exists and is writable |
---|
| 506 | unless (-d $dir and -w $dir) { |
---|
| 507 | w_report 'ERROR: ', $dir, ': cannot write to destination.'; |
---|
| 508 | $rc = 0; |
---|
| 509 | } |
---|
| 510 | } |
---|
| 511 | |
---|
| 512 | return $rc; |
---|
| 513 | } |
---|
| 514 | |
---|
| 515 | # ------------------------------------------------------------------------------ |
---|
| 516 | # SYNOPSIS |
---|
| 517 | # $rc = $obj->create_bldrunenvsh (); |
---|
| 518 | # |
---|
| 519 | # DESCRIPTION |
---|
| 520 | # This method creates the runtime environment script for the build. |
---|
| 521 | # ------------------------------------------------------------------------------ |
---|
| 522 | |
---|
| 523 | sub create_bldrunenvsh { |
---|
| 524 | my $self = shift; |
---|
| 525 | |
---|
| 526 | # Path to executable files and directory for misc files |
---|
| 527 | my @bin_paths = grep {_directory_contents($_)} @{$self->binpath()}; |
---|
| 528 | my $bin_dir = -d $self->bindir() ? $self->bindir() : undef; |
---|
| 529 | my $etc_dir = _directory_contents($self->etcdir()) ? $self->etcdir() : undef; |
---|
| 530 | |
---|
| 531 | # Create a runtime environment script if necessary |
---|
| 532 | if (@bin_paths || $etc_dir) { |
---|
| 533 | my $path = $self->bldrunenvsh(); |
---|
| 534 | open(my $handle, '>', $path) || croak("$path: cannot open ($!)\n"); |
---|
| 535 | printf($handle "#!%s\n", $self->setting(qw/TOOL SHELL/)); |
---|
| 536 | if (@bin_paths) { |
---|
| 537 | printf($handle "PATH=%s:\$PATH\n", join(':', @bin_paths)); |
---|
| 538 | print($handle "export PATH\n"); |
---|
| 539 | } |
---|
| 540 | if ($etc_dir) { |
---|
| 541 | printf($handle "FCM_ETCDIR=%s\n", $etc_dir); |
---|
| 542 | print($handle "export FCM_ETCDIR\n"); |
---|
| 543 | } |
---|
| 544 | close($handle) || croak("$path: cannot close ($!)\n"); |
---|
| 545 | |
---|
| 546 | # Create symbolic links fcm_env.ksh and bin/fcm_env.ksh for backward |
---|
| 547 | # compatibility |
---|
| 548 | my $FCM_ENV_KSH = 'fcm_env.ksh'; |
---|
| 549 | for my $link ( |
---|
| 550 | File::Spec->catfile($self->rootdir, $FCM_ENV_KSH), |
---|
| 551 | ($bin_dir ? File::Spec->catfile($bin_dir, $FCM_ENV_KSH) : ()), |
---|
| 552 | ) { |
---|
| 553 | if (-l $link && readlink($link) ne $path || -e $link) { |
---|
| 554 | unlink($link); |
---|
| 555 | } |
---|
| 556 | if (!-l $link) { |
---|
| 557 | symlink($path, $link) || croak("$link: cannot create symbolic link\n"); |
---|
| 558 | } |
---|
| 559 | } |
---|
| 560 | } |
---|
| 561 | return 1; |
---|
| 562 | } |
---|
| 563 | |
---|
| 564 | # ------------------------------------------------------------------------------ |
---|
| 565 | # SYNOPSIS |
---|
| 566 | # $rc = $obj->dearchive (); |
---|
| 567 | # |
---|
| 568 | # DESCRIPTION |
---|
| 569 | # This method extracts from TAR archives for selected sub-directories. |
---|
| 570 | # ------------------------------------------------------------------------------ |
---|
| 571 | |
---|
| 572 | sub dearchive { |
---|
| 573 | my $self = shift; |
---|
| 574 | |
---|
| 575 | my $tar = $self->setting (qw/OUTFILE_EXT TAR/); |
---|
| 576 | my $verbose = $self->verbose; |
---|
| 577 | |
---|
| 578 | # Extract archives if necessary |
---|
| 579 | for my $name (@subdirs_tar) { |
---|
| 580 | my $tar_file = $self->$name . $tar; |
---|
| 581 | |
---|
| 582 | # Check whether tar archive exists for the named sub-directory |
---|
| 583 | next unless -f $tar_file; |
---|
| 584 | |
---|
| 585 | # If so, extract the archive and remove it afterwards |
---|
| 586 | &run_command ([qw/tar -xzf/, $tar_file], PRINT => $verbose > 1); |
---|
| 587 | &run_command ([qw/rm -f/, $tar_file], PRINT => $verbose > 1); |
---|
| 588 | } |
---|
| 589 | |
---|
| 590 | return 1; |
---|
| 591 | } |
---|
| 592 | |
---|
| 593 | # ------------------------------------------------------------------------------ |
---|
| 594 | # SYNOPSIS |
---|
| 595 | # $name = $obj->get_pkgname_of_path ($path); |
---|
| 596 | # |
---|
| 597 | # DESCRIPTION |
---|
| 598 | # This method returns the package name of $path if $path is in (a relative |
---|
| 599 | # path of) $self->srcdir, or undef otherwise. |
---|
| 600 | # ------------------------------------------------------------------------------ |
---|
| 601 | |
---|
| 602 | sub get_pkgname_of_path { |
---|
| 603 | my ($self, $path) = @_; |
---|
| 604 | |
---|
| 605 | my $relpath = File::Spec->abs2rel ($path, $self->srcdir); |
---|
| 606 | my $name = $relpath ? [File::Spec->splitdir ($relpath)] : undef; |
---|
| 607 | |
---|
| 608 | return $name; |
---|
| 609 | } |
---|
| 610 | |
---|
| 611 | # ------------------------------------------------------------------------------ |
---|
| 612 | # SYNOPSIS |
---|
| 613 | # %src = $obj->get_source_files (); |
---|
| 614 | # |
---|
| 615 | # DESCRIPTION |
---|
| 616 | # This method returns a hash (keys = package names, values = file names) |
---|
| 617 | # under $self->srcdir. |
---|
| 618 | # ------------------------------------------------------------------------------ |
---|
| 619 | |
---|
| 620 | sub get_source_files { |
---|
| 621 | my $self = shift; |
---|
| 622 | |
---|
| 623 | my %src; |
---|
| 624 | if ($self->srcdir and -d $self->srcdir) { |
---|
| 625 | &find (sub { |
---|
| 626 | return if /^\./; # ignore system/hidden file |
---|
| 627 | return if -d $File::Find::name; # ignore directory |
---|
| 628 | return if not -r $File::Find::name; # ignore unreadable files |
---|
| 629 | |
---|
| 630 | my $name = join ( |
---|
| 631 | '__', @{ $self->get_pkgname_of_path ($File::Find::name) }, |
---|
| 632 | ); |
---|
| 633 | $src{$name} = $File::Find::name; |
---|
| 634 | }, $self->srcdir); |
---|
| 635 | } |
---|
| 636 | |
---|
| 637 | return \%src; |
---|
| 638 | } |
---|
| 639 | |
---|
| 640 | # ------------------------------------------------------------------------------ |
---|
| 641 | # SYNOPSIS |
---|
| 642 | # $rc = $obj->mirror (\@items); |
---|
| 643 | # |
---|
| 644 | # DESCRIPTION |
---|
| 645 | # This method mirrors @items (list of method names for directories or files) |
---|
| 646 | # from $dest0 (which must be an instance of Fcm::Dest for a local |
---|
| 647 | # destination) to this destination. |
---|
| 648 | # ------------------------------------------------------------------------------ |
---|
| 649 | |
---|
| 650 | sub mirror { |
---|
| 651 | my ($self, $items_ref) = @_; |
---|
| 652 | if ($self->authority() || $self->dest0()->rootdir() ne $self->rootdir()) { |
---|
| 653 | # Diagnostic |
---|
| 654 | if ($self->verbose()) { |
---|
| 655 | printf( |
---|
| 656 | "Destination: %s\n", |
---|
| 657 | ($self->authority() ? $self->authority() . q{:} : q{}) . $self->rootdir() |
---|
| 658 | ); |
---|
| 659 | } |
---|
| 660 | if ($MIRROR_IMPL_OF{$self->mirror_cmd()}) { |
---|
| 661 | $MIRROR_IMPL_OF{$self->mirror_cmd()}->($self, $self->dest0(), $items_ref); |
---|
| 662 | } |
---|
| 663 | else { |
---|
| 664 | # Unknown mirroring tool |
---|
| 665 | w_report($self->mirror_cmd, ': unknown mirroring tool, abort.'); |
---|
| 666 | return 0; |
---|
| 667 | } |
---|
| 668 | } |
---|
| 669 | return 1; |
---|
| 670 | } |
---|
| 671 | |
---|
| 672 | # ------------------------------------------------------------------------------ |
---|
| 673 | # SYNOPSIS |
---|
| 674 | # $rc = $self->_mirror_with_rdist ($dest0, \@items); |
---|
| 675 | # |
---|
| 676 | # DESCRIPTION |
---|
| 677 | # This internal method implements $self->mirror with "rdist". |
---|
| 678 | # ------------------------------------------------------------------------------ |
---|
| 679 | |
---|
| 680 | sub _mirror_with_rdist { |
---|
| 681 | my ($self, $dest0, $items) = @_; |
---|
| 682 | |
---|
| 683 | my $rhost = $self->authority ? $self->authority : &hostname(); |
---|
| 684 | |
---|
| 685 | # Print distfile content to temporary file |
---|
| 686 | my @distfile = (); |
---|
| 687 | for my $label (@$items) { |
---|
| 688 | push @distfile, '( ' . $dest0->$label . ' ) -> ' . $rhost . "\n"; |
---|
| 689 | push @distfile, ' install ' . $self->$label . ';' . "\n"; |
---|
| 690 | } |
---|
| 691 | |
---|
| 692 | # Set up mirroring command (use "rdist" at the moment) |
---|
| 693 | my $command = 'rdist -R'; |
---|
| 694 | $command .= ' -q' unless $self->verbose > 1; |
---|
| 695 | $command .= ' -f - 1>/dev/null'; |
---|
| 696 | |
---|
| 697 | # Diagnostic |
---|
| 698 | my $croak = 'Cannot execute "' . $command . '"'; |
---|
| 699 | if ($self->verbose > 2) { |
---|
| 700 | print timestamp_command ($command, 'Start'); |
---|
| 701 | print ' ', $_ for (@distfile); |
---|
| 702 | } |
---|
| 703 | |
---|
| 704 | # Execute the mirroring command |
---|
| 705 | open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort'; |
---|
| 706 | for my $line (@distfile) { |
---|
| 707 | print COMMAND $line; |
---|
| 708 | } |
---|
| 709 | close COMMAND or croak $croak, ' (', $?, '), abort'; |
---|
| 710 | |
---|
| 711 | # Diagnostic |
---|
| 712 | print timestamp_command ($command, 'End ') if $self->verbose > 2; |
---|
| 713 | |
---|
| 714 | return 1; |
---|
| 715 | } |
---|
| 716 | |
---|
| 717 | # ------------------------------------------------------------------------------ |
---|
| 718 | # SYNOPSIS |
---|
| 719 | # $rc = $self->_mirror_with_rsync($dest0, \@items); |
---|
| 720 | # |
---|
| 721 | # DESCRIPTION |
---|
| 722 | # This internal method implements $self->mirror() with "rsync". |
---|
| 723 | # ------------------------------------------------------------------------------ |
---|
| 724 | |
---|
| 725 | sub _mirror_with_rsync { |
---|
| 726 | my ($self, $dest0, $items_ref) = @_; |
---|
| 727 | my @rsh_mkdir; |
---|
| 728 | if ($self->authority()) { |
---|
| 729 | @rsh_mkdir = ( |
---|
| 730 | $self->rsh_mkdir_rsh(), |
---|
| 731 | shellwords($self->rsh_mkdir_rshflags()), |
---|
| 732 | $self->authority(), |
---|
| 733 | $self->rsh_mkdir_mkdir(), |
---|
| 734 | shellwords($self->rsh_mkdir_mkdirflags()), |
---|
| 735 | ); |
---|
| 736 | } |
---|
| 737 | my @rsync = ($self->rsync(), shellwords($self->rsyncflags())); |
---|
| 738 | my @rsync_verbose = ($self->verbose() > 2 ? '-v' : ()); |
---|
| 739 | my $auth = $self->authority() ? $self->authority() . q{:} : q{}; |
---|
| 740 | for my $item (@{$items_ref}) { |
---|
| 741 | # Create container directory, as rsync does not do it automatically |
---|
| 742 | my $dir = dirname($self->$item()); |
---|
| 743 | if (@rsh_mkdir) { |
---|
| 744 | run_command([@rsh_mkdir, $dir], TIME => $self->verbose() > 2); |
---|
| 745 | } |
---|
| 746 | else { |
---|
| 747 | mkpath($dir); |
---|
| 748 | } |
---|
| 749 | run_command( |
---|
| 750 | [@rsync, @rsync_verbose, $dest0->$item(), $auth . $dir], |
---|
| 751 | TIME => $self->verbose > 2, |
---|
| 752 | ); |
---|
| 753 | } |
---|
| 754 | return 1; |
---|
| 755 | } |
---|
| 756 | |
---|
| 757 | # ------------------------------------------------------------------------------ |
---|
| 758 | # SYNOPSIS |
---|
| 759 | # $rc = $obj->set_lock (); |
---|
| 760 | # |
---|
| 761 | # DESCRIPTION |
---|
| 762 | # This method sets a lock in the current destination. |
---|
| 763 | # ------------------------------------------------------------------------------ |
---|
| 764 | |
---|
| 765 | sub set_lock { |
---|
| 766 | my $self = shift; |
---|
| 767 | |
---|
| 768 | $self->lockfile (); |
---|
| 769 | |
---|
| 770 | if ($self->type eq 'ext' and not $self->dest0) { |
---|
| 771 | # Only set an extract lock for the local destination |
---|
| 772 | $self->lockfile ($self->extlock); |
---|
| 773 | |
---|
| 774 | } elsif ($self->type eq 'bld') { |
---|
| 775 | # Set a build lock |
---|
| 776 | $self->lockfile ($self->bldlock); |
---|
| 777 | } |
---|
| 778 | |
---|
| 779 | return &touch_file ($self->lockfile) if $self->lockfile; |
---|
| 780 | } |
---|
| 781 | |
---|
| 782 | # ------------------------------------------------------------------------------ |
---|
| 783 | # SYNOPSIS |
---|
| 784 | # @cfglines = $obj->to_cfglines ([$index]); |
---|
| 785 | # |
---|
| 786 | # DESCRIPTION |
---|
| 787 | # This method returns a list of configuration lines for the current |
---|
| 788 | # destination. If it is set, $index is the index number of the current |
---|
| 789 | # destination. |
---|
| 790 | # ------------------------------------------------------------------------------ |
---|
| 791 | |
---|
| 792 | sub to_cfglines { |
---|
| 793 | my ($self, $index) = @_; |
---|
| 794 | |
---|
| 795 | my $PREFIX = $self->cfglabel($self->dest0() ? 'RDEST' : 'DEST'); |
---|
| 796 | my $SUFFIX = ($index ? $Fcm::Config::DELIMITER . $index : q{}); |
---|
| 797 | |
---|
| 798 | my @return = ( |
---|
| 799 | Fcm::CfgLine->new(label => $PREFIX . $SUFFIX, value => $self->rootdir()), |
---|
| 800 | ); |
---|
| 801 | if ($self->dest0()) { |
---|
| 802 | for my $name (qw{ |
---|
| 803 | logname |
---|
| 804 | machine |
---|
| 805 | mirror_cmd |
---|
| 806 | rsh_mkdir_rsh |
---|
| 807 | rsh_mkdir_rshflags |
---|
| 808 | rsh_mkdir_mkdir |
---|
| 809 | rsh_mkdir_mkdirflags |
---|
| 810 | rsync |
---|
| 811 | rsyncflags |
---|
| 812 | }) { |
---|
| 813 | if ($self->{$name} && $self->{$name} ne $PROP_OF{$name}) { # not default |
---|
| 814 | push( |
---|
| 815 | @return, |
---|
| 816 | Fcm::CfgLine->new( |
---|
| 817 | label => $PREFIX . $Fcm::Config::DELIMITER . uc($name) . $SUFFIX, |
---|
| 818 | value => $self->{$name}, |
---|
| 819 | ), |
---|
| 820 | ); |
---|
| 821 | } |
---|
| 822 | } |
---|
| 823 | } |
---|
| 824 | |
---|
| 825 | return @return; |
---|
| 826 | } |
---|
| 827 | |
---|
| 828 | # ------------------------------------------------------------------------------ |
---|
| 829 | # SYNOPSIS |
---|
| 830 | # $string = $obj->write_rules (); |
---|
| 831 | # |
---|
| 832 | # DESCRIPTION |
---|
| 833 | # This method returns a string containing Makefile variable declarations for |
---|
| 834 | # directories and search paths in this destination. |
---|
| 835 | # ------------------------------------------------------------------------------ |
---|
| 836 | |
---|
| 837 | sub write_rules { |
---|
| 838 | my $self = shift; |
---|
| 839 | my $return = ''; |
---|
| 840 | |
---|
| 841 | # FCM_*DIR* |
---|
| 842 | for my $i (0 .. @{ $self->inherit }) { |
---|
| 843 | for my $name (@paths) { |
---|
| 844 | (my $label = $name) =~ s/path$/dir/; |
---|
| 845 | my $dir = $name eq 'rootpath' ? $self->$name->[$i] : File::Spec->catfile ( |
---|
| 846 | '$(FCM_ROOTDIR' . ($i ? $i : '') . ')', |
---|
| 847 | File::Spec->abs2rel ($self->$name->[$i], $self->rootpath->[$i]), |
---|
| 848 | ); |
---|
| 849 | |
---|
| 850 | $return .= ($i ? '' : 'export ') . 'FCM_' . uc ($label) . ($i ? $i : '') . |
---|
| 851 | ' := ' . $dir . "\n"; |
---|
| 852 | } |
---|
| 853 | } |
---|
| 854 | |
---|
| 855 | # FCM_*PATH |
---|
| 856 | for my $name (@paths) { |
---|
| 857 | (my $label = $name) =~ s/path$/dir/; |
---|
| 858 | |
---|
| 859 | $return .= 'export FCM_' . uc ($name) . ' := '; |
---|
| 860 | for my $i (0 .. @{ $self->$name } - 1) { |
---|
| 861 | $return .= ($i ? ':' : '') . '$(FCM_' . uc ($label) . ($i ? $i : '') . ')'; |
---|
| 862 | } |
---|
| 863 | $return .= "\n"; |
---|
| 864 | } |
---|
| 865 | |
---|
| 866 | $return .= "\n"; |
---|
| 867 | |
---|
| 868 | return $return; |
---|
| 869 | } |
---|
| 870 | |
---|
| 871 | # Returns contents in directory. |
---|
| 872 | sub _directory_contents { |
---|
| 873 | my $path = shift(); |
---|
| 874 | if (!-d $path) { |
---|
| 875 | return; |
---|
| 876 | } |
---|
| 877 | opendir(my $handle, $path) || croak("$path: cannot open directory ($!)\n"); |
---|
| 878 | my @items = grep {$_ ne q{.} && $_ ne q{..}} readdir($handle); |
---|
| 879 | closedir($handle); |
---|
| 880 | map {File::Spec->catfile($path . $_)} @items; |
---|
| 881 | } |
---|
| 882 | |
---|
| 883 | # ------------------------------------------------------------------------------ |
---|
| 884 | |
---|
| 885 | 1; |
---|
| 886 | |
---|
| 887 | __END__ |
---|