Subversion Repositories DevTools

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

# Copyright (C) 1998-2012 Vix Technology, All rights reserved

#

# Module name   : jats_svnrelease.pl

# Module type   : Jats Utility

# Compiler(s)   : Perl

# Environment(s): Jats

#

# Description   : A script to build a package from a SubVersion

#                 The script will:

#                   Create a workspace

#                   Checkout the files

#                   Locate the build file

#                   Build the packages

#                   Install packages

#                   Remove the view

#

#               The script can do a lot of other things too.

#

# Notes         : A lot of this code is common to jats_ccrelease.pl

#                 Will need to refactor if both are to be used

#

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

require 5.006_001;

use strict;

use warnings;

use JatsError;

use JatsSystem;

use FileUtils;

use JatsBuildFiles;

use ArrayHashUtils;

use JatsSvn;

use Pod::Usage;                             # required for help support

use Getopt::Long;

use File::Find;

use File::Copy;

use File::Path;

use Cwd;

my $VERSION = "1.0.0";                      # Update this

#

#   Options

#

my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug

my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose

my $opt_help = 0;                           # User help level

my @opt_spec;                               # Labels used as a base for the view

my $opt_dpkg = 1;                           # Transfer built package to dpkg_archive

my $opt_copy = 0;                           # Copy built package to user

my $opt_reuse = 0;                          # Re-user view if it exists

my $opt_viewname;                           # View Name

my $opt_extract = 0;                        # Just create a static view

my $opt_extract_files;                      # Just extract files to user - no view

my $opt_devModeStr;                         # Development mode string

my $opt_devMode = '';                       # Development mode (cleaned up)

my $opt_delete = 0;                         # Just delete the view. 2 to force

my @opt_build;                              # build files to use (kludge)

my $opt_test;                               # Test the build process - no copy

my $opt_cache;                              # Cache external packages

my $opt_keep = 0;                           # Keep view if successful

my $opt_beta;                               # Create beta release

my $opt_merge;                              # Merge release

my $opt_path;                               # Path for view spec

my $opt_runtests = 1;                       # Run unit tests after build

my $opt_branch;                             # Create config spec with branch

my $opt_mkbranch;                           # Create branch

my $opt_debug_build = 0;                    # Build Debug Only

my $opt_prod_build = 0;                     # Build ion Only

my $opt_view_root = $ENV{'GBE_VIEWBASE'};   # Root of the view

my $opt_prefix = 1;                         # Prefix the view tag with user-name

my $opt_tag;                                # View tag insert (build or export or user)

my $bad_label_name = 0;                     # Badly formed label

#

#   Globals - Provided by the JATS environment

#

my $USER            = $ENV{'USER'};

my $UNIX            = $ENV{'GBE_UNIX'};

my $GBE_SANDBOX     = $ENV{'GBE_SANDBOX'};

my $GBE_ABT         = $ENV{'GBE_ABT'} || '0';

my $MACHINENAME     = $ENV{'GBE_HOSTNAME'};

my $GBE_VIEWBASE    = $ENV{'GBE_VIEWBASE'};   # Root of the view

#

#   Globals

#

my $VIEWDIR_ROOT;                           # Root of the static view

my $VIEWDIR;                                # Absolute path to the view

my $VIEWPATH;                               # Path relative to clearcase

my $view_prefix     = "${USER}_";           # Default WorkSpace prefix

my $user_cwd;                               # Initial User Directory

my $error = 0;                              # Build Error Flag/Counter

my $label_count = 0;                        # Number of labels to create the view

my @label_not_pegged;                       # List of unpegged labels

my @messageText;                            # Messages to be displayed AFTER extraction

my $workSpace;                              # Path to created workspace (or extact)

my $svnSession;                             # Primary Subversion Session

my $noReleaseWs = 0;                        # Do not officially release from this

my $checkDelta = 1;                         # Check Diffs between Tag and Head

                                            #   0 - Don't do anything

                                            #   1 - Warn about diffs

                                            #   2 - Error if diffs

my $traceBack = 2;                          # Trace Back error control. As above

#

#   Data about the package-version

#

my $srcPathPkg;                             # Root of the package

my $devBranch;                              # Development Branch - within the package

my $devBranchPeg;                           # May be pegged

my $devBranchHead;                          # Revision of the HEAD of the development branch

my $tagLabel;                               # Label in 'tags'

my $tagPeg;                                 # May be pegged

my $tagLabelBranch;                         # Tagged from this branch: Discovered

my $tagLabelBranchPeg;                      # Tagged from this branch at this peg: Discovered

my $ttbType;                                # trunk, tags or branches

my $urlType;                                # 'jats' or 'url'

my $initialUrl;                             # Initial URL of target

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

# Function        : Mainline Entry Point

#

# Description     : Main entry point

#

# Inputs          : ARGV[]      - See documentation below

#

#

#   Alter some option defaults if we are creating a view within a sandbox

#

if ( $GBE_SANDBOX )

{

   $GBE_VIEWBASE = $GBE_SANDBOX;

   $opt_prefix = 0;

}

#

#   Parse the user options

#

my $result = GetOptions (

                'help:+'        => \$opt_help,                  # flag, multiple use allowed

                'manual:3'      => \$opt_help,                  # flag

                'v|verbose:+'   => \$opt_verbose,               # flag, multiple use allowed

                'label=s'       => \@opt_spec,                  # Array of build specs

                'view=s'        => \$opt_viewname,              # String

                'dpkg!'         => \$opt_dpkg,                  # [no]flag

                'copy!'         => \$opt_copy,                  # [no]flag

                'reuse!'        => \$opt_reuse,                 # [no]flag

                'extract:+'     => \$opt_extract,               # flag

                'extractfiles'  => \$opt_extract_files,         # flag

                'delete:+'      => \$opt_delete,                # flag

                'build=s'       => \@opt_build,                 # An array of build

                'test!'         => \$opt_test,                  # [no]flag

                'cache'         => \$opt_cache,                 # flag

                'keep!'         => \$opt_keep,                  # [no]flag

                'beta!'         => \$opt_beta,                  # [no]flag

                'merge'         => \$opt_merge,                 # [no]flag

                'path=s'        => \$opt_path,                  # string

                'runtests!'     => \$opt_runtests,              # [no]flag

                'branch=s'      => \$opt_branch,                # String

                'mkbranch=s'    => \$opt_mkbranch,              # String

                'prodOnly'      => \$opt_prod_build,            # flag

                'debugOnly'     => \$opt_debug_build,           # flag

                'root=s'        => \$GBE_VIEWBASE,              # string

                'prefix!'       => \$opt_prefix,                # flag

                'tag=s'         => \$opt_tag,                   # string

                'devMode=s'     => \$opt_devModeStr,            # string

                );

                #

                #   UPDATE THE DOCUMENTATION AT THE END OF THIS FILE !!!

                #

#

#   Process help and manual options

#

pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);

pod2usage(-verbose => 1)  if ($opt_help == 2 );

pod2usage(-verbose => 2)  if ($opt_help > 2 );

InitFileUtils();

#

#   Configure the error reporting process now that we have the user options

#

ErrorConfig( 'name'    => 'SVNRELEASE',

             'verbose' => $opt_verbose );

#

#   Validate user options

#   Use either -label or one command line argument

#

Error ("Cannot mix -extractfiles and -branch")

    if ( $opt_branch && $opt_extract_files );

Error ("Unexpected command line arguments present.","Cannot mix -label and command line label" )

    if ( $#opt_spec >= 0 && $#ARGV >= 0);

Error ("Cannot specify both '-mkbranch' and '-branch'")

    if ( $opt_mkbranch && $opt_branch );

push @opt_spec, @ARGV;

unless(  @opt_spec  )

{

    Error ("Need a workspace or a label. -help for options") if ( $opt_delete  && ! $opt_viewname );

    Error ("Need a Subversion Reference or URL. -help for options") unless $opt_delete;

}

#

#   Set up branching values

#       mkbranck    - Create if not exists. Error if it exists

#       branch      - Error if not exists

#

if ( $opt_mkbranch ) {

    $opt_branch = $opt_mkbranch;

    $opt_mkbranch = 1;

}

$opt_branch = SvnIsaSimpleLabel($opt_branch) if ( $opt_branch );

#   Determine extraction mode

#       Working- Default

#               Extract point on development branch were tag was taken

#               Update build files

#               Warn about files that have changed

#

#       Tag   - Extract point on development branch were tag was taken

#               Update build files

#               Error if tag is not the tip

#

#       Tip   - Extact tip of the development branch

#               Warn about files that have changed between head and tagPoint

#

#       Exact - What the user specified

#               May be a tag and thus not usable

#

if ( $opt_devModeStr )

{

    if ( $opt_devModeStr =~ m/^(Tip)|(BranchTip)$/i) {

        $opt_devMode = 'tip';

        $checkDelta = 1;

        $noReleaseWs = 1;

    } elsif ( $opt_devModeStr =~ m/^(Tag)|(TagPoint)$/i) {

        $opt_devMode = 'tag';

        $checkDelta = 2;

        $checkDelta = 1 if ( $opt_branch );

        $noReleaseWs = 0;

    } elsif ( $opt_devModeStr =~ m/^(Work)|(Working)$/i) {

        $opt_devMode = '';

        $checkDelta = 1;

        $noReleaseWs = 0;

    } elsif ( $opt_devModeStr =~ m/^Exact$/i) {

        $opt_devMode = 'exact';

        $checkDelta = 1;

        $noReleaseWs = 0;

        Error ('Cannot mix -[mk]branch and -devMode=' . $opt_devModeStr ) if ( $opt_branch );

    } elsif ( $opt_devModeStr =~ m/^escrow$/i) {

        # JATS internal use only. Not advertised

        $opt_devMode = 'exact';

        $checkDelta = 0;

        $noReleaseWs = 0;

        $traceBack = 1;

        Error ('Cannot mix -[mk]branch and -devMode=' . $opt_devModeStr ) if ( $opt_branch );

    } else {

        Error ("Unknown development mode: $opt_devModeStr");

    }

}

#

#   The buildtool works in a known environment

#

if ( $GBE_ABT )

{

    $noReleaseWs = 0;       # Can always release

    $checkDelta = 0;        # Do not care. Often expected to have changes.

    $traceBack = 2;         # Must check traceback. Validate RM data

}

#

#   Limit the user to ONE label/tag/

#   Reason: Under Subversion its not possible to 'pinch' files from another

#           package. Don't need to create a workspace with multiple labels

#

#           It was a bad practice under clearcase

#

if ( $#opt_spec >= 1 )

{

    Error ("Multiple labels not supported",

           "Use one label to describe a package" );

}

parseSubversionRef($opt_spec[0]);

Error ("INTERNAL: initialUrl not set") unless ( $initialUrl );

Error ("Cannot interprete the URL or Subversion Reference: $opt_spec[0]") unless ( $srcPathPkg  );

#

#   User has specified both debug and production

#   Then set both to 0 : ie default

#

if ( $opt_debug_build + $opt_prod_build > 1 )

{

    $opt_debug_build = 0;

    $opt_prod_build = 0;

}

#

#   User has requested test mode

#       - Don't copy

#       - Don't package

#

if ( $opt_test )

{

    $opt_dpkg = 0;

    $opt_copy = 0;

}

#

#   Determine the machine type

#

Verbose ("Machine Type: UNIX=$UNIX");

Error ("Machine Name not determined")

    unless ( $MACHINENAME );

$user_cwd = getcwd;

Error ("USER name not determined" )

    unless ( $USER );

#

#   Clean up the view root directory

#

$VIEWDIR_ROOT = Realpath($GBE_VIEWBASE) || $GBE_VIEWBASE;

Verbose ("Viewpath: $VIEWDIR_ROOT");

Error ("Cannot locate view root directory: $VIEWDIR_ROOT" ) unless (-d $VIEWDIR_ROOT);

#

#   Remove any user name from the front of the view name

#   Simplifies the deletion process as the user can provide

#   the directory name

#

$view_prefix = '' unless ( $opt_prefix );

#

#   Create a class to describe the complete SVN label

#   This will parse the label and create a number of nice elements that will

#   be used in determing the name of the workspace

#

$svnSession = NewSessionByUrl ( $initialUrl, 1 );

#DebugDumpData("New Session", $svnSession );

#

#   Test for a pegged label

#

push @label_not_pegged, $svnSession->Full

    unless ( $svnSession->Peg );

#

#   Setup user specified workspace

#   Include the user name to ensure that the view name is unique-ish

#   Keep the name as short as possible as some compilers display a fixed

#   length filename in error messages and this name is part of the path

#

#   Base the viewname on the view label. This will simplify the creation

#   of multiple views and reduce the risk of unexpected deletion

#

$opt_viewname = calcViewName();

$opt_viewname =~ s~^$view_prefix~~ if (defined($opt_viewname) && $view_prefix && $opt_delete );

#

#   Create a clearcase view to be used for the view

#

$VIEWPATH = "$view_prefix$opt_viewname";

$VIEWDIR = "$VIEWDIR_ROOT/$VIEWPATH";

$VIEWDIR =~ tr~\\/~/~s;

Verbose( "Hostname: $MACHINENAME" );

Verbose( "Viewpath: $VIEWPATH" );

Verbose( "Viewdir : $VIEWDIR" );

#

#   If the user has specified a "source path", then we must ensure that it is

#   valid. It will be used to create the WorkSpace

#

#   Ensure that the path is a defined variable. If used prepend a / to simplify

#   concatenation.

#

Verbose("Validate Source Path");

if ( $opt_path )

{

    $opt_path =~ tr~\\/~/~s;

    $opt_path =~ s~/$~~;

    $opt_path =~ s~^/~~;

    Error( "Source Path has drive specifier" ) if ( $opt_path =~ m~^[A-Za-z]\:~ );

    $opt_path = '/'.$opt_path ;

}

else

{

    $opt_path = '';

}

$workSpace = $VIEWDIR . $opt_path;

Verbose( "workSpace : $workSpace" );

#

#   Operation

#   If all we are doing is deleting the view then do it now

#   If we are going to extract stuff, then we will delay the deletion

#   as long as possible - incase we decide we can't

#

if ( $opt_delete )

{

    delete_view()

        unless ( $opt_reuse );

    exit 0;

}

#

#   Ensure that the label is present within the specified Repository

#

Verbose("Ensure Labels can be found in a Repository");

Verbose ("Testing label: ". $svnSession->Full );

$label_count++;

$svnSession->SvnValidateTarget (

                    'cmd'    => 'SvnRelease',

                    'target' => $svnSession->Full,

                    'require' => 1,

                    );

#

#   If the user did not provide a peg then examine

#   the 'tag' in the repo and determine when it was created

#   This will not work to well if the user is allowed to move the tag

#

unless ( $svnSession->Peg() )

{

    $svnSession->SvnInfo( $svnSession->Full, 'InfoRepo' );

    my $peg = $svnSession->{'InfoRepo'}{'Last Changed Rev'};

    $svnSession->{'PEG'} = '@' . $peg;

    if ( $tagLabel ) {

        $tagPeg = $peg;

    } elsif ( $devBranch ) {

        $devBranchPeg = $peg;

    }

}

#debugDumpRefInfo('Get Peg');

#

#   Trace back from the tag to the point at which it was copied

#   This should be the same as the user provided development branch

#   but it may not be the same if the user is changing the branch

#

if ( $tagLabel && $traceBack )

{

    my $btData;

    my $labelBranch = $svnSession->backTrackSvnLabel(

                            join ('@', $tagLabel, $tagPeg)

                          , 'data' => \$btData

                          , 'onlysimple' => 0,

                          , 'printdata' => 0 );

    $svnSession->{SavedBackTrack} = $btData;

    unless ( $btData->{isaBranch} )

    {

        Warning("Cannot trace package label back to a development branch");

    }

    else

    {

        Error ("INTERNAL: Cannot parse result of backTrackSvnLabel: $labelBranch")

            unless ($btData->{devBranch} =~ m~^(.*)@(\d+)$~);

        $tagLabelBranch = $1;

        $tagLabelBranchPeg = $2;

        #

        #   Verify that the Development Branch matches that provided by the user

        #

        if ( $devBranch && ($devBranch ne $tagLabelBranch) )

        {

            # If the user is creating a branch, then allow this mismatch

            #

            unless ( $opt_branch && ($devBranch =~ m~/$opt_branch$~) )

            {

                my @msgText;

                push ( @msgText,

                        "The package Tag was not taken from the development branch",

                        "Development Branch: $devBranch\@$tagPeg",

                        "Tag traced back to: $tagLabelBranch\@$tagLabelBranchPeg" );

                if ( $traceBack == 1) {

                    push @messageText, @msgText;

                } else {

                    Error ( @msgText );

                }

            }

        }

        $devBranchPeg = $tagLabelBranchPeg unless ( $devBranchPeg );

        #   Ensure that the TAG has not been modified since it was taken

        #   The extraction algorithm assumes that the tag directory is

        #   immutable.

        #

        #   The build daemon will actually modify the build file during

        #   a ripple - this is catered for.

        #

        #   If other files have been modifed then it should be an error

        #

        if ( $btData->{changeSets} > 1 )

        {

            Error ("Tag has been modified since created") if ( $GBE_ABT );

            Warning ("Tag has been modified since created");

            $noReleaseWs = 1;

        }

    }

}

#debugDumpRefInfo('BackTrack Label');

#

#   Examine the HEAD of the development branch and determine if there

#   have been any changes since the tag was taken

#

determineChangedFiles();

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

#   Create a workspace based on the tag

#   It will be back tracked to the branch that was tagged:

#       - Ripple build tags look better in version tree

#       - User can develop in the workspace as its not linked to an immutable 'tags'

#

#   So far we have:

#       $initialUrl         - Url to the version that the user specified

#       $initialUrlBranch   - Url to the branch from which the initialUrl was taken

#                             Iff based on a Tag

#       $urlDevBranchHead   - Head of the Development Branch

#

$initialUrl = substr( $initialUrl, 1 + length($srcPathPkg));

my $initialUrlBranch;

if ( $tagLabelBranch )

{

    $initialUrlBranch  = $tagLabelBranch;

    $initialUrlBranch .= '@' . $tagLabelBranchPeg;

}

my $urlDevBranchHead;

if ( $devBranch )

{

    $urlDevBranchHead  = $devBranch;

}

else

{

    $urlDevBranchHead  = $tagLabelBranch;

}

#

#   Debug information

#

if ( IsVerbose(1) ) {

    debugDumpRefInfo('Creating workspaces');

    Verbose ('------------');

    Verbose ("initialUrl       :", $initialUrl);

    Verbose ("initialUrlBranch :", $initialUrlBranch );

    Verbose ("urlDevBranchHead :", $urlDevBranchHead );

    Verbose ("opt_viewname     :", $opt_viewname );

#    DebugDumpData("svn_label", $svnSession );

}

#

#   If we are only extracting files then ...

#

if ( $opt_extract_files )

{

    Warning(@messageText );

    extract_files_from_view();

    exit (0);

}

#

#   Create a new workspace

#       This is not done if the user is reusing an existing workspace

#       AND the existing workspace exists.

#

if (! -d $VIEWDIR || ! $opt_reuse )

{

    Message( "Create the workspace" . ($GBE_SANDBOX ? " in a SANDBOX" : ''));

    my $branch;

    my $view_tag;

    my $update_tagsChanges;

    if ( $opt_devMode eq 'tip' ) {

        $view_tag =  $urlDevBranchHead;

    } elsif ( $opt_devMode eq 'exact' ) {

        $view_tag =  $initialUrl;

    } else {

        $view_tag = $initialUrlBranch || $initialUrl;

        $update_tagsChanges = 1;

    }

    Message ("Creating Workspace based on: $view_tag");

    $view_tag = $svnSession->FullPath() . '/' .$view_tag;

    Verbose("Creating Workspace:", $view_tag);

    #

    #   If a branch is required ...

    #   Two modes:

    #       mkbranch    - Ensure that the branch does not exist

    #                     Make a new one

    #       branch      - Ensure that the branch does exist

    #                     Use existing branch

    #   Ensure that the branch is NOT in the Repository

    #

    if ( $opt_branch )

    {

        $branch = $svnSession->BranchName($opt_branch, 'branches' );

        $svnSession->SvnValidateTarget (

                        'cmd'    => 'SvnRelease: Validate Branch',

                        'target' => $branch,

                        'require' =>   (! $opt_mkbranch),

                        'available' => (  $opt_mkbranch),

                        );

        #

        #   If using an existing branch, then set up the name

        #   of the source.

        #

        $view_tag = $branch if ( ! $opt_mkbranch );

    }

    #

    #   Perform delayed delete of any existign view

    #   The process has been delayed as much as possible - incase other tests

    #   fail

    #

    delete_view();

    #

    #   Create the workspace

    #

    $svnSession->SvnCo ( $view_tag, $workSpace );

    Error ("Cannot locate the created Workspace")

        unless ( -d $workSpace);

    importTagChanges()

        if ($update_tagsChanges);

    #

    #   If we need to create a branch then

    #       Copy the WS to URL

    #       Switch to new URL

    #   The bulk of the copy will be done on the server-side

    #   and not over the network. This is  good.

    #

    if ( $opt_mkbranch )

    {

        #

        #   Branch does not exist

        #   Create it be copying the base view

        #

        Message ("Creating branch: $opt_branch");

        my $branch_tag = $svnSession->SvnCopy (

                        'old' => $workSpace,

                        'new' => $branch,

                        'comment' => 'Created by Jats SvnRelease branch request',

                        'replace' => 0 );

        Verbose ("Switching to new branch: $opt_branch");

        $branch_tag = SvnPath2Url($branch_tag);

        $svnSession->SvnSwitch ($branch_tag,

                               $workSpace,

                               '--NoPrint' );

    }

    #

    #   Create a local package archive

    #   May be needed for multipackage builds and it will prevent JATS from

    #   finding any outside the view

    #

    mkdir ( $VIEWDIR . '/local_dpkg_archive')

        unless ($GBE_SANDBOX);

    #

    #   Display messages AFTER the extraction text

    #   Will ensure that the user has a chance to see them

    #

    Warning(@messageText );

}

#   Place a tag-file in the user-specified source path

#   This will be used by the build-tool to locate the 'source-path' of the

#   view, primarily for determining metrics.

#

#   Calculate where the dynamic view will be

#   This differ between UNIX/WINDOWS

#

if ( $GBE_ABT)

{

    Message("Create Build tagfile");

    TouchFile ( "$workSpace/.jats.packageroot" )

        if ( -d $workSpace )

}

#

#   Locate the JATS build files within the populated view

#

chdir ($VIEWDIR) or Error("Cannot chdir to $VIEWDIR");

Message( "Locating build files");

my $bscanner = BuildFileScanner( $VIEWDIR, 'build.pl', '--LocateAll' );

$bscanner->scan();

my @build_list = $bscanner->getInfo();

foreach my $be ( @build_list )

{

    Message(DisplayPath ("Build file: $be->{dir} Name: $be->{file}"));

}

#

#   If we are extracting the view then we are done

#   Display useful information for the user

#

if ( $opt_extract )

{

    Message  DisplayPath "View in: $VIEWDIR";

    Warning ("No build files found" )   if ( $#build_list < 0 );

    Warning( "Multiple build files found" )if ( $#build_list > 0 );

    Message ("Not all labels are pegged") if ( @label_not_pegged  );

    Message ("All labels are pegged") unless ( @label_not_pegged  );

    Message ("Badly formed label name" ) if ( $bad_label_name );

    Message ("Development Mode: $opt_devModeStr") if ( $opt_devModeStr );

    Message ("Development Sandbox") if ( $GBE_SANDBOX );

    Message ("Cannot release from this workspace") if ($noReleaseWs);

    exit 0;

}

Error ("No build files found")  if ( $#build_list < 0 );

#

#   Determine the list of builds to perform

#   Ensure that the user-requested build files are present

#

#   The user specifies the build file, via the mangled package name

#   This is package_name . project extension (daf_utils.cr)

#

if ( $#opt_build  >= 0)

{

    Verbose( "Check and locate the build files");

    @build_list = ();

    foreach my $bentry ( @opt_build )

    {

        if ($bscanner->match( $bentry) )

        {

            UniquePush (\@build_list, $bscanner->getMatchList() );

            Verbose ("Found: $bentry");

        }

        else

        {

            Error ("Cannot locate requested build files for: $bentry")

        }

    }

}

#

#   Sanity test if we will transfer the generated package to dpkg_archive

#   There are some limits

#       1) Must have built from one label

#       2) That label must be locked

#       3) Only one build file

#       4) The view must not have been reused

#       5) The view has a branch rule

#       6) Cannot release from a sandbox

#

my @elist;

push @elist, "Package built from multiple labels" unless ( $label_count == 1 );

push @elist, "Package built from an unpegged label" if ( @label_not_pegged  );

push @elist, "Package built with multiple build files" if ( scalar @build_list > 1 );

push @elist, "Package from a reused view" if ( $opt_reuse && ! $opt_beta );

push @elist, "Package from a development sandbox" if ( $GBE_SANDBOX );

push @elist, "Package from a development workspace" if ($noReleaseWs);

push @elist, "View contains a branch" if ( $opt_branch );

push @elist, "User has specified build files" if ( $#opt_build > 0 );

push @elist, "Badly formed label name" if ( $bad_label_name );

if ( @elist )

{

    Warning ("Cannot officially release the package.", @elist);

    Error ("Build terminated as it cannot be released") if ($opt_dpkg && ! $opt_beta);

}

Warning ("Beta Release") if $opt_beta;

#

#   Process each of the build files in the specified order

#

foreach my $be (@build_list)

{

    #

    #   We need to change to the build directory

    #   Moreover we need the local name of the build directory.

    #   Windows does not handle a UNC pathname to well (at all)

    #

    my $build_dir = $be->{dir};

    chdir ("$build_dir") or Error( "Cannot chdir to build directory: $build_dir");

    if ( $be->{file} =~ m/^build.pl$/ )

    {

        Message ("Using JATS: $build_dir");

        #

        #   Invoke JATS to build the package and make the package

        #

        my @build_args = qw(--expert --cache);

        push @build_args, '--cache' if $opt_cache;

        my $make_type = 'all';

        $make_type = 'all_prod'  if ( $opt_prod_build );

        $make_type = 'all_debug' if ( $opt_debug_build );

        JatsCmd('build', @build_args)               and Error("Package did not build");

        JatsCmd('make', $make_type, 'NODEPEND=1')   and Error("Package did not make");

        JatsCmd('install');

        if ( $opt_runtests )

        {

            JatsCmd('make', 'run_unit_tests')      and Error("Tests did not run correctly");

        }

    }

    else

    {

        #

        #   Ant build files

        #

        my $pname =  $be->{file};

        Message ("Using ANT: $build_dir, $pname");

        $pname =~ s~depends.xml$~.xml~;

        copy($be->{file}, "auto.xml");

        JatsCmd('-buildfile', $pname, 'ant', 'build')        and Error("Package did not build");

        JatsCmd('-buildfile', $pname, 'ant', 'make_package') and Error("Package did not make_package");

    }

}

#

#   Copy the generated packages

#       1) dpkg_archive

#       2) Users local directory

#

foreach my $be (@build_list)

{

    my $build_dir = $be->{dir};

    chdir ("$build_dir") or Error( "Cannot chdir to build directory: $build_dir");

    if ( $opt_dpkg )

    {

        Message ("Using: $build_dir");

        my @create_opts = "-o";

        push @create_opts ,"-m" if ( $opt_merge );

        JatsCmd('-here', 'create_dpkg', @create_opts, '-pname', $be->{name}, '-pversion', $be->{version}) and $error++;

    }

    if ( $opt_copy )

    {

        Message ("Copy package to $user_cwd");

        copy_directory( 'pkg', $user_cwd, '' );

    }

    #

    #   Test structure of the package

    #   Ensure that it has a descpkg file

    #   Validate the package name and version

    #   More important for ANT projects than JATS as JATS has a sanity test

    #

    if ( $opt_test )

    {

        JatsCmd('-here', 'create_dpkg', '-test', '-pname', $be->{name}, '-pversion', $be->{version}) and $error++;

    }

}

Error ("Package not transferred")

    if ( $error );

chdir ($user_cwd) or Error( "Cannot chdir to $user_cwd");

#

#   Delete the view

#

if ( ! $opt_reuse && ! $error && ! $opt_keep )

{

    delete_view();

}

else

{

    Message( "View left in: $VIEWDIR" );

}

Message ("End program");

exit 0;

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

# Function        : delete_view

#

# Description     : Delete a view

#

# Inputs          : None

#                   $VIEWDIR - path of the view

#

# Returns         :

#

sub delete_view

{

    my $cofound = 0;

    my $uuid;

    #

    #   Simple delete

    #

    if ( $opt_extract_files )

    {

        if ( -d $VIEWDIR )

        {

            Message("Remove extracted files: $VIEWDIR");

            RmDirTree( $VIEWDIR );

        }

    }

    else

    {

        #

        #   If the view physically exists then attempt to physically remove it

        #

        if ( -d $VIEWDIR )

        {

            #

            #   Determine if there are any checked out files in the view

            #

            Message("Remove the view: $VIEWDIR");

            Verbose("Look for checked out files");

            SvnRmView ('path'     => $workSpace,

                       'force'    => ($opt_delete > 1) || ($opt_extract > 1),

                       'modified' => [ 'local_dpkg_archive' ] );

        }

        Warning ("View was not deleted. Will Delete view directory")

            if ( -d $workSpace );

        RmDirTree( $VIEWDIR ) if $opt_path;

    }

    Error ("View was not deleted")

        if ( -d $VIEWDIR );

}

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

# Function        : copy_directory

#

# Description     : Copy a directory tree

#

# Inputs          : Source directory

#                   Target directory

#                   Strip

#

#                   Should be full pathnames

#

# Returns         :

#

my $copy_error;

my $copy_count;

sub copy_directory

{

    our ($src_dir, $dest_dir, $strip) = @_;

    our $slength = length ($strip);

    #

    #   Prevent File::Find from generating warnings

    #

    no warnings 'File::Find';

    #

    #   Helper routine to copy files

    #

    sub copy_file_wanted

    {

        #

        #   Do not copy directories