Subversion Repositories DevTools

Rev

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

########################################################################
# Copyright (C) 1998-2013 Vix Technology, 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 $ScmWho                 = "";
our $ScmDebug               = 0;
our $ScmVerbose             = 0;

our $CurrentYear            = "";
our $CurrentTime            = "";
our $CurrentDate            = "";
our $All;

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

#-------------------------------------------------------------------------------
# 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 ) = @_;

#.. Import diagnostic levels
#
    $::ScmWho = $who;
    $::ScmDebug = $ENV{ "GBE_DEBUG" }       if ( exists( $ENV{ "GBE_DEBUG" } ) );
    $::ScmVerbose = $ENV{ "GBE_VERBOSE" }   if ( exists( $ENV{ "GBE_VERBOSE" } ) );

    ErrorConfig( 'name'    => $::ScmWho,
                 'debug'   => $::ScmDebug,
                 'verbose' => $::ScmVerbose );

    SystemConfig ('UseShell' => 1 );

    Debug( "Common ($::ScmWho)" );
    Debug( "version:   $::CommonVersion" );
    Debug( "Debug:     $::ScmDebug" );
    Debug( "Verbose:   $::ScmVerbose" );

    #
    #   Init the FileUtils package
    #   Sets various globals used throughout the program
    #
    InitFileUtils();

    #
    #   Init global time variables
    #
    $::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        : 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 );
}


#   ExpandPlatforms ---
#       Expand a platform list applying aliases.
#..

sub ExpandPlatforms
{
    our( @_expandarg ) = @_;
    our( @_expandresult, $_expandnest );

    @_expandresult = ();
    $_expandnest = 0;

    Debug3( "ExpandPlatforms(@_)" );

    sub ExpandPlatform
    {
        sub ExpandAlias
        {
            my( $key ) = @_;

            if (%::BUILDALIAS)         # buildlib.pl
            {
                return ExpandPlatform( split( ' ', $::BUILDALIAS{ $key } ) )
                    if ( $key !~ /^--/ && $::BUILDALIAS{ $key } );
            }
            else
            {
                return $key                     # argument || no aliases
                    if ( $key =~ /^--/ || !(%::ScmBuildAliases) );

                return ExpandPlatform( split( ' ', $::ScmBuildAliases{ $key } ) )
                    if ( $::ScmBuildAliases{ $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.  "/mypath/myfile".       then Lower case
#               3.  "/mypath/MYFILE".       and finally upper case.
#
#           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/myfile".
#               3.  "/dir1/cfg/MYFILE".
#               4.  "/dir2/cfg/Myfile".
#               5.  "/dir2/cfg/myfile".
#               6.  "/dir2/cfg/MYFILE".
#
#           Upon being not found displays the message
#
#               "stuff (cfg/Myfile) not found".
#
sub Exists
{
    my( $path, $name, $msg, @paths ) = @_;
    my( $dir, $file, $lc_name, $uc_name );

    Debug2 "Searching for $path/$name (" . ($msg || '') . ")";
    Debug2 " using @paths" if ( @paths );

    if ( scalar( @paths ) > 0 ) {
        $dir = pop( @paths );                   # search path
    } else {
        $dir = "";                              # path is absolute
    }

    $lc_name = lc( $name );
    $uc_name = uc( $name );
    do {
        $dir .= "/"                             # directory delimitor
            if ( $dir ne "" );

        $file = "$dir$path/$name";              # quoted, can be mixed case

        Debug2 " -> $file";

        if ( ! -f $file )
        {
            $file = "$dir$path/$lc_name";       # lower case
            if ( ! -f $file )
            {
                $file = "$dir$path/$uc_name";   # upper case
                $file = ""                      # NO MATCH
                    if ( ! -f $file );
            }
        }
    } while ( ($file eq "") &&
                ($dir ne "") && ($dir = pop( @paths )) );

    #
    #   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 " == $file";

    Debug( "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]");
}

#-------------------------------------------------------------------------------
# Function        : ToolsetFile
#
# Description     : Maintain a datastructure of files that are created
#                   by the makefile creation process.
#
#                   Used to simplify the clobber process
#
#                   Maintains a in-memory datastructure
#
# Inputs          : fileList        - Files to add to the list
#
# Returns         : Nothing
#
our %GBE_TOOLSETFiles;
sub ToolsetFile
{
    my (@fileList) = @_;
    Verbose2 ("ToolsetFile:", @fileList);
    Error ("Internal: ToolsetFile. ScmRoot or ScmInterface not defined")
        unless ( defined $::ScmRoot && defined $::ScmInterface );

    my $dataDir = "$::ScmRoot/$::ScmInterface";
    my $dataFile = "$dataDir/GbeFiles.cfg";

    Error ("Internal: ToolsetFile. Cwd not defined")
        unless ( defined $::Cwd );


    #
    #   Initial read of data structure
    #   Only read on first call
    #
    unless ( %GBE_TOOLSETFiles )
    {
        if ( -f  $dataFile )
        {
            require ( $dataFile );
        }

        # Capture the package root directory
        $GBE_TOOLSETFiles{Root} = AbsPath($::ScmRoot)
            unless defined $GBE_TOOLSETFiles{Root};
    }

    #
    # Save to disk if
    #   Target directory exists - creation may be delayed
    #   We have added entries
    #
    if ( @fileList )
    {
        #
        #   Add files
        #       Need to be full paths
        #
        $GBE_TOOLSETFiles{Files}{RelPath(AbsPath($_), $GBE_TOOLSETFiles{Root} )} = 1 foreach ( @fileList );

        #
        #   Save file
        #   Simply rewrite the file - if the terget directory exists
        #   Its creation may be after we have started accumulating files
        #
        if ( -d $dataDir  ) {
            my $fh = ConfigurationFile::New( $dataFile );
            $fh->Header( "ToolsetFile", "Toolset Files" );
            $fh->Dump( [\%GBE_TOOLSETFiles], [qw(*GBE_TOOLSETFiles)] );
            $fh->Close();
        }
    }
}

1;  #success