Subversion Repositories DevTools

# -*- mode: perl; tabs: 8; indent-width: 4; -*-

#

# Module name   : common.pl

# Module type   : Makefile system

#

# 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]");

}

1;  #success