Subversion Repositories DevTools

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

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

#

# Module name   : JatsSignatureBuilder.pm

# Module type   : JATS Utility

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : Generate a PAckage signature

#

#

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

require 5.008_002;

use strict;

use warnings;

package JatsSignatureBuilder;

use JatsError;

use FileUtils;

use JatsVersionUtils;

use JatsEnv;

use JatsSystem;

use ArrayHashUtils;

use BuildName;

use Digest::SHA::PurePerl qw(sha1);

use IPC::Open3;

use File::Path;

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

# Function        : GeneratePackageSignature 

#

# Description     : Generate a package signature

#

# Inputs          : $pkgBase        - Path to the package's build file

#                   $outPath        - Base of path to create signature files 

#

# Returns         : The package signature

#

sub GeneratePackageSignature

{

    my ($pkgBase, $outPath) = @_;

    Error ("No directory specified") unless $pkgBase;

    Error ("Not a directory: $pkgBase") unless -d $pkgBase;

    my $parsedInfo = JatsParser::processBuild ($pkgBase);

    #DebugDumpData("GeneratePackageSignature::parsedInfo", $parsedInfo);

    Error ('BuildName not found') unless exists $parsedInfo->{BuildName};

    #   Generate a package signature from the parsed data

    #

    return BuildSignature($parsedInfo, $outPath, \&getPackageSignature);

}

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

# Function        : getPackageSignature 

#

# Description     : Helper routine 

#                   Given a package name and package version determine the package

#                   signature.

#                   

#                   Can used predetermined data or perform a package repo scan

#                   

#                   This version assumes that we are buildign within a jats sandbox

#                   Each packages signature file Package.sig is stored in the packages

#                   interface directory (at the moment).

#                   

#                   Process:

#                       Locate the packages interface directory - we have a link file to it

#                       Read in the PAckage Signature file

#

# Inputs          : $pname      - Package Name

#                   $pversion   - Package Version

#                   $mode       - Optional. true -> do not error if not found

#

# Returns         : The package signature. Undefined if the package canot be found

#                    

sub getPackageSignature

{

    my ($pname, $pversion, $mode ) = @_;

    my $prj = '';

    my $pkg;

    my $version;

    my $pkgSig;

    #

    #   Try the 'OLD' mode first

    #   This is a temp KLUDGE

    #

    $pkgSig = getPackageSignatureOld($pname, $pversion, 1);

    return $pkgSig if $pkgSig;

    # 

    #   We are in a sandbox and expect to find package signatures in the sandbox directory

    #

    my ($pn, $pv, $ps ) = SplitPackage ($pname, $pversion );

    $version = 'sandbox';

    $prj = '.' . $ps if ( $ps ); 

    $version .= $prj;

    my $signatureDir =  CatPaths($::GBE_DPKG_SBOX, $pname);

    my $signatureFile = CatPaths($signatureDir, 'sandbox' . $prj .'.Package.sig');

    if ( -f $signatureFile)

    {

        $pkgSig = TagFileRead($signatureFile);

        Error("Package signature invalid for $pname/$version", "Signature: $pkgSig") 

            if((length($pkgSig) != 40) && $pkgSig !~ m~^MSG:~) ;

    }

    else

    {

        Warning ("Package signature not found for $pname/$version", "You must 'build' the package before using it") unless $mode;

        $pkgSig = 'MSG: No signature for ' . $pname . '_' . $pversion;

    }

    return $pkgSig;

}

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

# Function        : getPackageSignatureOld  

#

# Description     : Get PAckage Signature using the old mechanism

#                   The package siganture is in the packages interface directory

#

# Inputs          : as for getPackageSignature 

#

# Returns         : 

#

sub getPackageSignatureOld

{

    my ($pname, $pversion, $mode ) = @_;

    my $prj = '';

    my $pkg;

    my $version;

    my $pkgSig;

    # 

    #   We are in a sandbox and expect to find a interface/Package.sig file

    #   This will allow us to locate the package in the package store

    #   

    #   If there is no interface/Package.sig, then the user must build (not make)

    #   the package in the sandbox.

    #   

    #   ie: the interface/Package.sig file allows us to use the package from package cache

    #       or indicates that the user has not yet built the package

    #       

    #   First locate the packages interface directory

    #   We have a nice link from the sandbox to assist in this

    #

    my ($pn, $pv, $ps ) = SplitPackage ($pname, $pversion );

    $version = 'sandbox';

    $prj = '.' . $ps if ( $ps ); 

    $version .= $prj;

    my $ifaceDir = CatPaths($::GBE_SANDBOX, 'sandbox_dpkg_archive', $pname, $version . '.int');

    $ifaceDir = TagFileRead($ifaceDir);

    $ifaceDir =~ s~\\~/~g;

    $ifaceDir =~ s~GBE_SANDBOX/~$::GBE_SANDBOX/~;

    my $pkgSigFile = CatPaths( $ifaceDir, 'Package.sig');

    if ( -f $pkgSigFile)

    {

#Debug0("$pname, $pversion --> $pkgSigFile");

        $pkgSig = TagFileRead($pkgSigFile);

        Error("Package signature invalid for $pname/$version", "Signature: $pkgSig") 

            if((length($pkgSig) != 40) && $pkgSig !~ m~^MSG:~) ;

    }

    else

    {

        Error("Package signature not found for $pname/$version", "You must 'build' the package before using it") unless $mode;

    }

    return $pkgSig;

}

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

# Function        : BuildSignature 

#

# Description     : Generate a package 'signature' for this package

#               

#                   The signature is used to bypass the entire Make processing in a sandbox

#                   If we can find a matching package in the package store then we don't 

#                   need to 'make' this package.

#

#                   There are two scenarios:

#                       In a GIT enabled sandbox

#                       Without GIT

#                       

#                   In a GIT enabled sandbox the signature allows the use of a pre-built 

#                   package - even if the package has been built on a different branch.

#                   

#                       The signature includes:

#                           The name of this package

#                           The GIT sha1 of the directory trees that contain this package

#                           The package signatures of all dependent packages

#                           

#                   In a Non-GIT enabled sandbox the package signature will be set such that

#                   the package will never be found in the package store and the package MUST

#                   be built within the sandbox.

#                   

#                   The hard part is determing the directory trees that contains this package

#                   Ideally this is a single dir-tree, but this cannot be enforced.

#                   

#                   Source directories have been gathered during makefile generation

#                   

#                   This suits most cases, but there are a few where the user needs

#                   to give JATS a hint. Use the AsdSrcDir directive to extend

#                   the signature paths to directories not under the build.pl

#                   or any makefile included by the build.pl

#                   

#                   The generated file will be held in the sandbox directory.

#                   

#

#                       

# Inputs          : $parsedInfo         - Ref to the packages JatsParser info

#                   $outPath            - Base of path to create signature files 

#                   $getPkgSignature    - Ref a function to locate the packages signature 

#

# Returns         : The package signature

#

sub BuildSignature

{

    my ($parsedInfo, $outPath, $getPkgSignature) = (@_);

    my %sigExcludeDirs;

    my %sigExcludeFiles;

    my $BuildSignatureSha1;

    my $BuildSignature;

    my @sigList;

    my $sigText;

    Message("Generate NEW Package Signature");

    #

    #   Determine the saved locations for the output files

    #

    mkpath ( $outPath ) unless -d $outPath;

    my $signatureFile = CatPaths($outPath, 'Package.sig');

    my $sigDebugFile  = CatPaths($outPath, 'Package.dsig');

    #

    #   Determine if this is a GIT enabled sandbox build

    #   Need a .git directory or file in the root of the sandbox

    #

    my $gitEnabled;

    if ($::GBE_SANDBOX && -e CatPaths ($::GBE_SANDBOX, '.git') ) {

        $gitEnabled = 1;

    }

    #

    #   Start generating the signature

    #       Include the package Name, Version and Project

    #

    $BuildSignatureSha1 = Digest::SHA::PurePerl->new;

    $sigText = "PKGNAME: " . join (' ', @{$parsedInfo->{BuildName}} );

    $BuildSignatureSha1->add( $sigText );

    push @sigList, $sigText . ": " . $BuildSignatureSha1->clone->hexdigest;

    #

    #   Include the signature of ALL dependent packages

    #   Ie: The package signature is a function of the source and its dependents

    #   Assume that we are starting with a sorted list

    #

    foreach my $tag ( @{$parsedInfo->{PkgList}} )

    {

        my ($pname, $pversion) = split ($;, $tag);

        my $pkgSig = $getPkgSignature->($pname, $pversion);

        $BuildSignatureSha1->add("PKGSIGNATURE: $pkgSig");

        push @sigList, sprintf("PKGSIGNATURE: [%s %s] %s: %s", $pname, $pversion, $pkgSig , $BuildSignatureSha1->clone->hexdigest);

    }

    if ($gitEnabled)

    {

        #

        #   Include the sha1 of all 'git' tree items that form the complete source image

        #   Warn user if not all components are version controlled

        #

        my @relDirList = @{$parsedInfo->{DirList}}; 

        my @cmdList = map { 'HEAD:' . $_ . '/'  } @relDirList;

        Debug3(" GIT CMD: " . "git rev-parse", @cmdList );

#DebugDumpData("parsedInfo",$parsedInfo);

        #

        #   Generate a 'nice' array of display paths used

        #   The display path will be used simply to report the location in the debug of the package signature

        #   The display path is relative to the base of the sandbox

        #

        my @absDirList = map { RelPath(FullPath( $_ ),$::GBE_SANDBOX) } @relDirList;

        #

        #   Callback function to process the output of the Git parse

        #   Expect one line for each HEAD: item

        #

        my $index = 0;

        my @notControlled;

        my $callback = sub {

            my ($cdata, $gitShar) = @_;

            $gitShar =~ s~\s+$~~;

            Debug3(" GIT OUT: " . $gitShar  );

            if ($gitShar =~ m~^HEAD:(.*)~) {

                push @notControlled, $1;

                $gitShar = 'MSG: Not version controlled';

            }

            $BuildSignatureSha1->add($gitShar);

            push @sigList, "PKGSRC: $absDirList[$index++]: $gitShar: " . $BuildSignatureSha1->clone->hexdigest;

            return 0;

        };

        my $rv = GitCmd('rev-parse', @cmdList, { process => $callback } );

        Debug2("GitCmd Result: $rv");

        $BuildSignature =  $BuildSignatureSha1->hexdigest;

        if (@notControlled) {

            Warning('The following paths are not version controlled:', @notControlled);

        }

    }

    else

    {

        $BuildSignature = 'MSG: Sandbox is not git enabled';

    }

    Message("Signature: $BuildSignature");

    push @sigList, "Signature: $BuildSignature";

    FileCreate( $signatureFile, $BuildSignature );

    FileCreate( $sigDebugFile, @sigList );

Debug0("sigDebugFile: $sigDebugFile");

    return $BuildSignature;

}

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

# Function        : GitCmd

#

# Description     : Run a Git Command and capture/process the output

#

#                   Based on JatsSvnCore:SvnCmd

#

# Inputs          : Command

#                   Command arguments

#                   Last argument may be a hash of options.

#                       nosavedata  - Don't save the data

#                       process     - Callback function

#                       printdata   - Print data

#                       error       - Error Message

#                                     Used as first line of an Error call

#

# Returns         : non-zero on errors detected

#

sub GitCmd

{

    my $self;           # Local storage

    Debug ("GitCmd");

    #

    #   Locate essential tools

    #

    our $GBE_SVN_PATH;

    EnvImportOptional('GBE_GIT_PATH', '');

    Debug ("GBE_GIT_PATH", $::GBE_GIT_PATH);

    my $stdmux = LocateProgInPath ( 'stdmux');

    my $git    = LocateProgInPath ( 'git', '--All', '--Path=' . $::GBE_GIT_PATH );

    #

    #   Extract arguments and options

    #   If last argument is a hash, then its a hash of options

    #

    my $opt;

    $opt = pop @_

        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));

    $self->{PRINTDATA} = $opt->{'printdata'} if ( exists $opt->{'printdata'} );

    Verbose2 "GitCmd $git @_";

    #

    # Useful debugging

    #

    # $self->{LAST_CMD} = [$svn, @_];

    #

    #   Reset command output data

    #

    $self->{ERROR_LIST} = [];

    $self->{RESULT_LIST} = [];

#    $self->{LAST_CMD} = \@_;

    #

    #   Make use of a wrapper program to mux the STDERR and STDOUT into

    #   one stream (STDOUT). #   This solves a lot of problems

    #

    #   Do not use IO redirection of STDERR because as this will cause a

    #   shell (sh or cmd.exe) to be invoked and this makes it much

    #   harder to kill on all platforms.

    #

    #   Use open3 as it allows the arguments to be passed

    #   directly without escaping and without any shell in the way

    #

    local (*CHLD_OUT, *CHLD_IN);

    my $pid = open3( \*CHLD_IN, \*CHLD_OUT, '>&STDERR', $stdmux, $git, @_);

    #

    #   Looks as though we always get a PID - even if the process dies

    #   straight away or can't be found. I suspect that open3 doesn't set

    #   $! anyway. I know it doesn't set $?

    #

    Debug ("Pid: $pid");

    Error ("Can't run command: $!") unless $pid;

    #

    #   Close the input handle

    #   We don't have anything to send to this program

    #

    close(CHLD_IN);

    #

    #   Monitor the output from the utility

    #   Have used stdmux to multiplex stdout and stderr

    #

    #   Note: IO::Select doesn't work on Windows :(

    #   Note: Open3 will cause blocking unless both streams are read

    #         Can't read both streams because IO::Select doesn't work

    #

    #   Observation:

    #       svn puts errors to STDERR

    #       svn puts status to STDOUT

    #

    while (<CHLD_OUT>)

    {

        s~\s+$~~;

        tr~\\/~/~;

        Verbose3 ( "GitCmd:" . $_);

        m~^STD(...):(.+)~;

        my $data = $1 ? $2 : $_;

        next unless ( $data );

        if ( $1 && $1 eq 'ERR' )

        {

            #

            #   Process STDERR output

            #

            push @{$self->{ERROR_LIST}}, $data;

        }

        else

        {

            #

            #   Process STDOUT data

            #

            push @{$self->{RESULT_LIST}}, $data unless ($opt->{'nosavedata'});

            #

            #   If the user has specified a processing function then pass each

            #   line to the specified function.  A non-zero return will

            #   be taken as a signal to kill the command.

            #

            if ( exists ($opt->{'process'}) && $opt->{'process'}($self, $data) )

            {

                kill 9, $pid;

                sleep(1);

                last;

            }

        }

    }

    close(CHLD_OUT);

    #

    #   MUST wait for the process

    #   Under Windows if this is not done then we eventually fill up some

    #   perl-internal structure and can't spawn anymore processes.

    #

    my $rv = waitpid ( $pid, 0);

    #

    #   If an error condition was detected and the user has provided

    #   an error message, then display the error

    #

    #   This simplifies the user error processing

    #

    if ( @{$self->{ERROR_LIST}} && $opt->{'error'}  )

    {

        Error ( $opt->{'error'}, @{$self->{ERROR_LIST}} );

    }

    #

    #   Exit status has no meaning since open3 has been used

    #   This is because perl does not treat the opened process as a child

    #   Not too sure it makes any difference anyway

    #

    #

    Debug ("Useless Exit Status: $rv");

    my $result = @{$self->{ERROR_LIST}} ? 1 : 0;

    Verbose3 ("Exit Code: $result");

    return $result;

}

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

#   Internal Package

#   Primarily to hide the use of the AUTOLOAD

#       Which still doesn't behave as expected

#       Have trouble with $self in AUTOLOAD. Its not appearig as an argument.

#   

package JatsParser;

use strict;

use warnings;

my $currentClass;

our $ProjectBase;

our $ScmRoot;

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

# Function        : JatsParser::processBuild 

#

# Description     : Process the build.pl file and associated makefile.pl's

#                   A static-ish method to do all of the hard work.

#

# Inputs          : $buildPath  - Path to the build file

#

# Returns         : A few globals 

#

sub processBuild

{

    my ($baseDir) = @_;

    my @AllSubDirs;

    #

    #   Process the build.pl file

    #

    my $filename = ::CatPaths($baseDir, 'build.pl');

    ::Error ("Build file not found : $filename") unless -f $filename;

    $baseDir = ::RelPath(::FullPath ($baseDir));

    my $buildParser = newJatsParser();

    $buildParser->parseFile($baseDir , 'build.pl');

    #DebugDumpData("parser", $parser);

    #

    #   If no source subdirs where specified in the build file then insert the  default one

    #   This is the same action as perform by jats build

    #

    if ( ! defined $buildParser->{SubDirs}) {

        push @{$buildParser->{SubDirs}}, ::CatPaths($baseDir, 'src');

    }

    #

    #   If the 'common' makefile exists then parse it as well

    #

    my $commonMakefile = ::CatPaths($baseDir, 'makefile.pl');

    unless ( -f $commonMakefile) {

        $commonMakefile = undef;

    }

    #

    #   Add the build path to the list of known subdirectories

    #

    @AllSubDirs = $baseDir;

    #

    #   Process all subdirs

    #       Order is not important - in this case

    #

    my @SubDirs = @{$buildParser->{SubDirs}};

    my $parser = newJatsParser($baseDir, $commonMakefile);

    while (@SubDirs)

    {

        my $makeDir = ::CleanDirName(pop @SubDirs);

        @{$parser->{SubDirs}} = ();

        $parser->parseFile($makeDir, 'makefile.pl');

        push @SubDirs, @{$parser->{SubDirs}} if (defined $parser->{SubDirs});

        ::UniquePush (\@AllSubDirs, $makeDir);

    }

    my @AllInclude = @{$parser->{Includes}} if defined $parser->{Includes};

    #

    #   Generate a list of root directories used by the package

    #   ie: want top level directories only and not subdirectories

    #

    my @PackageDirs = generateMinDirList(@AllSubDirs, @AllInclude);

    #

    #   Generate a list of all the external packages

    #   Don't sort the list. Order may be important

    #   

    my @AllPackages = ();

    push @AllPackages, @{$buildParser->{PkgList}} if (defined $buildParser->{PkgList});

    #

    #   Prepare a structure to be returned

    #   

    my $data;

    $data->{BuildName} = $buildParser->{BuildName};

    $data->{BaseDir} = $baseDir; 

    $data->{PkgList} = \@AllPackages;

    $data->{DirList} = \@PackageDirs;

    return $data;

}

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

# Function        : generateMinDirList 

#

# Description     : Generate a list of root directories used by the package

#                   ie: want top level directories onyl and not subdirectories

#  

#

# Inputs          : A list of paths to process

#

# Returns         : A list of processed paths 

#

sub generateMinDirList

{

    #

    #   Convert all to absolute paths

    #

    my @baseList;

    foreach  (@_) {

        push @baseList, ::FullPath($_);

    }

    #   Process the complete list to remove subdirectories

    #   Process is:

    #       Sort list. Will end up with shortest directories first, thus subdirs will follow parents

    #       Insert each item into a new list iff it is not a subdir of something already in the list

    #

    my @dirList = sort {uc($a) cmp uc($b)} @baseList;

    my @newlist; 

    foreach my $newItem ( @dirList ) {

        my $match = 0;

        foreach my $item ( @newlist ) {

            if (index ($newItem, $item) == 0) {

                $match = 1;

                last;

            }

        }

        push @newlist, $newItem if (! $match);

   }

   #

   #   Convert back to relative paths

   #

   @baseList = ();

   foreach ( @newlist ) {

       push @baseList, ::RelPath($_);

   }

   return @baseList;

}

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

# Function        : AUTOLOAD

#

# Description     : Intercept and process user directives

#                   It does not attempt to distinguish between user errors and

#                   programming errors. It assumes that the program has been

#                   tested. 

#

# Inputs          : Original function arguments (captured)

#

#

our $AUTOLOAD;

sub AUTOLOAD

{

    #

    #   Don't respond to class destruction

    #

    return if our $AUTOLOAD =~ /::DESTROY$/;

    my $self = $currentClass;

    my $type = ref ($self) || ::Error("$self is not an object");

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

    my $fname = $AUTOLOAD;

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

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

    #

    #   If directive is inlined

    #   Replace it with the raw text of the directive

    #       Really only for display purposes

    #

    if ($fname eq 'If')

    {

        return $fname . '(' . join( ',', map { qq/"$_"/ } @_ ) . ')' ;

    }

    #

    #   Capture  and process some directives

    #

    my %directives = ( AddIncDir => 1, 

                       AddSrcDir => 1, 

                       AddDir => 1, 

                       AddLibDir => 1,

                       LinkPkgArchive => 2, 

                       BuildPkgArchive => 2,

                       BuildName => 3,

                       SetProjectBase  => 4,

                       SubDir => 5,

                       BuildSubDir => 5,

                       );

    if ($directives{$fname})

    {

#        ::Debug0 ("Directive: $fname( $args );", "File: $filename, Line: $line, Mode: $directives{$fname}" );

        #   AddIncDir

        #   AddSrcDir

        #   AddLibDir

        #   AddDir

        #       Directives that specify directories that extend paths

        #

        if ($directives{$fname} == 1)

        {

            for (my $ii = 1; $ii < scalar @_; $ii++)

            {

                my $arg = $_[$ii];

                next if ( $arg =~ m~^--~);

#::Debug0("Processing: $arg");

#::DebugDumpData("Self", $self);

                #

                #   Skip if the path looks like it conatins keywords

                #   interface and local

                #   

                if ($arg =~ m~/interface/~ || $arg =~ m~/local/~ ) {

                    $arg = '.'

                }

                my $dirtyPath = $arg;

                $dirtyPath = join( '/', $self->{baseDir}, $arg) unless ($arg =~ m~^/~ || $arg =~ m~^\w:~) ;

#::Debug0("DirtyPath: $dirtyPath");

                my $path =  ::CleanPath($dirtyPath );

#::Debug0("CleanPath: $path");

                ::UniquePush (\@{$self->{Includes}}, $path);

                ::Error ("Included directory does not exist: $path") unless -d $path;

            }

        }

        #

        #   LinkPkgArchive

        #   BuildPkgArchive

        #       Directives that define external packages

        #

        if ($directives{$fname} == 2) {

            push @{$self->{PkgList}}, join($;, @_);

        }

        #

        #   BuildName

        #       Directive that specifies the Build Name

        #       Format into name, version, suffix

        #   

        if ($directives{$fname} == 3) {

            my $build_info = BuildName::parseBuildName( @_ );

            $build_info->{BUILDNAME_PROJECT}  = $build_info->{BUILDNAME_PROJECT} ? '.' . $build_info->{BUILDNAME_PROJECT} : '';

            my @data = ($build_info->{BUILDNAME_PACKAGE}, $build_info->{BUILDNAME_VERSION}, $build_info->{BUILDNAME_PROJECT}); 

            $self->{BuildName} = \@data;

        }

        #

        #   SetProjectBase

        #       Handle ProjectBase variable

        #       Only handle a subset as I want to deprecate this

        #       Handle ONLY one arg

        #       Must be either : --Up=nn, or a string ( ../.. );

        #

        if ($directives{$fname} == 4) {

            if (scalar @_ > 1 ) {

               :: Error ("Multiple arguments to SetProjectBase not supported");

            }

            my $dirString = $_[0];

            if ($dirString =~ m~--Up=(\d+)~) {

                my $count = $1;

                $dirString = '/..' x $count;

            }

            my $newProjectBase = $self->{ProjectBase} . $dirString;

            $newProjectBase = ::CleanPath($newProjectBase);

#::Debug0 ("SetProjectBase:" . $newProjectBase);

            no strict;

            no warnings 'all';

            $ProjectBase =  $newProjectBase;

#::Debug0 ("ProjectBase: $ProjectBase");

        }

        #

        #   SubDir

        #   BuildSubDir

        #       Directives that specify subdirectories to be included in the build

        #       Assume they are relative

        #

        if ($directives{$fname} == 5) {

            foreach ( @_ ) {

                push  @{$self->{SubDirs}}, ::CatPaths($self->{baseDir}, $_ );

            }

        }

    }

}

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

# Function        : newJatsParser 

#

# Description     : New instance of a JatsParser object

#

# Inputs          : $buildBase - Root of the build 

#                   $commonFile - Common makefile to be prefixed to all

#

# Returns         : 

#

sub newJatsParser

{

    my ($buildBase, $commonFile) = @_;

    my $class = 'JatsParser';

    my $self  = {};

    bless $self, $class;

    #

    #   Init Data

    #

    $self->{baseDir} = '';

    $self->{filename} = '';

    $self->{SubDirs} = ();

    $self->{PkgList} = ();

    $self->{Includes} = ();

    $self->{ScmRoot} = ::FullPath($buildBase) if defined $buildBase ;

    $self->{ProjectBase} = $self->{ScmRoot};

    $self->{Common} = $commonFile if defined $commonFile;

    #

    #   Return class

    #

    return $self;

}

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

# Function        : parseFile 

#

# Description     : Parse a build or makefile and return data

#

# Inputs          : $baseDir      - Base directory

#                   $filename     - File to process

#

# Returns         : stuff 

#

sub parseFile

{

    my ($self, $baseDir, $filename) = @_;

    $currentClass = $self;

    $self->{baseDir} = $baseDir;

    $self->{filename} = $filename;

    $filename =  ::CatPaths($baseDir,$filename);

    ::Error("File not found: $filename") unless -f $filename;

    #

    #   Set Jats-global variables

    #       $ProjectBase

    #       $ScmRoot

    #

    no strict;

    $ProjectBase =  $self->{ProjectBase};

    $ScmRoot = ::RelPath( $self->{ScmRoot}, ::FullPath($self->{baseDir}) ) if defined( $self->{ScmRoot}); 

    local @ARGV;

    $ARGV[1] = 'Dummy';

    use strict;

    #

    #   Create the code to be processed

    #   Join the common-makefile and the user-makefile

    #       Set Line numbers and filenames

    #

    my $commonCode = "#No Common Code\n";

    $commonCode = slurpFile($self,$self->{Common}) if (exists $self->{Common});

    my $code =  slurpFile($self,$filename);

#    ::Debug0("code:\n", $commonCode . $code);

    #

    #   Evaluate the code

    #

    no strict;

    no warnings 'all';

    eval $commonCode . $code;

    if ($@) {

        ::Error('Bad eval of Code:', $@);

        ::Debug0("Code", $code);

    }

    use strict;

    use warnings;

#    ::DebugDumpData("ParsedData", $self);

}

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

# Function        : slurpFile 

#

# Description     : Read and entire (build / makefile ) into a string

#                   Clean it up a little bit

#

# Inputs          : $file   - File to process 

#

# Returns         : Entire file as a sinngle string

#

sub slurpFile

{

    my ($self, $file) = @_;

    local $/;

    open my $fh, '<', $file or ::Error("Cannot open $file. $!" );

    $/ = undef;

    my $data = <$fh>;

    close $fh;

    #

    #   Remove ugly directives

    #   Messes with line numbers

    #

    $data =~ s~^\s*require.*~_JatsRequire();~gm;

    $data =~ s~^\s*die.*~_JatsDie();~mg;

    $data =~ s~^\s*unless.*~_JatsUnless();~mg;

    $data =~ s~^\s*\$MAKELIB_PL\s+.*~_JatsDefine();~mg;

    $data =~ s~^\s*\$BUILDLIB_PL\s+.*~_JatsDefine();~mg;

    #

    #   Some old build files use some rubbish perl

    #

#    $data =~ s~^my~#my~mg;

    #

    #   Put a nice header on the file for error reporting

    #

    my $absName = ::FullPath($file);

    my $header = "#line 1 \"$absName\"\n" ;

    return $header . $data;

}

1;