Rev 6511 | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### 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( ReadBuildConfiggetPlatformPartsgetPackagePathsgetPackageListgetToolInfotestToolInfogetAliasesisGenericBuild);@EXPORT_OK = qw( $InterfaceVersion$ScmBuildMachType$ScmInterfaceVersion$ScmBuildName$ScmBuildPackage$ScmBuildVersion$ScmBuildBaseVersion$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;our %ScmBuildMatrix;#-------------------------------------------------------------------------------# 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 : True - data has been loaded#sub ReadBuildConfig{$interface = shift;$platform = shift;my $no_test;my $no_error;foreach ( @_ ){if ( m/^--NoTest/i ) {$no_test = 1;} elsif ( m/^--NoError/i ) {$no_error = 1;} else {Warning ("ReadBuildConfig, Unknown option: $_");}}unless ($interface) {WarnError (!$no_error, "ReadBuildConfig. Interface directory is not defined");return 0;}Debug("BuildConfig::Reading config, $interface");my $cfgfile = "$interface/build.cfg";unless ( -f $cfgfile ) {WarnError (!$no_error, "JATS internal file missing. Rebuild required","BuildConfig: Cannot find file: $cfgfile" ) ;return 0;}## 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) ){WarnError (!$no_error, "JATS interface files are not compatible with this version of JATS","Rebuild required.","Current Interface Version: $ScmInterfaceVersion","JATS Interface Version : $InterfaceVersion" );return 0;}## 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" );}}return 1;}#-------------------------------------------------------------------------------# Function : isGenericBuild## Description : Determine if this is a 'GENERIC' build# ie: can be built on ANY build machine## Inputs :## Returns : TRUE - Is generic#sub isGenericBuild{return exists $ScmBuildMatrix{'GENERIC'} ? 1 : 0;}#-------------------------------------------------------------------------------# 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 toolError ("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;