Subversion Repositories DevTools

#! 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;