source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/Dest.pm @ 5134

Last change on this file since 5134 was 5129, checked in by abarral, 5 months ago

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