Subversion Repositories DevTools

use File::Find;

use Digest::SHA qw(sha1);

use IPC::Open3;

our $BUILDSIGNATURE;                            # Source signature

#                   Package Signature

    my $pkgSig = 'unknown';

    #   If we are in a SandBox, then we use package signatures to locate pre-built

    #   packages.

    #

    if ($::GBE_SANDBOX)

    {

        my @ret = PackageLocateBySignature(@_);

        if ($ret[0])

        {

            return @ret;

        }

        Warning ("Package not found by signature - revert to package version")

    }

    #

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

# Function        : PackageLocateBySignature

#

# Description     : Locate a package via its signature

#                   In a monoRepo sandbox pre-build package artifacts are located

#                   via the signature of the source package. This must be generated

#                   before it can be used.

#                   

#                   At the moment we simply generate an error if the signature cannot be

#                   found. We could be clever and invoke jats to generate the required 

#                   signature.

#                   

#

# Inputs          : package name

#                   package version

#

# Returns         : path to the package

#                   local       1 - From local package repository

#                   Package Signature

#

sub PackageLocateBySignature

{

    my ($name, $uversion ) = @_;

    my $prj = '';

    my $pkg;

    my $local = 1;

    my $in_sandbox = 1;

    my $isa_cache = 0;

    my $version;

    my $pkgSig = 'unknown';

    Debug( "PackageLocateBySignature: ($name/$uversion)" );

    # 

    #   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 ($name, $uversion );

    $version = 'sandbox';

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

    $version .= $prj;

    my $ifaceDir = catdir($::GBE_SANDBOX, 'sandbox_dpkg_archive', $name, $version . '.int');

    $ifaceDir = TagFileRead($ifaceDir);

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

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

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

    return unless -f $pkgSigFile; 

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

        unless ( -f $pkgSigFile);

    $pkgSig = TagFileRead($pkgSigFile);

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

        if(length($pkgSig) != 40);

    #

    #   Look in each package archive directory

    #

    foreach my $dpkg ( split( $::ScmPathSep, $::GBE_DPKG_SBOX),

                       '--NotSandbox',

                       split( $::ScmPathSep, $::GBE_DPKG_LOCAL),

                       '--NotLocal',

                       split( $::ScmPathSep, $::GBE_DPKG_CACHE),

                       '--NotCache',

                       split( $::ScmPathSep, $::GBE_DPKG_REPLICA),

                       split( $::ScmPathSep, $::GBE_DPKG),

                       split( $::ScmPathSep, $::GBE_DPLY),

                       split( $::ScmPathSep, $::GBE_DPKG_STORE) )

    {

        #

        #   Detect various tags that have been placed in the search list

        #   to flag the end of the sandbox search and the end of the local

        #   archive search

        #

        if ( $dpkg eq '--NotSandbox' )

        {

            $in_sandbox = 0;

            next;

        }

        if ( $dpkg eq '--NotLocal' )

        {

            $local = 0;

            $isa_cache = 1;

            next;

        }

        if ( $dpkg eq '--NotCache' )

        {

            $isa_cache = 0;

            next;

        }

        $pkg = "$dpkg/$name$prj/$pkgSig";

        $pkg = "$dpkg/$name/$version.lnk"

            if ( -e "$dpkg/$name/$version.lnk" );

        #

        #   If we are scanning the sandbox archive itself, then we can will override the signature

        #   if the package has been built within the sandbox. This is indicated by the presence of a

        #   valid .lnk file.

        #   

        #       Note: The .lnk file may be present, but it won't point to anything valid until

        #             the package has been built.

        #

        if ($in_sandbox)

        {

            my $pkgLinkFile = $pkg;

            $pkgLinkFile =~ s~pkgsig$~lnk~;

            if ( -f $pkgLinkFile )

            {

                Debug( "           link found -> $pkg" );

                my $pkgLink = TagFileRead($pkgLinkFile);

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

                if ($pkgLink =~ s~^GBE_SANDBOX/~$::GBE_SANDBOX/~)

                {

                        # If the target sandbox is in the 'deploymode' then the package

                        # will not be in the expected location. It will be in a 'build/deploy'

                        # subdir. Remove the pkg/name dir to get to the root of the package

                        my @dirs = File::Spec->splitdir( $pkgLink );

                        splice(@dirs, -2);

                        my $deployBox = catdir(@dirs, 'build', 'deploy');

                        $pkgLink = $deployBox if ( -d $deployBox);

                }

                # 

                #   Handle badly formed packages - test for descpkg file

                #   Or those have the body of the code in the pkg directory

                #   

                my $pkgDescpkg = catfile( $pkgLink, 'descpkg');

                if (-d $pkgLink && -f $pkgDescpkg)

                {

                    $pkg = $pkgLink;

Debug0("============== From Sandbox: $pkgSig");

#                    $pkgFromSandbox++;

                }

            }

        }

        Debug( "           searching $pkg" );

        #   Does the package directory exist?

        #   Terminate the directory name with a "/" to detect hidden spaces

        #..

        $pkg =~ s~//~/~g;

        next unless ( -d "$pkg/" );             # exists ?

        #

        #   If the package exists within the dpkg_archive cache then mark the

        #   version as having been used. Used by cache cleanup algorithms

        #

        if ( $isa_cache  )

        {

            TouchFile ( "$pkg/used.cache", "Marks the cache copy as being used");

        }

        #

        #   Use the first suitable package found

        #..

        Debug( "           importing $pkg" );

        return $pkg, $local, $pkgSig;

    }

    #

    #   Package not found

    #   This is an error, although it can be bypassed

    #

    Error ("Required package not found: '$name/$version'" ) unless ( $NoPackageError );

    Log( "WARNING .... Package not available: '$name/$version'" );

    return;

}

#                   package Signature

        #   See if the dependencies have changed

        #   

        my $BuildpkgSig = Digest::SHA->new;

        $BuildpkgSig->add("PKGNAME: $BUILDNAME_PACKAGE $BUILDNAME_VERSION $BUILDNAME_SUFFIX");

        #

        #   Include the signature of ALL dependent packages

        #   Ie: The build fingerprint is a function of the source and its dependents

        #

        my $depTagFile = catfile($ScmInterface, 'build.bfp');

        unless (-f $depTagFile) {

            push @build_warn, "Missing: $depTagFile";

        }

        else

        {

            foreach my $tag ( PackageEntry::GetPackageList() )

            {

                my $pkgSig = PackageEntry::GetPackageSignature($tag);

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

            }

            my $depSha1 =  $BuildpkgSig->hexdigest;

            Debug2("DepSha1: $depSha1");

            unless (TagFileMatch ($depTagFile, $depSha1))

            {

                push @build_warn, "Dependency signatures have changed";

            }

        }

        #

    #   Generate package signature

    #

    BuildSignature();

    #

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

# 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 contain 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

#                       

# Inputs          : 

#

# Returns         : 

#

sub BuildSignature

{

    my %sigExcludeDirs;

    my %sigExcludeFiles;

    my $BuildSignatureSha1;

    my $signatureFile = catfile($Cwd, $BUILDINTERFACE, 'Package.sig');

    my $sigDebugFile  = catfile($Cwd, $BUILDINTERFACE, 'Package.dsig');

    my @sigList;

    #

    #   Only create the Signature file ONCE

    #   Done on first build (after a clobber)

    #

#   if (-f $signatureFile)

#   {

#       Message("Generate Package Signature - Already generated");

#       return;

#   }

    Message("Generate Package Signature");

    #

    #   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 catfile ($::GBE_SANDBOX, '.git') )

    {

        $gitEnabled = 1;

    }

    #

    #   Start generating the signature

    #       Include the package Name,Version and Project

    #

    $BuildSignatureSha1 = Digest::SHA->new;

    $BuildSignatureSha1->add("PKGNAME: $BUILDNAME_PACKAGE $BUILDNAME_VERSION $BUILDNAME_SUFFIX");

    push @sigList, "PKGNAME: $BUILDNAME_PACKAGE $BUILDNAME_VERSION $BUILDNAME_SUFFIX: " . $BuildSignatureSha1->clone->hexdigest;

    #

    #   Include the signature of ALL dependent packages

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

    #

    foreach my $tag ( PackageEntry::GetPackageList() )

    {

        my $pkgSig = PackageEntry::GetPackageSignature($tag);

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

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

    }

    #

    #   Save the signature of the package header and the dependencies

    #   This will be used for a simple test to see in we need to rebuild the build file 

    #

    my $depSha1 =  $BuildSignatureSha1->clone->hexdigest;

    Debug2("DepSha1: $depSha1");

    FileCreate( catfile($ScmInterface, 'build.bfp'), $depSha1 );

    if ($gitEnabled)

    {

        #

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

        #

        my @relDirList = map { my $relName = $_; $relName =~ s~^$::GBE_SANDBOX/~~; $relName  } ToolsetFiles::GetSubTrees(); 

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

Debug0(" GIT DIR: @relDirList" );

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

        my $index = 0;

        my $callback = sub {

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

            $line =~ s~\s+$~~;

Debug0(" GIT OUT: " . $line  );

            $BuildSignatureSha1->add($line);

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

            return 0;

        };

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

        $BUILDSIGNATURE =  $BuildSignatureSha1->hexdigest;

    }

    else

    {

        $BUILDSIGNATURE = 'Sandbox is not git enabled';

    }

    Message("Signature: $BUILDSIGNATURE");

    push @sigList, "Signature: $BUILDSIGNATURE";

    FileCreate( $signatureFile, $BUILDSIGNATURE );

    FileCreate( $sigDebugFile, @sigList );

Debug0("sigDebugFile: $sigDebugFile");

    #

    #   Create the descpkg file - to include the signature

    #

    BuildDescpkg('Internal');

}

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

# Function        : GitCmd

#

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

#

#                   Based on JatsSvnCore:GitCmd

#

# 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 read both streams becsue 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;

}

    my ($mode) = @_;

    unless ($mode && $mode eq 'Internal')

    {

    }

    push @desc, "Signature:     $BUILDSIGNATURE" if defined $BUILDSIGNATURE;