source: LMDZ5/branches/IPSLCM6.0.11/tools/fcm/lib/Fcm/ReposBranch.pm

#!/usr/bin/perl
# ------------------------------------------------------------------------------
# NAME
#   Fcm::ReposBranch
#
# DESCRIPTION
#   This class contains methods for gathering information for a repository
#   branch. It currently supports Subversion repository and local user
#   directory.
#
# COPYRIGHT
#   (C) Crown copyright Met Office. All rights reserved.
#   For further details please refer to the file COPYRIGHT.txt
#   which you should have received as part of this distribution.
# ------------------------------------------------------------------------------

package Fcm::ReposBranch;

# Standard pragma
use warnings;
use strict;

# Standard modules
use Carp;
use File::Spec;
use File::Spec::Functions;
use File::Basename;
use File::Find;

# FCM component modules
use Fcm::Util;
use Fcm::Timer;

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $branch = Fcm::ReposBranch->new (
#     CONFIG  => $config,
#     PACKAGE => $package,
#     TAG     => $tag,
#     REPOS   => $repos,
#     VERSION => $version,
#     TYPE    => $type,
#   );
#
# DESCRIPTION
#   This method constructs a new instance of the Fcm::ReposBranch class.
#
# ARGUMENTS
#   CONFIG  - reference to a Fcm::Config instance
#   PACKAGE - package name of which this repository belongs
#   TAG     - "tag" name of this branch of the repository
#   REPOS   - repository branch root URL/path
#   VERSION - this version of the branch is used by the extract
#   TYPE    - repository type
# ------------------------------------------------------------------------------

sub new {
  my $this  = shift;
  my %args  = @_;
  my $class = ref $this || $this;

  my $self = {
    CONFIG  => (exists $args{CONFIG}  ? $args{CONFIG}  : &main::cfg),
    PACKAGE => (exists $args{PACKAGE} ? $args{PACKAGE} : undef),
    TAG     => (exists $args{TAG}     ? $args{TAG}     : undef),
    REPOS   => (exists $args{REPOS}   ? $args{REPOS}   : undef),
    VERSION => (exists $args{VERSION} ? $args{VERSION} : undef),
    TYPE    => (exists $args{TYPE}    ? $args{TYPE}    : undef),

    # Use this list of directories in this branch
    DIRS    => {},

    # Expand this list of directories in this branch
    EXPDIRS => {},
  };

  bless $self, $class;
  return $self;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $config = $branch->config;
#
# DESCRIPTION
#   This method returns a reference to the Fcm::Config instance.
# ------------------------------------------------------------------------------

sub config {
  my $self = shift;

  return $self->{CONFIG};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $package = $branch->package;
#   $branch->package ($package);
#
# DESCRIPTION
#   This method returns the package name of this repository branch. If an
#   argument is specified, the name is set to the value of the argument.
# ------------------------------------------------------------------------------

sub package {
  my $self = shift;

  if (@_) {
    $self->{PACKAGE} = shift;
  }

  return $self->{PACKAGE};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $tag = $branch->tag;
#   $branch->tag ($tag);
#
# DESCRIPTION
#   This method returns the tag name of this repository branch. If an
#   argument is specified, the name is set to the value of the argument.
# ------------------------------------------------------------------------------

sub tag {
  my $self = shift;

  if (@_) {
    $self->{TAG} = shift;
  }

  return $self->{TAG};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $repos = $branch->repos;
#   $branch->repos ($repos);
#
# DESCRIPTION
#   This method returns the URL/path name of this repository branch. If an
#   argument is specified, the URL/path is set to the value of the argument.
# ------------------------------------------------------------------------------

sub repos {
  my $self = shift;

  if (@_) {
    $self->{REPOS} = shift;
  }

  return $self->{REPOS};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $version= $branch->version;
#   $branch->version ($version);
#
# DESCRIPTION
#   This method returns the revision number of this repository branch. If an
#   argument is specified, the revision is set to the value of the argument.
# ------------------------------------------------------------------------------

sub version {
  my $self = shift;

  if (@_) {
    $self->{VERSION} = shift;
  }

  return $self->{VERSION};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $type = $branch->type;
#   $branch->type ($type);
#
# DESCRIPTION
#   This method returns the repository type ("svn" or "user"). If an
#   argument is specified, the type is set to the value of the argument.
# ------------------------------------------------------------------------------

sub type {
  my $self = shift;

  if (@_) {
    $self->{TYPE} = shift;
  }

  return $self->{TYPE};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $dir = $branch->dir ($name);
#   $branch->dir ($name, $dir);
#
# DESCRIPTION
#   This method returns the path to the source directory with sub-package name
#   $name. If $dir is specified, the path is set to its value.
# ------------------------------------------------------------------------------

sub dir {
  my $self = shift;
  my $name = shift;

  if (@_) {
    $self->{DIRS}{$name} = $_[0];
  }

  if (exists $self->{DIRS}{$name}) {
    return $self->{DIRS}{$name};

  } else {
    return undef;
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   %dirs = $branch->dirs;
#
# DESCRIPTION
#   This method returns a hash containing the source directories of this
#   repository. The keys of the hash are the sub-package names, and the values
#   of the hash are the URL/path to the source directories.
# ------------------------------------------------------------------------------

sub dirs {
  my $self = shift;

  return %{ $self->{DIRS} };
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $dir = $branch->expdir ($name);
#   $branch->expdir ($name, $dir);
#
# DESCRIPTION
#   This method returns the path to the expandable source directory with
#   sub-package name $name. If $dir is specified, the path is set to its
#   value.
# ------------------------------------------------------------------------------

sub expdir {
  my $self = shift;
  my $name = shift;

  if (@_) {
    $self->{EXPDIRS}{$name} = $_[0];
  }

  if (exists $self->{EXPDIRS}{$name}) {
    return $self->{EXPDIRS}{$name};

  } else {
    return undef;
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   %dirs = $branch->expdirs;
#
# DESCRIPTION
#   This method returns a hash containing the expandable source directories of
#   this repository. The keys of the hash are the sub-package names, and the
#   values of the hash are the URL/path to the expandable source directories.
# ------------------------------------------------------------------------------

sub expdirs {
  my $self = shift;

  return %{ $self->{EXPDIRS} };
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $branch->expand_version_tag;
#
# DESCRIPTION
#   This method expands the VERSION of the current repository branch to a
#   revision number.
# ------------------------------------------------------------------------------

sub expand_version_tag {
  my $self = shift;

  if ($self->type eq 'svn') {
    # Expand revision keyword
    my $rev = expand_rev_keyword (
      REV  => $self->version,
      URL  => $self->repos,
      HEAD => 1,
    );

    # Find out whether the specified revision is current or not
    if (uc ($self->version) ne 'HEAD' and $self->config->verbose > 1) {
      # Get last commit revision
      my $lc_rev = expand_rev_keyword (
        REV => 'HEAD',
        URL => $self->repos,
      );

      # Print information if used rev is less than the last commit rev
      print 'Info: using rev ', $rev, ' of ', $self->repos,
            ', last commit rev is ', $lc_rev, ".\n"
        if $rev < $lc_rev;
    }

    $self->version ($rev) if $rev ne $self->version;

  } elsif ($self->type eq 'user') {
    return;

  } else {
    e_report $self->repos, ': repository type "', $self->type,
             '" not supported.';
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $branch->expand_path;
#
# DESCRIPTION
#   This method expands the relative path names of sub-directories to full
#   path names. It returns 1 on success.
# ------------------------------------------------------------------------------

sub expand_path {
  my $self = shift;

  my $separator = $self->{CONFIG}->setting (qw/MISC DIR_SEPARATOR/);

  if ($self->type eq 'svn') {
    # SVN repository
    # Do nothing unless there is a declared repository for this branch
    return unless $self->{REPOS};

    # Remove trailing /
    $self->{REPOS} =~ s/$separator+$//;

    # Consider all declared (expandable) sub-directories
    for my $name (qw/DIRS EXPDIRS/) {
      for my $dir (keys %{ $self->{$name} }) {
        # Do nothing if declared sub-directory is quoted as a full URL
        next if &is_url ($self->{$name}{$dir});

        # Expand sub-directory to full URL
        $self->{$name}{$dir} = $self->{REPOS} . (
          $self->{$name}{$dir} ? ($separator . $self->{$name}{$dir}) : ''
        );
      }
    }
    # Note: "catfile" cannot be used in the above statement because it has
    #       the tendency of removing a slash from double slashes.

  } elsif ($self->type eq 'user') {
    # Local user directories

    # Expand leading ~ for all declared (expandable) sub-directories
    for my $name (qw/DIRS EXPDIRS/) {
      for my $dir (keys %{ $self->{$name} }) {
        $self->{$name}{$dir} = expand_tilde $self->{$name}{$dir};
      }
    }

    # A top directory for the source is declared
    if ($self->{REPOS}) {
      # Expand leading ~ for the top directory
      $self->{REPOS} = expand_tilde $self->{REPOS};

      # Get the root directory of the file system
      my $rootdir = File::Spec->rootdir ();

      # Expand top directory to absolute path, if necessary
      $self->{REPOS} = File::Spec->rel2abs ($self->{REPOS})
        if $self->{REPOS} !~ m/^$rootdir/;

      # Remove trailing /
      $self->{REPOS} =~ s/$separator+$//;

      # Consider all declared (expandable) sub-directories
      for my $name (qw/DIRS EXPDIRS/) {
        for my $dir (keys %{ $self->{$name} }) {
          # Do nothing if declared sub-directory is quoted as a full path
          next if $self->{$name}{$dir} =~ m#^$rootdir#;

          # Expand sub-directory to full path
          $self->{$name}{$dir} = $self->{$name}{$dir}
                               ? catfile ($self->{REPOS}, $self->{$name}{$dir})
                               : $self->{REPOS};
        }
      }
    }

  } else {
    e_report $self->repos, ': repository type "', $self->type,
             '" not supported.';
  }

  return 1;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $branch->expand_all;
#
# DESCRIPTION
#   This method searches the expandable source directories recursively for
#   source directories containing regular files. These sub-directories are
#   then added to the source directory list. The method returns total number
#   of sub-directories to be extracted from the current repository.
# ------------------------------------------------------------------------------

sub expand_all {
  my $self = shift;

  my %dirs = ();

  # Directory separator for SVN repository
  my $separator = $self->{CONFIG}->setting (qw/MISC DIR_SEPARATOR/);

  if ($self->type eq 'user') {
    for my $rootname (keys %{ $self->{EXPDIRS} }) {
      my %subdirs = find_srcdir $self->{EXPDIRS}{$rootname}, $rootname, '::';

      for my $key (keys %subdirs) {
        $dirs{$key} = $subdirs{$key};
      }
    }

  } elsif  ($self->type eq 'svn') {
    for my $rootname (keys %{ $self->{EXPDIRS} }) {
      # Execute the "svn ls -R" command
      my @lines   = &run_command (
        [qw/svn ls -R/, $self->{EXPDIRS}{$rootname} . '@' . $self->{VERSION}],
        METHOD => 'qx', TIME => $self->config->verbose > 2,
      );

      # Get list of sub-directories containing source files
      for my $line (@lines) {
        chomp $line;
        next if $line =~ /$separator$/;

        my $dir = dirname $line;

        my @pck = split /::/, $rootname;
        push @pck, (File::Spec->splitdir ($dir)) unless $dir eq '.';
        my $pck = join '::', @pck;

        my $val = $self->{EXPDIRS}{$rootname};
        $val   .= $separator . $dir unless $dir eq '.';

        $dirs{$pck} = $val;
      }
    }

  } else {
    e_report $self->repos, ': repository type "', $self->type,
             '" not supported.';
  }

  for my $key (keys %dirs) {
    $self->{DIRS}{$key} = $dirs{$key};
  }

  return scalar keys %dirs;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $branch->add_base_dirs ($base);
#
# DESCRIPTION
#   Add a list of source directories to the current branch based on the set
#   provided by $base, which must be a reference to a Fcm::ReposBranch
#   instance. It returns the total number of used sub-directories in the
#   current repositories.
# ------------------------------------------------------------------------------

sub add_base_dirs {
  my $self = shift;
  my $base = shift;

  my %base_dirs = $base->dirs;

  for my $key (keys %base_dirs) {
    # Remove repository root from base directories
    if ($base_dirs{$key} eq $base->repos) {
      $base_dirs{$key} = '';

    } else {
      $base_dirs{$key} = substr $base_dirs{$key}, length ($base->repos) + 1;
    }

    # Append base directories to current repository root
    $self->dir ($key, $base_dirs{$key}); 
  }

  # Expand relative path names of sub-directories
  $self->expand_path;

  return scalar keys %{ $self->{DIRS} };
  
}

# ------------------------------------------------------------------------------

1;

__END__