Subversion Repositories DevTools

########################################################################

# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.

#

# Module name   : jats.sh

# Module type   : Makefile system

# Compiler(s)   : n/a

# Environment(s): jats build system

#

# Description   : Provide access to information from the build.pl file as parsed

#                 by JATS. This is more complete than the parser in the

#                 "BuildFile.pm"

#

#                 The purpose of this module is to provide an interface

#                 between (essentially) internal data structures and user

#                 scripts that need to access the data. These are primarily

#                 deployment scripts.

#

#                 The 'All' tag is used for backward compatabilty. It simply

#                 exports all the known data structures. NOT to be used by new

#                 code.

#

#

#

# Interface     : ReadBuildConfig           - Initialise module

#                 getPlatformParts          - Get a list of Platform parts

#                 

#                 PackageEntry - Internal class

#                   getUnifiedName

#                   getBase

#                   getName

#                   getVersion

#                   getType

#                   getDir

#                   getLibDirs

#                   getIncDirs

#

#......................................................................#

require 5.006_001;

use strict;

use warnings;

#===============================================================================

package ReadBuildConfig;

use JatsError;

use JatsMakeInfo qw(:basic);

use FileUtils;

# automatically export what we need into namespace of caller.

use Exporter();

our (@ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK);

@ISA         = qw(Exporter);

@EXPORT      = qw(  ReadBuildConfig

                    getPlatformParts

                    getPackagePaths

                    getPackageList

                    getToolInfo

                    testToolInfo

                    getAliases

                );

@EXPORT_OK =  qw(   $InterfaceVersion

                    $ScmBuildMachType

                    $ScmInterfaceVersion

                    $ScmBuildName

                    $ScmBuildPackage

                    $ScmBuildVersion

                    $ScmBuildProject

                    $ScmBuildVersionFull

                    $ScmBuildPreviousVersion

                    $ScmSrcDir

                    $ScmLocal

                    $ScmDeploymentPatch

                    $ScmBuildSrc

                    $ScmExpert

                    $ScmAll

                    $ScmNoBuild

                    $ScmBuildUuid

                    %ScmBuildAliases

                    %ScmBuildProducts

                    %ScmBuildPlatforms

                    %ScmBuildMatrix

                    %ScmBuildPkgRules

                    @BUILDPLATFORMS

                    @DEFBUILDPLATFORMS

                    @BUILDTOOLSPATH

                    %BUILDPLATFORM_PARTS

                    %BUILDINFO

                    %BUILD_KNOWNFILES

                );

%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);

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

#   Global variables

#

my $interface;

my $platform;

#

#   The $InterfaceVersion value is manually maintained

#   The integer part should be changed to indicate a incompatible change

#   to the JATS files created within the interface directory

#

#   $InterfaceVersion is treated as a float. The fractional part can be

#   used to indicate minor changes to the file format.

#

our $InterfaceVersion       = "2.0";            # Change will issue error message

#

#   The following varaibles are "read" in from the build.cfg file

#   In order to access simply access we need to declare them

#

our %BUILDINFO;

our %BUILDPLATFORM_PARTS;

our $ScmInterfaceVersion;

our %ScmBuildPkgRules;

our $ScmBuildMachType;

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

# Function        : ReadBuildConfig

#

# Description     : Read in the build config information

#                   Read in build.cfg

#

# Inputs          : $interface              - Path to the interface directory

#                   $platform               - Platform being processed

#

# Returns         : Nothing

#

sub ReadBuildConfig

{

    $interface = shift;

    $platform = shift;

    my $no_test;

    foreach  ( @_ )

    {

        if ( m/^--NoTest/i ) {

            $no_test = 1;

        } else {

            Warning ("ReadBuildConfig, Unknown option: $_");

        }

    }

    Debug("BuildConfig::Reading config, $interface");

    my $cfgfile = "$interface/build.cfg";

    Error ("JATS internal file missing. Rebuild required",

           "BuildConfig: Cannot find file: $cfgfile" ) unless ( -f $cfgfile );

    #

    #   Include the build.cfg data

    #

    require ( $cfgfile );

    #

    #   Ensure that the version of the interface files can be consumed

    #   The $ScmInterfaceVersion is a written copy of $InterfaceVersion

    #

    #   Allow build.cfg files that do not have a ScmInterfaceVersion

    #   Assume that these are at version 1.0.

    #

    $ScmInterfaceVersion = '1.0' unless ( $ScmInterfaceVersion );

    Debug ("ReadBuildConfig: Version: $ScmInterfaceVersion, Need: $InterfaceVersion");

    if ( int($ScmInterfaceVersion) != int($InterfaceVersion)  )

    {

        Error ("JATS interface files are not compatible with this version of JATS",

               "Rebuild required.",

               "Current Interface Version: $ScmInterfaceVersion",

               "JATS Interface Version   : $InterfaceVersion" );

    }

    #

    #   Ensure that this config file is designed for this machine type

    #   At make-time this test may not be valid. It should have been

    #   validated before make-time.

    #

    TestMachType ($ScmBuildMachType, "build.cfg") unless $no_test;

    #

    #   Remove some unused data

    #   Reduces the size of Makefile.cfg. Speeds up writting

    #

    if ( $platform )

    {

        for (keys %::ScmBuildPlatforms)

        {

            next if ($_ eq $platform );

            delete ($::BUILDPLATFORM_PARTS{$_} );

            delete ($::BUILDINFO{$_} );

            delete ($::ScmBuildPkgRules{$_} );

        }

    }

    #   dump

    #

    Debug( "Aliases:" );

    if ( ! (%::ScmBuildAliases) ) {

        Debug( "  undefined" );

    } else {

        foreach my $key (keys %::ScmBuildAliases) {

            my( @value ) = split( ' ', $::ScmBuildAliases{ $key } );

            Debug( " $key\t= @value" );

        }

    }

    Debug( "Products:" );

    if ( ! (%::ScmBuildProducts) ) {

        Debug( "  undefined" );

    } else {

        foreach my $key (keys %::ScmBuildProducts) {

            my( @value ) = split( ',', $::ScmBuildProducts{ $key } );

            Debug( " $key\t= @value" );

        }

    }

    Debug( "Platforms:" );

    if ( ! (%::ScmBuildPlatforms) ) {

        Debug( "  undefined" );

    } else {

        foreach my $key (keys %::ScmBuildPlatforms) {

            my( @args ) = split( /$;/, $::ScmBuildPlatforms{ $key } );

            Debug( " $key\t= @args" );

        }

    }

}

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

# Function        : getAliases 

#

# Description     : Return a list of aliases for the current platform

#

# Inputs          : 

#

# Returns         : A list of aliases

#

sub getAliases

{

    Error ("BuildConfig:getAliases. Not initialised") unless ( $platform );

    #

    #   Determine the aliases for this target

    #       The alias list includes the actual target too

    #

    my @AliasList;

    push @AliasList, $platform;

    if ( exists( $BUILDINFO{$platform}{'ALIAS'} ))

    {

        push @AliasList, $BUILDINFO{$platform}{'ALIAS'};

    }

    if ( exists( $BUILDINFO{$platform}{'USERALIAS'} ))

    {

        push @AliasList, @{$BUILDINFO{$platform}{'USERALIAS'}};

    }

    return @AliasList;

}

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

# Function        : getPlatformParts

#

# Description     : return a list of platform parts

#

# Inputs          : None

#

# Returns         : A list of platform parts to search in the interface

#                   directory, local directory or other

#

sub getPlatformParts

{

    Error ("BuildConfig. Not initialised") unless ( $platform );

    return @{$BUILDINFO{$platform}{PARTS}};

}

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

# Function        : getPackagePaths

#

# Description     : Return a list of all packages

#                   LinkPkgarchive packages will be provided as is

#                   BuildPkgArchive packages will be provided as a single

#                   reference to the interface directory

#

# Inputs          : Options

#                       --Interface=xxxx            Path to the interface dir

#                                                   If provided, then the path

#                                                   will be used for the first

#                                                   BuildPkgArchive

#                       --All                       All paths

#                       --Tools                     All Tools Paths

#                       --Gbe                       All Gbe paths

#

# Returns         : An array of paths

#

sub getPackagePaths

{

    Error ("BuildConfig. Not initialised") unless ( $platform );

    my $interface;

    my $all;

    my $need;

    my @result;

    #

    #   Parse Options

    #

    foreach ( @_ )

    {

        if ( m~^--Interface=(.+)~ ) {

            $interface = $1;

        } elsif ( m~^--All~ ) {

            $all = 1;

        } elsif ( m~^--Tools~ ) {

            $need = 'TOOLDIRS';

        } elsif ( m~^--Gbe~ ) {

            $need = 'CFGDIR';

        } else {

            Error ("BuildConfig. Unknown Option: $_");

        }

    }

    #

    #   Locate required entries

    #

    for my $entry (@{$ScmBuildPkgRules{$platform} })

    {

        #

        #   Do we need this entry

        #   Select tools and gbe entries

        #

        my @subdirs = '/';

        if ( $need )

        {

            next unless ( exists ($entry->{$need} ) );

            my $subdir = $entry->{$need};

            if ( ref($subdir) eq 'ARRAY' ) {

                @subdirs = @{$subdir};

            } else {

                @subdirs = $subdir;

            }

        }

        #

        #   Skip the Pseudo INTERFACE package if we are processing all packages

        #   Skip BuildPkgArchives if we aren't processing all

        #

        next if ( ($entry->{'TYPE'} eq 'interface') && $all );

        next if ( ($entry->{'TYPE'} eq 'build') && !$all );

        #

        #   Select appropriate root

        #       Use provided interface path - not too sure why

        #       Should be able to simplify this

        #

        my $dir = $entry->{'ROOT'};

        $dir = $interface if ( $entry->{'TYPE'} eq 'interface' );

        foreach my $subdir ( @subdirs )

        {

            my $dir = $entry->{'ROOT'} . $subdir;

            $dir =~ s~/+~/~g;

            $dir =~ s~/+$~~g;

            push @result, $dir;

        }

    }

    return @result;

}

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

# Function        : getPackageList

#

# Description     : Returns a list of package entries

#                   Only real use of the returned values is to iterate over it

#                   and pass the values into other functions within this

#                   class.

#

# Inputs          : Nothing

#

# Returns         : A list of refs to package data

#

sub getPackageList

{

    Error ("BuildConfig. Not initialised") unless ( $platform );

    my @result;

    foreach ( @ {$ScmBuildPkgRules{$platform} } )

    {

#        my %self;

#        $self{DATA} = $_;

        push @result, bless $_, "PackageEntry";

    }

    return ( @result );

}

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

# Function        : testToolInfo 

#

# Description     : Test to see if suitable toolInfo exists

#                   May be used if the need for the toolInfo is optional

#

# Inputs          : $toolname       - Tool to locate

#                   $error          - True: Error on not found

#

# Returns         : undefined       - No tool located

#                   refToToolEntry  - Used internally

#

sub testToolInfo

{

    my ($toolname, $error) = @_;

    my $toolroot;

    my $toolinfo;

    my $pentry;

    my @searchPath;

    foreach my $entry ( getPackageList() )

    {

        my $path = $entry->getBase(2);

        Verbose("getToolInfo: $path");

        #   Generic

        $toolinfo = catdir($path, 'gbe', 'INFO', 'info.' . $toolname . '.generic');

        push @searchPath, $toolinfo;

        if ( -f $toolinfo )

        {

            $toolroot = $path;

            $pentry = $entry;

            last;

        }

        #   Machine specific

        $toolinfo = catdir($path, 'gbe', 'INFO', 'info.' . $toolname . '.'. $ENV{GBE_HOSTMACH});

        push @searchPath, $toolinfo;

        if ( -f $toolinfo )

        {

            $toolroot = $path;

            $pentry = $entry;

            last;

        }

    }

    unless (defined $toolroot)

    {

        #   Didn't find the required tool

        Error ("Cannot find required tool in any package: $toolname", "Search Path:", @searchPath) if ($error );

        return undef ;

    }

    #

    #   Return user info

    #

    return ($pentry, $toolroot, $toolinfo) if (wantarray);

    return $pentry;

}

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

# Function        : getToolInfo 

#

# Description     : Locate and load the tool information for the named tool

#

# Inputs          : $toolname           - tool to locate

#                   ...                 - Optional,Names of fields to expect in the package

#                                         If any of the required fields ar missing an error

#                                         will be reported

#

# Returns         : A hash of Tool info

#

sub getToolInfo

{

    my ($toolname, @fnames) = @_;

    my %data;

    #

    #   Check existence and get essential information

    #       Will not return if not found

    #

    my ($pentry, $toolroot, $toolinfo) = testToolInfo ($toolname, 1);

    open (my $DATA, '<', $toolinfo ) || Error("Cannot open tool info file. $!", "File: $toolinfo");

    while ( <$DATA> )

    {

        $_ =~ s~\s+$~~;

        next if ( m~^#~ );

        next if length($_) < 1;

        m~(.*?)\s*=\s*(.*)~;

        $data{$1} = $2;

    }

    close $DATA;

    $data{PKGBASE} = $toolroot;

    $data{PKGENTRY} = $pentry;

#DebugDumpData("Data", \%data);

    #

    #   Ensure that the required fields are in the info file

    #   These will be a mix of mandatory and user fields

    #

    my @missing;

    for my $fname ('TOOLNAME','TOOLROOT', @fnames)

    {

        next if defined $data{$fname};

        push @missing, $fname;

    }

    if (@missing)

    {

        Error("Tool Package '$toolname' is missing required fields:", @missing);

    }

    return \%data;

}

################################################################################

#   PackageEntry

################################################################################

#

#   A class to access the data embedded into $ScmBuildPkgRules

#   Use a class interface to abstract the data

#

package PackageEntry;

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

# Function        : dump

#

# Description     : Diagnostic Dump of the body of the package entry

#

# Inputs          : None

#

# Returns         : None

#

sub dump

{

    my $self = shift;

    ::DebugDumpData("PackageEntry", $self );

}

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

# Function        : getUnifiedName 

#

# Description     : Return a Package Name based on PackageName and project suffix

#                   Package Name is cleaned up a bit

#                       Replace non-alphanumenrics with a '_'

#                       Converted to upper case 

#

# Inputs          : $self

#                   $prefix         - Optional Prefix 

#                   $suffix         - Optional Suffix 

#

# Returns         : String

#

sub getUnifiedName

{

    my ($self,$prefix,$suffix) = @_;

    my $name = $prefix || '';

    $name .= $self->{'DNAME'};

    $name .= '_' . $self->{'DPROJ'} if $self->{'DPROJ'};

    $name .= $suffix || '';

    $name =~ s~\W~_~g; 

    $name =~ s~-~_~g; 

    $name =~ tr~_~_~s;

    $name = uc $name;

    return $name;

}

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

# Function        : getBase

#

# Description     : Determine the base directory of the package

#

# Inputs          : $self                   - Class Ref

#                   $type                   - 0: Empty

#                                             1: abs dpkg_archive

#                                             2: May be in the interface

#                                             3: Interface, LinkPkgs

#

# Returns         : As above

#

sub getBase

{

    my ($self, $type ) = @_;

    ::Error ("Internal: PackageEntry::getBase called without 'type' argument") unless defined $type;

    if ( $type == 1 ) {

        return $self->{ROOT};

    } elsif ( $type == 2 ) {

        if ( $self->{'TYPE'} eq 'build' ) {

            return $interface;

        } else {

            return $self->{ROOT};

        }

    } elsif ( $type == 3 ) {

        return if ( $self->{'TYPE'} eq 'build' );

        return $self->{ROOT};

    } else  {

        return '';

    }

}

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

# Function        : getXxxx 

#

# Description     : Various getters

#

# Inputs          : $self - Reference to the class 

#

# Returns         : Value

#

sub getName

{

    my ($self) = @_;

    return $self->{NAME};

}

sub getVersion

{

    my ($self) = @_;

    return $self->{VERSION};

}

sub getType

{

    my ($self) = @_;

    return $self->{TYPE};

}

#

#   Returns the location of the package.

#       This will be a ref into the package store

#       Used only if access to dpkg_archive is needed

#       Only useful if TYPE is build or link

#

sub getDir

{

    my ($self) = @_;

    return $self->{ROOT};

}

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

# Function        : getLibDirs

#

# Description     : Return an array of library directories

#

# Inputs          : $self                   - Class ref

#                   $type                   - 0 : Relative to base of the package

#                                             1 : abs to the dpkg_archive package

#                                             2 : abs to the interface

#                                             3 : Interface, LinkPkgs

#

# Returns         : An array

#

sub getLibDirs

{

    my ($self, $type ) = @_;

    my @result;

    my $prefix = getBase( $self, $type );

    foreach ( @{$self->{PLIBDIRS}} )

    {

        push @result, $prefix . $_;

    }

    return @result;

}

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

# Function        : getIncDirs

#

# Description     : Return an array of include directories

#

# Inputs          : $self                   - Class ref

#                   $type                   - 0 : Relative to base of the package

#                                             1 : abs to the dpkg_archive package

#                                             2 : abs to the interface

#                                             3: Interface, LinkPkgs

#

# Returns         : An array

#

sub getIncDirs

{

    my ($self, $type ) = @_;

    my @result;

    my $prefix = getBase( $self, $type );

    foreach ( @{$self->{PINCDIRS}} )

    {

        push @result, $prefix . $_;

    }

    return @result;

}

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

1;