Subversion Repositories DevTools

use File::Path;

my  $build_source_pkg       = 0;                # Flag to build source package

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

# Function        : BuildReleaseFile

# Description     : Legacy function

#                   Don't know what it was meant to do

#                   Unfortunately it is present in a lot of build.pl files

#

#                   Not well supported on all machine types

#

# Inputs          : $BuildFilename          - Root of output filename

#                   $BuildDir               - Path of subdir to tar

#

#                   Also uses the undocumented: GBE_SNAPSHOT_DIR

#

# Returns         : Does not return

#                   Once invoked this function will exit the build

#

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

# Function        : BuildSnapshot

# Description     : Legacy function

#                   Don't know what it was meant to do

#                   Unfortunately it is present in a lot of build.pl files

#

# Inputs          : None that are used

#

# Returns         : Undefined

#

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

# Function        : BuildSrcArchive

#

# Description     : Create a source snapshot of the build source

#                   Designed to provide a source image for packaging

#                   examples

#

#                   Should be platform independent

#

#                   Creates an archive file and places it into the

#                   interface directory. The archive will be packaged

#                   automatically by the build process

#

#                   Use the 'pax' utility

#                       1) Can massage the file path such that the stored

#                          directory image contains the package name and version

#

#                   Directive can be used at any time before the BuildMake

#

#                   Will handle the existence of an auto.pl file by inserting

#                   it as build.pl.

#

# Inputs          : Options

#

#

# Returns         : 

#

sub BuildSrcArchive

{

    #

    #   If we are clobbering, then there is nothing to do

    #   The generated file is placed within the interface

    #   directory and that directory will be deleted during the clobber

    #

    return if ( $Clobber );

    DataDirective("BuildSrcArchive");

    #

    #   Currently this operation is only supported of some platforms

    #   Only supported on Unix platforms

    #   Uses the 'pax' utility

    #

    unless ( LocateProgInPath ( 'pax', '--All' ) && ( $ScmHost eq "Unix" ) )

    {

        Log( "SrcPackage . Not supported" );

        return;

    }

    #

    #   Only allow one instance of the directive

    #

    Error ("Multiple BuildSrcArchive directives not supported")

        if ( $build_source_pkg );

    #

    #   Create the name of the archive

    #       Based on the package name and version

    #       Has no spaces

    #

    my $build_name = $BUILDNAME;

    $build_name =~ s~\s+~_~g;

    #

    #   Create the archive in the interface directory

    #   Don't need to clobber it as the entire interface directory

    #   will be clobbered

    #

    $build_source_pkg = $build_name;

}

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

# Function        : BuildSrcArchiveBody

#

# Description     : Function to implement the body of the BuildSrcArchive

#                   operation. Will be invoked during BuildMake

#

# Inputs          : None

#

# Returns         : 

#

sub BuildSrcArchiveBody

{

    return unless ( $build_source_pkg );

    my $archive_dir = "pkg/$BUILDNAME_PACKAGE/src";

    my $archive_file = "$build_source_pkg" . '.tar';

    Log( "SrcPackage . $archive_file.gz" );

    unlink "$archive_dir/$archive_file";

    unlink "$archive_dir/$archive_file.gz";

    mkpath($archive_dir, 0, 0775);

    #

    #   Create a list of files and top-level dirs to add to source archive

    #   Many files are ignored

    #   Should only be executed on the first 'build' thus many internal

    #   directories will not be present

    #

    my @flist;

    my $auto_pl;

    opendir (my $tp, '.' ) or Error ("Cannot read current directory");

    while ( $_ = readdir($tp) )

    {

        next if ( m/^\.$/ );

        next if ( m'^\.\.$' );

        next if ( m'^build\.log$' );

        next if ( m'\.gbe$' );

        next if ( m'^local$' );

        next if ( m'^pkg$' );

        next if ( m/^$BUILDINTERFACE$/ );

        $auto_pl = 1, next  if ( m'^auto\.pl$' );

        next if (  m'^build\.pl$' );

        next if ( m/^$build_source_pkg$/ );

        push @flist, $_;

    }

    closedir $tp;

    #

    #   If we don't have an auto.pl, then we add the build.pl file

    #   If we do have a auto.pl - it gets tricky. Its don't after the

    #   initial pax command

    #

    unless ( $auto_pl )

    {

        push @flist, 'build.pl';

    }

    #

    #   Create the command to be executed

    #   Prefix archive paths with build_name

    #

    my @command = ( 'pax', '-w', '-f', "$archive_dir/$archive_file" );

    System( '--NoShell' , @command, '-s', "~^~$build_source_pkg/~", @flist );

    #

    #   If we have an auto.pl file, then we need to add it to the archive

    #   but it needs to be called build.pl

    #

    if ( $auto_pl )

    {

        System( '--NoShell' , @command, '-a', '-s', "~^auto.pl~$build_source_pkg/build.pl~" , 'auto.pl' );

    }

    #

    #   Must now zip the file

    #   Can't zip and append at the same time

    #

    System( '--NoShell' , 'gzip', "$archive_dir/$archive_file" );

    #

    #   Display the results

    #

    System ('--NoShell', 'pax', '-z', "-f$archive_dir/$archive_file.gz")

        if (IsVerbose (1));

}

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

# Function        : BuildAccessPerms

#

#                   Legacy

#

# Inputs          : None

#

# Returns         : 

    my ($last) = @_;

    #

    #   Ensure directive is allowed

    #       $BUILDPHASE >  1     - No more directives allowed

    #       $BUILDPHASE == 1     - Allowed directive

    #

    if ( $BUILDPHASE > 1 )

    {

        my $function = (caller(1))[3];

        $function =~ s~.*::~~;

        Error ("Directive not allowed: $function","'BuildMake' must be the last directive in the build file");

    }

    $BUILDPHASE = 1;

    #

    #   Create source package

    #

    BuildSrcArchiveBody();

# Function        : LastBuildDirective

#

# Description     : No more build directives allowed

#

# Inputs          : 

#

# Returns         : 

#

sub LastBuildDirective

{

    $BUILDPHASE = 2;

}

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

    LastBuildDirective();

    #

    #   Generate some warnings that will be seen at the end of the build

    #

    Warning ("BuildSrcArchive Directive Present","Read JATS Manual for correct usage")

        if ($build_source_pkg);