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