Subversion Repositories DevTools

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

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

#

# Module name   : common.pl

# Module type   : Makefile system

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : Some function common to build and makefile processing tools.

#

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

use strict;

use warnings;

use JatsError;

use JatsSystem;

use ConfigurationFile;

use FileUtils;

use ArrayHashUtils;

use ReadBuildConfig qw(:All);

use JatsMakeConfig;

our $CommonVersion          = "1.03";

our $CurrentYear            = "";

our $CurrentTime            = "";

our $CurrentDate            = "";

our $All;

our @BUILD_ACTIVEPLATFORMS  = ();               # Array of active platforms

our @DEFBUILDPLATFORMS = ();

our $GBE_TOOLS;

our $GBE_OPTS;

our $LegacyMode = 0;                            # Indicates either ABT or a LEGACY build

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

# Function        : CommonInit

#

# Description     : Initialisation routine for this common code

#                   The function MUST be called after the package has been

#                   loaded with a "require" statement.

#

#

# Inputs          : $who            - Name of the package using the routines

#                                     Used for error reporting

#

# Returns         : Nothing

#

sub CommonInit

{

    my( $who ) = @_;

    ErrorConfig( 'name' => $who );

    SystemConfig ('UseShell' => 1 );

    Debug( "Common ($who)" );

    Debug( "version:   $::CommonVersion" );

    Debug( "Debug:     $::ScmDebug" );

    Debug( "Verbose:   $::ScmVerbose" );

    #   Envars used by this module

    EnvImportOptional ( 'GBE_ABT' );                # optional ABT flags          

    EnvImportOptional ( 'GBE_OPTS', '' );           # optional OPTS flags

                                                    # 

    $LegacyMode = $::GBE_ABT || $::GBE_OPTS =~ m/LEGACY/i;          

    #

    #   Init the FileUtils package

    #   Sets various globals used throughout the program

    #

    InitFileUtils();

    #

    #   Init global time variables

    #

    $::ComonInitDone = 1;

    $::CurrentTime = localtime;

    my ($sec, $min, $hour, $mday, $mon, $year) = localtime();

    $::CurrentYear = 1900 + $year;

    $::CurrentDate                              # eg. 13/10/86

        = sprintf ("%02u/%02u/%02u", $mday, $mon+1, $year % 100);

}

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

# Function        : AUTOLOAD

#

# Description     : Intercept bad user directives and issue a nice error message

#                   This is a simple routine to report unknown user directives

#                   It does not attempt to distinguish between user errors and

#                   programming errors. It assumes that the program has been

#                   tested. The function simply report filename and line number

#                   of the bad directive.

#

# Inputs          : Original function arguments ( not used )

#

# Returns         : This function does not return

#

sub AUTOLOAD

{

    my $args = JatsError::ArgsToString( \@_);

    my $fname = $::AUTOLOAD;

    $fname =~ s~^\w+::~~;

    my ($package, $filename, $line) = caller;

    Error ("Directive not known or not allowed in this context: $fname",

           "Directive: $fname( $args );",

           "File: $filename, Line: $line" );

}

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

# Function        : abtWarning 

#

# Description     : User Error, Build System Warning

#                   Used to tighten up builds while retaining BuildSystem compatability

#

#                   ABT Mode is a bit more forgiving, but only for backward compatability

#                   Otherwise force users to fix the build.pl and makefile.pl files.

#

# Inputs          : $mode           - True.   Exit if Error

#                                     False.  Delay error exit. Use must use ErrorDoExit() 

#                   $msg            - Message to display

#                   @msgbits        - Other message arguments

#

# Returns         : May not return

#

sub abtWarning

{

    my ($mode, $msg, @msgbits) = @_;

    if ( $LegacyMode ) {

        Warning( $msg . ' -- ignored in ABT/LEGACY Mode',  @msgbits);

        return;

    }

    ReportError($msg, @msgbits);

    ErrorDoExit() if $mode;

}

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

# Function        : ConfigLoad

#

# Description     : Loads the global configuration details

#                   Details are held within the interface directory in "build.cfg"

#

# Inputs          : None

#

# Returns         : Nothing

#                   Will populate the global environment space with the contents

#                   of the build.cfg file. These variables may need to be access

#                   with the :: syntax ($::Variable)

#

#                   This function will remove lumps of the configuration that

#                   are not needed by the current platform simply to reduce the

#                   data retaied in other config files.

#

#

sub ConfigLoad

{

   ReadBuildConfig("$::ScmRoot/$::ScmInterface", $::ScmPlatform );

}

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

# Function        : ExpandPlatforms 

#

# Description     : Expand a user provided platform list and resolve aliases

#                   Note: Need to avoid recusion

#                         ie: Alias AAA -> BBB, CCC, AAA is allowed

#                         because alias have already been expanded

#                         

#                         Use. The SOLARIS alias expands to several alias including SOLARIS

#                              The expanded SOLARIS is actually a PLATFORM

#                              I know it sucks - backward compatability always does

#                              

#                   Alias information will come from one of two places

#

# Inputs          : A list of platforms, aliases and options

#

# Returns         : A list of platforms 

#

sub ExpandPlatforms

{

    our( @_expandarg ) = @_;

    our @_expandresult = ();

    our $_expandnest = 0;

    #

    #   Use one of

    #       BUILDALIAS - as setup by buildfile.pl

    #       ScmBuildAliases - makelib.pl and makelib.pl2 

    #

    our %_Aliases = %::ScmBuildAliases ? %::ScmBuildAliases : %::BUILDALIAS;  

    Debug3( "ExpandPlatforms(@_)" );

#    DebugTraceBack( "ExpandPlatforms(@_)" );

#    DebugDumpData("Aliases",\%_Aliases);

    sub ExpandPlatform

    {

        sub ExpandAlias

        {

            my( $key ) = @_;

            return $key                     # argument || no aliases

                if ( $key =~ /^--/ || !(%_Aliases) );

            return ExpandPlatform( split( ' ', $_Aliases{ $key } ) )

                if ( exists $_Aliases{ $key } );

            return $key;

        }

        sub ExpandPush

        {

            my( $pResult, $operator, $pPlatforms, @arguments ) = @_;

            foreach my $platform ( @$pPlatforms )

            {                                   # unfold arguments

                push( @$pResult, $operator.$platform );

                next if ( $platform =~ /^--/ );

                push( @$pResult, @arguments );

            }

        }

        Error( "ExpandPlatforms( @_expandarg ) nesting error.",

               "",

               "Check for recursive definitions within the follow directives",

               "       - BuildAlias and BuildProduct."

             ) if ( $_expandnest++ > 42 );

        my( @result, $operator, @platforms, @arguments ) = ();

        Debug3( "  +$_expandnest: @_ " );

        foreach my $arg ( @_ ) {

            if ( $arg =~ /^--/ ) {              # argument, accumulate

                push( @arguments, $arg );

            } else {                            # group, product or platform

                ExpandPush( \@result, $operator, \@platforms, @arguments );

                if ( ($operator = substr($arg, 0, 1)) eq "!" ) {

                    @platforms = ExpandAlias( substr($arg, 1) );

                } else {

                    $operator = "";

                    @platforms = ExpandAlias( $arg );

                }

                @arguments = ();

            }

        }

        ExpandPush( \@result, $operator, \@platforms, @arguments );

        $_expandnest--;

        Debug3( "  -$_expandnest: @result" );

        return @result;

    }

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

    #   Function body

    #

    foreach (@_expandarg) {                      # break out embedded args

        if ( /^--/ ) {

            push @_expandresult, $_;

        } else {

            push @_expandresult, split( ',', $_ );

        }

    }

    @_expandresult = ExpandPlatform( @_expandresult );

    Debug2( "ExpandPlatforms(@_expandarg) = @_expandresult" );

    return @_expandresult;

}

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

# Function        : Exists( $path, $name, $msg, [@paths] ) ---

#

# Description     : Case insensitive 'exists'.

#

# Inputs          :

#       $path       Represents either the absolute path of the file

#                   named 'name' in the case of @path being an empty

#                   list, or the subdir appended to each entry

#                   contained within the @paths list.

#

#       $name       The file name

#

#       $desc       Text used to describe the file upon the image

#                   not being found.

#

#       @paths      Optional list of paths to be searched.

#

# Returns         : Full path of resolved filename, otherwise nothing.

#

#   Examples:

#

#       a)  Exists( "/mypath", "Myfile", "stuff" );

#

#           Resolve the name of the file called "myfile" within the

#           directory "/mypath", using the following matching order

#           

#               1.  "/mypath/Myfile". As supplied.

#               2.  Scan "/mypath" for all files and perform a case 

#                   insensitive comparison for MYFILE.

#

#           Upon being not found displays the message

#

#               "stuff (/mypath/Myfile) not found".

#

#       b)  @paths = ( '/dir1', '/dir2' );

#           Exists( "cfg", "Myfile", "stuff", @paths );

#

#           Resolve the name of the file called "Myfile" within the

#           set of directories "/dir1/cfg/" and "/dir2/cfg/", using

#           the following matching order:

#

#               1.  "/dir1/cfg/Myfile".

#               2.  "/dir1/cfg/<Scan for MYFILE>".

#               3.  "/dir2/cfg/Myfile".

#               4.  "/dir2/cfg/<Scan for MYFILE>".

#

#           Upon being not found displays the message

#

#               "stuff (cfg/Myfile) not found".

#

my %ExistsDirCache;

sub Exists

{

    my( $path, $name, $msg, @paths ) = @_;

    my $file;

    my $ucName = uc($name);

    Debug2 "Searching for $path/$name (" . ($msg || '') . ")";

    Debug2 " using @paths" if ( @paths );

    #

    #   Convert the two call methods into a common method

    #   Convert path with empty @paths into an array of paths with an empty 'path'

    #

    unless (@paths) {

        push @paths, $path;

        $path = '';

    }

    SCANPATHS:

    foreach my $thisPath ( @paths) {

        my $curPath = $thisPath . '/' . $path . '/';

        $curPath =~ s~//$~/~;

        #

        #   Try exact file name first - should work most of the time

        #

        $file = $curPath . $name; 

        Debug2 " -> $file";

        last SCANPATHS if ( -f $file );

        #

        #   Scan all files in the directory for the first

        #   case insensitive match

        #

        $file = '';

        #

        #   Read directory and cache the results for reuse

        #

        unless (exists $ExistsDirCache{$curPath})

        {

            if (opendir my $dh, $curPath ) {

                @{$ExistsDirCache{$curPath}} = readdir $dh;

                closedir $dh;

            }

        }

        #

        #   Scan for first matching filename

        #

        foreach my $item (@{$ExistsDirCache{$curPath}}) {

            if (uc($item) eq $ucName) {

                $file = $curPath . $item;

                last SCANPATHS if ( -f $file );

                $file = '';

            }

        }

    } 

    #

    #   If the user has defined an error message and the file does not

    #   exist, then generate an error message

    #

    Error("$msg","File: $path/$name not found.")

        if ($msg && $file eq "");

    Debug2( "Exists:     = $file" );

    return $file;

}

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

#   Require( $path, $name, $msg, [@paths] ) ---

#

#   Description:

#       Case insensitive 'require', see Exists() for usage.

#

#   Returns:

#       Full path of resolved filename.

#..

sub Require

{

    my( $file );

    $file = Exists( @_ );

    require $file if ($file);

    return $file;

}

#   Require2( \@args, $path, $name, $msg, [@paths] ) ---

#       Case insensitive 'require' same as Require(), but allows the

#       argument list \@args to passed thru to the included image

#       via a localised @_.

#

#   Returns:

#       Full path of resolved filename.

#..

sub Require2

{

    my( $args ) = shift;

    my( $file, $result );

    $file = Exists( @_ );

    if (exists $::INC{$file}) {

        Error( "Included $file has already been loaded." );

    }

    unless (-f $file) {

        Error ("Can't locate the include $file");

    } else {

        local @_;                               # Include argument vector

        push @_, @$args;

        $::INC{$file} = $file;

        $result = do $file;                     # exec

    }

    if ($@) {

        $::INC{$file} = undef;

        Error ($@);

    } elsif (!$result) {

        delete $::INC{$file};

        Error ("Included $file did not return true value.");

    }

    return $file;

}

sub RequireTool

{

    my( $script, @arguments ) = @_;

    my( $file );

    Debug2( "RequireTool(@_)" );

    $file = Require( "", $script,

                "RequireTool", @::BUILDTOOLSPATH, $::GBE_TOOLS );

}

#   Trim( string ) ---

#       Trim leading/trailing whitespace

#..

sub Trim

{

    my( $str ) = @_;

    if ( $str )

    {

        $str =~ s/^\s*//g;                          # leading white space

        $str =~ s/\s*(\n|$)//;                      # trailing white space

    }

    return $str;

}

#   CommifySeries ---

#       Format the array into comma seperate list.

#..

sub CommifySeries

{

    my $sepchar = grep(/,/ => @_) ? ";" : ",";

    (@_ == 0) ? '' :

    (@_ == 1) ? $_[0] :

    (@_ == 2) ? join(" and ", @_)  :

                    join("$sepchar ", @_[0 .. ($#_-1)], "and $_[-1]");

}

1;  #success