Subversion Repositories DevTools

Rev

Rev 331 | Blame | Compare with Previous | Last modification | View Log | RSS feed 

#! perl
########################################################################
# Copyright ( C ) 2004 ERG Limited, All rights reserved
#
# Module name   : jats.sh
# Module type   : Makefile system
# Compiler(s)   : n/a
# Environment(s): jats
#
# Description   : Package Entry
#
#       New         Create a new package entry instance.
#
#       RuleInc     Check whether the specific 'include' path should
#                   be included within the PINCDIRS list.
#
#       RuleLib     Check whether the specific 'lib' path should
#                   be included within the PLIBDIRS list.
#
#       Cleanup     Performs any record cleanup required prior to the
#                   entry being published.
#
# Usage:
#
# Version   Who      Date        Description
#
#......................................................................#

require 5.006_001;
use strict;
use warnings;

use DescPkg;
use JatsError;


our $BUILDNAME_PACKAGE;
our $BUILDNAME_VERSION;
our $BUILDNAME_PROJECT;
our $BUILDINTERFACE;
our @BUILDTOOLS;


package PackageEntry;

our %DescPkgCache           = ();           # Hash of known packages
our %PackageDefined         = ();           # Quick defined package test
our @PackageList            = ();           # Ordered array of packages


#-------------------------------------------------------------------------------
# Function        : EmptyEntry
#
# Description     : Create an empty class element
#                   Populated with the basic items
#
# Inputs          : None
#
# Returns         : New, empty entry
#
sub EmptyEntry
{
    my ($self) = {
            PINCDIRS        => [],
            PLIBDIRS        => [],
            LIBEXAMINED     => {},
            INCEXAMINED     => {},
            TOOLDIRS        => [],
            THXDIRS         => [],
        };
    return bless $self, __PACKAGE__;
}

sub New
{
    my ($base, $name, $version, $sandbox, $type, $local) = @_;
    my $self = EmptyEntry();

    #   Load package description ...
    #
    #       If a sandbox link, parse the build.pl and retrieve the BuildName()
    #       otherwise, load the description from the 'descpkg'.
    #
    #   Note:   The results are cached within DescPkgCache
    #..
    if ( ! exists( $DescPkgCache{$base} ) )
    {
        my ($rec);
        my ($desc) = "";

        if ( $sandbox )
        {
            open (BUILDPL, "$base/build.pl") ||
                ::Error( "cannot open '$base/build.pl'" );
            while (<BUILDPL>) {
                if ( $_ =~ /^\s*BuildName\s*\(\s*[\"\'](.*)[\'\"]\s*\)/ ) {
                    $desc = $1;                 # BuildName() argument
                    ($rec->{NAME}, $rec->{VERSION}, $rec->{PROJ}) = split( ' ', $desc );
                    last;
                }
            }
            close (BUILDPL);
        }
        elsif ( -f "$base/descpkg" )
        {
            $rec = ::ReadDescpkg( "$base/descpkg", 1 );
        }
        else
        {                                       # doesn't exist
            ::Error( "Package description does not exist",
                     "Package Location: $base" )
        }

        ::Error("Cannot determine package description",
                "Package Location: $base" )
            unless ( $rec );

        ::Warning( "Package names do not match: $rec->{NAME}, $name" )
            if ( $rec->{NAME} ne $name );

        if ( $local || substr($version,0,8) eq '!current' ||
                substr($version,0,8) eq '!sandbox' )
        {                                       # display results
            my $logPrefix = "               ->";
            if ( $local ) {
                ::Log( "$logPrefix $base" );
            } elsif ($rec->{NAME} eq "") {
                ::Log( "$logPrefix n/a" );
            } else {
                ::Log( "$logPrefix $rec->{NAME} $rec->{VERSION} $rec->{PROJ}" );
            }
        }
        elsif ( $rec->{VERSION_FULL} ne $version )
        {
            ::Warning( "Package versions do not match: $name : $rec->{VERSION_FULL}, $version" );
        }

        #
        #   Extend the package information to contain suffiecient data
        #   for general use. Information will be retained to allow the
        #   user to extact specific package information
        #
        $version =~ m~(\d+\.\d+\.\d+)\.(\w+)~ ;
        my $vnum = $1 || $version;
        my $proj = $2 || '';

        $rec->{UNAME}    = $name;
        $rec->{UVERSION} = $version;
        $rec->{UVNUM}    = $vnum;
        $rec->{UPROJ}    = $proj;
        $rec->{type}     = $type;

        $PackageDefined{$name}{$proj}{$vnum} = $base;
        push @PackageList, $base;

        $DescPkgCache{$base} = $rec;                  # cache result
    }

#   Build the package entry record
#..
    my ($descpkg) = $DescPkgCache{$base};       # descpkg details

    $self->{'base'}         = $base;
    $self->{'base'}         .= "/local"
        if ( $sandbox );

    $self->{'name'}         = $name;
    $self->{'version'}      = $version;
    $self->{'sandbox'}      = $sandbox;
    $self->{'dname'}        = $descpkg->{NAME};
    $self->{'dversion'}     = $descpkg->{VERSION};
    $self->{'dproj'}        = $descpkg->{PROJ} || $descpkg->{UPROJ} || '';
    $self->{'packages'}     = $descpkg->{PACKAGES};
    $self->{'type'}         = $type;
    $self->{'cfgdir'}       = "/gbe"
        if ( $sandbox || -d $base."/gbe" );

    return $self;
}

#-------------------------------------------------------------------------------
# Function        : Interface
#
# Description     : Create a specialised 'interface' entry
#
# Inputs          : $base           - Path to the Interface directory
#
# Returns         : Ref to this class
#
sub Interface
{
    my ($base) = @_;
    my $self = EmptyEntry();

    $self->{'base'}         = $base;
    $self->{'name'}         = 'INTERFACE';
    $self->{'version'}      = '0.0.0';
    $self->{'sandbox'}      = 0;
    $self->{'dname'}        = $self->{'name'};
    $self->{'dversion'}     = $self->{'version'};
    $self->{'dproj'}        = '';
    $self->{'packages'}     = '';
    $self->{'type'}         = 'interface';
    $self->{'cfgdir'}       = '/gbe';

    return $self;

}

sub RuleInc
{
    my( $self ) = shift;
    my( $path ) = @_;
    my( $examined ) = $self->{INCEXAMINED};
    my( $list ) = $self->{PINCDIRS};

    return if ( $$examined{$path} );
    $$examined{$path} = 1;

    push @$list, $path      if ( $self->{'sandbox'} || -d $self->{'base'}.$path );
}

#
#   Examine Path to ensure that it is a directory and that it contains files
#   Simplify Lib Path searching by removing useless paths.
#
#   If there are ANY files then the directory is useful
#   If there are no files ( only subdirectories ) then the directory is not useful
#
sub isUsefulDir
{
    my ($path) = @_;

    if ( -d $path )
    {
        opendir (USEFUL, $path) or ::Error ("Cannot open $path");
        my @dirlist = readdir USEFUL;
        closedir USEFUL;

        foreach ( @dirlist )
        {
            return 1 if ( -f "$path/$_" );
        }
    }
    return 0;
}

sub RuleLib
{
    my( $self ) = shift;
    my( $path ) = @_;
    my( $examined ) = $self->{LIBEXAMINED};
    my( $list ) = $self->{PLIBDIRS};

    return if ( $$examined{$path} );
    $$examined{$path} = 1;

    push @$list, $path."D"  if ( $self->{'sandbox'} || isUsefulDir($self->{'base'}.$path."D") );
    push @$list, $path."P"  if ( $self->{'sandbox'} || isUsefulDir($self->{'base'}.$path."P") );
    push @$list, $path      if ( $self->{'sandbox'} || isUsefulDir($self->{'base'}.$path) );
}

#-------------------------------------------------------------------------------
# Function        : ExamineToolPath
#
# Description     : Given the root of a package, locate any
#                   toolset extension paths within the tree. These will be
#                   saved and later used when user tools and scripts are
#                   invoked.
#
#   Examine:
#       - tools/bin/GBE_MACHTYPE    - Hardware specfic tools
#       - tools/bin                 - Hardware independent tools - scripts
#       - tools/scripts/GBE_MACHINE - Hardware specific scripts
#       - tools/scripts             - Hardware independent scripts (too)
#
# Inputs          : self
#
# Returns         : Nothing
#
sub ExamineToolPath
{
    my( $self ) = shift;

    #
    #   Determine base dir
    #       LinkPkgArchive  : From the package
    #       BuildPkgArchive : From the interface directory
    #
    my $base_dir = $self->{'base'};
    $base_dir = "$::Cwd/$BUILDINTERFACE"
        if ( $self->{'type'} eq 'build' );

    for my $path ("/tools/bin", "/tools/scripts" )
    {
        foreach my $suffix ( "/$::GBE_MACHTYPE", "" )
        {
            my $dir = $base_dir . $path . $suffix;
            if ( isUsefulDir( $dir ) )
            {
                ::UniquePush( \@{$self->{'TOOLDIRS'}}, $dir );
                ::UniquePush( \@BUILDTOOLS, $dir );
            }
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : ExamineThxPath
#
# Description     : Given the root of a package, locate some well known
#                   packaging directories for later use.
#
#                   Examine:
#                       /thx/$platform
#                       /thx
#
# Inputs          : self
#                   platform        - Current build platform
#
# Returns         : nothing
#
sub ExamineThxPath
{
    my( $self, $platform ) = @_;

    my $dir = $self->{'base'} . '/thx';
    if ( -d $dir )
    {
        push @{$self->{'THXDIRS'}}, "/thx/$platform" if isUsefulDir( "$dir/$platform" );
        push @{$self->{'THXDIRS'}}, "/thx" if isUsefulDir( $dir );
    }
}

sub Cleanup
{
    my ($self) = shift;

    delete $self->{LIBEXAMINED};
    delete $self->{INCEXAMINED};
}


#-------------------------------------------------------------------------------
# Function        : GetBaseDir
#
# Description     : Return the base directory of a given package
#                   Simple getter function
#
# Inputs          : self
#                   path    - Optional path within package
#
# Returns         : The base directory of the package
#
sub GetBaseDir
{
    my ($self, $path) = @_;
    my $dir = $self->{'base'};
    $dir .= '/' . $path if ( $path );
    return $dir;
}


#-------------------------------------------------------------------------------
# Function        : SanityTest
#
# Description     : Examine all the packages used in the current build.pl
#                   and all the packages used to build them. Then generate
#                   warning if there are mismatches.
#
#                   All the data has been collected and stored within
#                   $DescPkgCache. This routine processes the data and
#                   constructs a data structure to locate packages with
#                   multiple versions.
#
#                   The project name is considered to be a part of the package
#                   name. Thus aaaa_11.22.33.mass is different to aaaa_11.22.33.syd
#
# Inputs          :
#
# Returns         :
#
my %package_list;

sub AddEntry
{
    my( $root, $rver, $rproj, $name, $version ) = @_;
    my $ver;
    my $proj;

    if ($version eq "!current") {
        $ver = "current";
        $proj = "";
    } else {
        $version =~ m~(.*)\.(.*?)$~;
        $ver = $1  || 'BadVer';
        $proj = $2 || 'BadProj';
    }

    ::UniquePush( \@{$package_list{"$name$;$proj"}{$ver}},  "${root}_${rver}.${rproj}");
}

sub SanityTest
{
    foreach my $package ( keys %DescPkgCache )
    {
        my $pptr = $DescPkgCache{$package};
        my $lver = $pptr->{'VERSION'};
           $lver .= '.' . $pptr->{'PROJ'} if ( $pptr->{'PROJ'} );
        AddEntry( $BUILDNAME_PACKAGE, $BUILDNAME_VERSION, $BUILDNAME_PROJECT, $pptr->{'NAME'}, $lver );


        foreach my $subpkg ( @{$pptr->{'PACKAGES'}} )
        {
            my $name = $subpkg->{name};
            my $ver = $subpkg->{version};

            AddEntry( $pptr->{'NAME'}, $pptr->{'VERSION'}, $pptr->{'PROJ'}, $name, $ver );
        }
    }

    #::DebugDumpData("XXX", \%package_list );

    #
    #   Detect and print warnings about multiple entries
    #
    my $first_found = 0;
    foreach my $pentry ( sort keys %package_list)
    {
        my @versions = keys %{$package_list{$pentry}};

        if ( $#versions > 0 )
        {
            ::Warning("Package mismatchs detected.") unless ( $first_found++ );

            my ($pname, $pproj) = split $;, $pentry ;
            foreach my $version ( @versions )
            {
                ::Warning("Package ${pname}_${version}.${pproj} used by:", @{$package_list{$pentry}{$version}});
            }
        }

    }
}

#-------------------------------------------------------------------------------
# Function        : Exists
#
# Description     : A class function to determine if a given package is known
#                   to the PackageEntry manager. Used to detect multiple package
#                   definitions.
#
#                   The test ignores package versions
#                   It is not possible to include different versions of the
#                   same package. The test ignores the project part of the
#                   version. This allows for
#                           sysbasetypes aa.bb.cc.mas and
#                           sysbasetypes xx.yy.zz.syd
#
# Inputs          : $name           - User package name
#                   $version        - User version ( with project )
#
# Returns         : True: Package exists
#

sub Exists
{
    my ($name, $version) = @_;

    $version =~ m~(\d+\.\d+\.\d+)\.(\w+)~ ;
    my $vnum = $1 || $version;
    my $proj = $2 || '';

    return exists( $PackageDefined{$name}{$proj} );
}

#-------------------------------------------------------------------------------
# Function        : GetPackageList
#
# Description     : A class function to return a list of packages
#                   The list cannot be used directory. It is really a set of
#                   keys to an internal data structure.
#
#                   The result can be used to iterate over the list of packages
#                   using other functions.
#
# Inputs          : None
#
# Returns         : An array of package tags
#                   The array is ordered by package definition order
#
sub GetPackageList
{
    return @PackageList;
}

#-------------------------------------------------------------------------------
# Function        : GetPackageData
#
# Description     : A class function to return specific data for a given package
#
# Inputs          : $tag        - An iteration tag provided by GetPackageList()
#
# Returns         : A list of
#                       Package name
#                       Package version
#                       Package type : build or link
#
sub GetPackageData
{
    my ($tag) = @_;
    my $rec = $DescPkgCache{$tag};
    return $rec->{UNAME}, $rec->{UVERSION}, $rec->{type};
}

#-------------------------------------------------------------------------------
# Function        : GetPackageVersionList
#
# Description     : A class function to return a list of package names as used
#                   to generate version strings
#
#
# Inputs          : None
#
# Returns         : An array of version list entries
#                   Each element of the form: "name (version)"
#
sub GetPackageVersionList
{
    my @list;
    foreach my $tag ( @PackageList )
    {
        my $rec = $DescPkgCache{$tag};
        push @list, "$rec->{UNAME} ($rec->{UVERSION})";
    }

    return @list;
}

### End of package: PackageEntry

1;