New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Dest.pm in branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/EXTERNAL/fcm/lib/Fcm – NEMO

source: branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/EXTERNAL/fcm/lib/Fcm/Dest.pm @ 5500

Last change on this file since 5500 was 5500, checked in by dancopsey, 9 years ago

Removed SVN keywords.

File size: 25.9 KB
Line 
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# ------------------------------------------------------------------------------
14use warnings;
15use strict;
16
17package Fcm::Dest;
18use base qw{Fcm::Base};
19
20use Carp             qw{croak}                          ;
21use Cwd              qw{cwd}                            ;
22use Fcm::CfgLine                                        ;
23use Fcm::Timer       qw{timestamp_command}              ;
24use Fcm::Util        qw{run_command touch_file w_report};
25use File::Basename   qw{basename dirname}               ;
26use File::Find       qw{find}                           ;
27use File::Path       qw{mkpath rmtree}                  ;
28use File::Spec                                          ;
29use Sys::Hostname    qw{hostname}                       ;
30use Text::ParseWords qw{shellwords}                     ;
31
32# Useful variables
33# ------------------------------------------------------------------------------
34# List of configuration files
35our @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
41our @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
48our @lockfiles = (
49  'bldlock',    # the build lock file
50  'extlock',    # the extract lock file
51);
52
53# List of misc files
54our @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
60our @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
66our @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
75our @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
84our @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"
92our @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.
98my %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
130my %PROP_HOOK_OF = (
131  'inherit' => \&_reset_inherit,
132  'rootdir' => \&_reset_rootdir,
133);
134
135# Mirror implementations
136my %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
150sub 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
174sub 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
191while (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.
211sub remote_shell {
212  my $self = shift();
213  $self->rsh_mkdir_rsh(@_);
214}
215
216# Resets properties associated with root directory.
217sub _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.
225sub _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
246for 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
319for 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
353sub 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
402sub 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
430sub 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
478sub 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
523sub 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
572sub 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
602sub 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
620sub 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
650sub 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
680sub _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
725sub _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
765sub 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
792sub 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
837sub 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.
872sub _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
8851;
886
887__END__
Note: See TracBrowser for help on using the repository browser.