Subversion Repositories DevTools

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

# Copyright ( C ) 2008 ERG Limited, All rights reserved

#

# Module name   : jats_svnasave_build.pl

# Module type   : JATS Utility

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : Build Daemon Support Utility

#                 This utility will:

#                   +   Assume the CWD is the root-dir of a package

#                       within a versioned control view

#                   +   Determine a suitable label for the package

#                   +   Save the build file in the view

#                   +   Label the resultant view

#

# Usage:        : See POD at end of this file

#

#               jats etool  jats_save_build

#                   -infile     auto.xml/auto.pl

#                   -outfile    xxxdepends.xml/build.pl

#                   -pname      package_name

#                   -pversion   package_version

#                   -infofile   path_to_info_file

#                   -wiplabel   Existing WIP label (optional)

#

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

use strict;

use warnings;

use JatsError;

use JatsBuildFiles;

use JatsSystem;

use JatsProperties;

use Getopt::Long;

use Pod::Usage;                             # required for help support

use Cwd;

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

#   Option variables

#

my $VERSION = "2.0.0";                      # Update this

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

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

my $opt_infile  = "auto.pl";

my $opt_ofile = "build.pl";

my $opt_help = 0;

my $opt_branch_default = "AutoBuilder";

my $opt_branch;

my $opt_newbranch;

my $opt_infofile;

my $opt_pname;

my $opt_pversion;

my $opt_wiplabel;

my $opt_locate;

#

#   Globals

#

my $root_dir;

my $pkg_label;

my $tag_label;

my @error_list;

my $last_result;

my @last_results;

my $label_created;

#

#   Configuration options

#

my $result = GetOptions (

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

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

                "verbose:+"     => \$opt_verbose,           # flag

                "outfile=s"     => \$opt_ofile,             # string

                "infile=s"      => \$opt_infile,            # string

                "branch=s"      => \$opt_branch,            # string

                "newbranch"     => \$opt_newbranch,         # string

                "infofile=s"    => \$opt_infofile,          # string

                "pname=s"       => \$opt_pname,             # string

                "pversion=s"    => \$opt_pversion,          # string

                "wiplabel=s"    => \$opt_wiplabel,          # string

                "locatepkg=s"   => \$opt_locate,            # string

                #

                #   Update documentation at the end of the 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 );

#

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

#

ErrorConfig( 'name'    =>'ABTSAVE',

             'verbose' => $opt_verbose,

             'on_exit' => \&display_error_list

           );

Error ("Input and output file are the same: $opt_infile" )

    if ( $opt_infile eq $opt_ofile );

Error ("Must provide a branch when usng newbranch option")

    if ( $opt_newbranch && ! $opt_branch );

$opt_branch = $opt_branch_default

    unless ( $opt_branch );

Error ("Package Name not provided")

    unless ( $opt_pname );

Error ("Package Version not provided")

    unless ( $opt_pversion );

Warning("Path to info file not provided")

    unless ( $opt_infofile );

unlink ($opt_infofile) if $opt_infofile;

#

#   Locate the build directory and chdir to that directory

#

locate_build_directory();

#

#   Have changed to the directory with build files

#   Continue with user argument sanity check

#

Error ("Input file not found: $opt_infile" )

    unless ( -f $opt_infile );

Error ("Output file not found: $opt_ofile" )

    unless ( -f $opt_ofile );

#

#   Determine the name of the Branch to be used

#   This is based on the branch that the file is already on as ClearCase does

#   not allow multiple instances of a branch on different sub-branches

#

ClearCmd ('describe',  '-fmt', '%n', $opt_ofile);

Error ("Program Terminated") if ( @error_list );

Error ("File may not be a VOB object: $opt_ofile" ) unless ( $last_result );

my $full_name = $last_result;

$last_result =~ m~(.*)/([^/]+)$~;

my $full_path = $1;

$last_result =~ m~(.*)/([^/]+)/([^/]+)~;

my $current_branch = $2;

$last_result =~ m~@@(.*)/([^/]+)~;

my $full_branch = $1;

my $target_branch = $full_branch;

my $branch_point = "";

Error ("Cannot determine full pathname of the file: $full_name") unless ( $full_path );

Verbose2 ("FullName     : $full_name" );

Verbose2 ("FullPath     : $full_path" );

Verbose2 ("Branch       : $current_branch" );

Verbose2 ("Userb        : $opt_branch" );

Verbose2 ("FullBranch   : $full_branch" );

#

#

#   Determine the branch that the file is on

#   If it is not on the desired branch then we will need to create the branch

#

#   Ensure that the required branch exists in the current VOB

#   Need to handle some legacy branches that were created with the name AutoBuilder

#   by not creating AutoBuild/AutoBuilder.AutoBuilder branches but retaining the

#   existing AutoBuilder branch.

#

if ( $opt_newbranch )

{

    #

    #   User has asked for a new branch

    #   Place the file on /main/xxxxx

    #

    $branch_point = "-version /main/0";

    $target_branch = "/main/$opt_branch";

}

elsif ( $current_branch =~ m/^$opt_branch/ )

{

    #

    #   Current branch has the same name ( prefix) as the desired branch

    #   Use it

    #

    $opt_branch  = $current_branch;

}

else

{

    #

    #   Current branch has a different name

    #   Construct new branch name

    #

    $opt_branch = "$opt_branch.$current_branch";

    $target_branch .= "/$opt_branch";

}

Verbose2 ("TargetBranch : $target_branch" );

Verbose2 ("BranchPoint  : $branch_point" );

#

#   Determine the desired label for the package

#   May need to pick an unassigned label

#

determine_package_label();

#

#   Ensure that the specified package label exists

#   Determine if it is locked too

#   

Verbose ("Checking package label: $pkg_label");

ClearCmd ('describe', '-fmt', '%[locked]p', "lbtype:$pkg_label" );

Error ("Program Terminated") if ( @error_list );

my $was_locked = 1 unless ( $last_result =~ m~unlocked~ );

#

#   Create the desired branch if it does not already exist

#   Detected locked element and unlock it

#

Verbose ("Checking branch existence: $opt_branch");

ClearCmd ('lstype', '-short', "brtype:$opt_branch" );

if ( $last_result =~ m~\(locked\)~ )

{

    Verbose ("Unlocking branch: $opt_branch");

    ClearCmd( 'unlock', '-c', 'Unlocked by JATS ABTSAVE', "brtype:$opt_branch" );

}

elsif ( $last_result ne $opt_branch )

{

    Verbose ("Create new branch: $opt_branch");

    ClearCmd ('mkbrtype', '-c', "Contains saved versions of $opt_ofile files created by the AutoBuild system", $opt_branch );

    Error ("Program Terminated") if ( @error_list );

}

#

#   Ensure that the file is not locked

#   Unlock the file - can't do anything to a 'locked' file

#

Verbose ("Checking for locked file: $opt_ofile");

ClearCmd ('lslock', '-short', $opt_ofile );

if ( $last_result )

{

    Verbose ("Unlocking file: $opt_ofile");

    ClearCmd( 'unlock', '-c', 'Unlocked by JATS ABTSAVE', $opt_ofile );

}

if ( $current_branch ne $opt_branch )

{

    #

    #   Need to create the initial branch point, but only if one does not already

    #   exists

    #

    Verbose ("Check for existing branch: $opt_branch" );

    if ( ClearCmd( 'find', $opt_ofile, '-version', "brtype($opt_branch)", '-print' ) )

    {

        Error ("Internal error. Cleartool find should not fail");

    }

    if ( $last_result )

    {

        #

        #   A branch already exists - and there can only be one

        #

        $last_result =~ m~@@(.*)/([^/]+)~;

        $target_branch = $1;

        Error ("Cannot determine full branch path: $last_result") unless ( $target_branch );

        Verbose2 ("Target Branch: $target_branch" );

    }

    else

    {

        Verbose ("Create the initial branch point" );

        ClearCmd( 'mkbranch', '-nco', '-nc', '-nwarn', $branch_point, $opt_branch, $opt_ofile );

    }

}

#

#   Ensure that the branch with the target auto builder file on is not locked

#

ClearCmd ( 'lslock', '-short', "$opt_ofile\@\@$target_branch" );

if ( $last_result )

{

    Verbose ("Unlocking branch: $target_branch");

    ClearCmd( 'unlock', '-c', 'Unlocked by JATS ABTSAVE', "$opt_ofile\@\@$target_branch" );

}

#

#   Look for a checked out file on the target branch

#   It may be reserved - this will kill the process, so unreserve it

#

if ( ClearCmd( 'lsco', '-long', '-brtype', $opt_branch, $opt_ofile ) )

{

    Error ("Internal error. Cleartool lsco should not fail");

}

#

#   Can only have one 'reserved' checkout on the branch, but it may not

#   be the first one listed.

#       Lines are in sets of 3

#           1) Not used

#           2) Has keyword reserved

#           3) Has full path to view server

#   Need veiew server path, iff its a reserved checkout

#

my $reserved = undef;

foreach ( @last_results )

{

    #

    #   Once reserved has been seen, the next line will contain the view path

    #

    if ( $reserved )

    {

        m~\(\"(.+)\"\)~;

        my $view = $1;

        $view =~ s~/~\\~g unless ( $ENV{GBE_UNIX} );

        Verbose2 ("Reserved checkout: Target View: $view" );

        ClearCmd( 'unreserve', '-comment', 'Unreserved by JATS ABTSAVE', '-view', $view, $opt_ofile );

        #

        #   Only one reserved file can exist, so there is no more to do

        #

        last;

    }

    #

    #   Check to see if this line flags a reserved version

    #

    $reserved = m~\(reserved\)~;

}

#

#   Use clearcase to checkout the output file

#

Verbose ("Checkout file: $opt_ofile" );

ClearCmd ('co', '-nc', '-nq', '-ndata', '-nwarn', '-branch', $target_branch, $opt_ofile);

Error ("Program Terminated") if ( @error_list );

#

#   Place the label on this file

#       If the label is locked then unlock it first

#       This is OK, because we are the builder ( or have permission )

#

if ( $was_locked )

{

    Verbose ("Relocking label: $pkg_label");

    ClearCmd ('unlock', "lbtype:$pkg_label" );

}

ClearCmd ('mklabel', '-replace', $pkg_label, $opt_ofile );

my @delayed_error = @error_list;

ClearCmd ('lock', "lbtype:$pkg_label" ) if $was_locked;

#

#   Place a Hyperlink Merge arrow between the two files if it looks as though we

#   have stolen the file or its label. If the original build file is on a different branch

#   the we have stolen it.

#

Verbose ("Check need to create a Hyperlink" );

my $target_name = $opt_ofile;

Verbose2 ("FullName: $full_name :Branch: $full_branch" );

Verbose2 ("TargetName: $target_name :Branch: $target_branch" );

if ( ( $full_branch ne $target_branch ) && ( !$opt_newbranch ) )

{

    Verbose ("Creating Hyperlink" );

    ClearCmd ('mkhlink', 'Merge', $full_name, $target_name);

}

#

#   Check in the file auto.pl file as the new build.pl file

#   This may get ugly if the current config-spec does not have a rule to

#   select the "new" build.pl file. This is often the case

#

#   Examine the error output and discard these errors

#

Verbose ("Check in build file: $opt_ofile" );

ClearCmd ('ci', '-c', "AutoBuilder checkin: $pkg_label", '-identical', '-from', $opt_infile, $opt_ofile);

Error ("Program Terminated") unless ( $last_result =~ m/Checked in "$opt_ofile" version/ );

@error_list = @delayed_error;

Error ("Program Terminated") if ( @error_list );

#

#   Label the view

#

label_build_view();

exit 0;

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

# Function        : locate_build_directory

#

# Description     : Locate the build directory that contains the build files

#                   In an ANT build, this will e the root of the package

#                   Otherwise the build files may not be in the root directory

#

#

# Inputs          : Globals

#

# Returns         : Globals

#

sub locate_build_directory

{

    return unless ( $opt_locate );

    my $bscanner = BuildFileScanner ( '.', $opt_infile );

    my $count = $bscanner->locate();

    Error ("Autolocate. Build file not found: $opt_infile" )

        if ( $count <= 0 );

    #

    #   If multiple build files have been found

    #   Scan the buildfiles and determine the names of the packages that will

    #   be built. This can be used to generate nice error messages

    if ( $count > 1 )

    {

        $bscanner->scan();

        $count = $bscanner->match( $opt_locate );

        my $errmess;

        if ( $count <= 0 ) {

            $errmess = "None found that build package: $opt_locate";

        } elsif ( $count > 1 ) {

            $errmess = "Multiple build files build the required package: $opt_locate";

        }

        #

        #   Pretty error display

        #   Display build directory and the package name (mangled)

        #

        if ( $errmess )

        {

            Error ("Autolocate. Multiple build files found.",

                   $errmess,

                   "Build files found in:", $bscanner->formatData() );

        }

    }

    #

    #   Extract the required build file directory

    #

    my $dir = $bscanner->getMatchDir() || '';

    Verbose ("Autolocate. Found $count build files: $dir");

    #

    #   Select the one true build directory

    #

    if ( $dir ne '.' )

    {

        #

        #   Save the current directory for later

        #

        $root_dir = getcwd();

        chdir $dir || Error ("Cannot change directory: $dir");

    }

}

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

# Function        : determine_package_label

#

# Description     : Determine the label that is to be applied to the package

#                   There are several cases to consider

#                       1) Compatability mode: User provides label

#                       2) WIP Mode. Determine name of label to use in rename

#                       3) Create a new label

#

# Inputs          : Globals

#

# Returns         : Globals

#                       $pkg_label

#

sub determine_package_label

{

    #

    #   Determine the desired label for the package

    #   This is a function of the package name and the package version

    #   The two are joined with a '.'

    #

    $tag_label = $opt_pname . '_' . $opt_pversion;

    #

    #   Ensure that desired label is "free", if not then hunt for a new one

    #   Determine the name of a 'new' label

    #

    my $base_label = $tag_label;

    my $index = 0;

    while ( ++$index )

    {

        if ( $index > 20 )

        {

            Error ("Cannot determine new label. Retry limit exceeded");

        }

        Verbose2 ("Trying $tag_label");

        unless (ClearCmd ('describe', '-short', "lbtype:$tag_label" ) )

        {

            #

            #   Label found - so try another

            #

            Verbose2("Label found. Try another");

            $tag_label = $base_label . '.' . $index;

            next;

        }

        #

        #   Warn about non standard label

        #

        Verbose ("Package will be labeled: $tag_label");

        Warning ("Labeling with a non-standard label: $tag_label" )

            if ( $index > 1 );

        last;

    }

    #

    #   Free label has been found

    #   Create it now, unless we are processing a WIP

    #

    unless ( $opt_wiplabel )

    {

        Verbose ("Creating new label: $tag_label");

        ClearCmd ('mklbtype', '-c', 'Autobuild Created', $tag_label );

        Error ("Cannot create new label: $tag_label" ) if ( @error_list );

        #

        #   Mark as created by this utility

        #   Label should be deleted on error

        #

        $label_created = $tag_label;

        $pkg_label = $tag_label;

    }

    else

    {

        $pkg_label = $opt_wiplabel;

    }

}

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

# Function        : label_build_view

#

# Description     : Label the view

#

#                   Either:

#                       Rename the WIP label to required name

#                       Label all files in the view

#                   

#                   Use JATS to do the hard work

#

#

# Inputs          : Globals

#

# Returns         : 

#

sub label_build_view

{

    if ( $opt_wiplabel )

    {

        Verbose ("Rename label: From $opt_wiplabel to $tag_label");

        SystemConfig ( ExitOnError => 2);

        JatsCmd( 'label', '-unlock', $opt_wiplabel, '-rename', $tag_label, '-lock' );

    }

    else

    {

        Verbose ("Apply new label to package: $tag_label");

        #

        #   Need to determine the root of the VOB

        #   Currently within the VOB.

        #   Get the "versioned object base" from clearcase

        #   Change to that directory and label the entire subtree

        #

        ClearCmd('describe', '-fmt', '%Ln', 'vob:.');

        Error ("Program Terminated") if ( @error_list );

        Error ("Cannot determine current VOB base" ) unless ( $last_result );

        my $vob_base = quotemeta($last_result);

        Verbose ("VOB Base: $vob_base");

        my $here =  getcwd();

        Verbose ("Current dir: $here");

        $here =~ m~^(.*$vob_base)~;

        my $base_dir = $1;

        Verbose ("Path of base: $base_dir");

        chdir ( $base_dir ) || Error ("Cannot chdir to vob base", $base_dir);

        #

        #   Label the entire (static) view

        #   Handle errors as error exit will clean up

        #

        my $rv =JatsCmd( 'label', '-label', $tag_label, '-replace', '-lock' );

        Error ("Failed to label all files in view")

            if ( $rv );

    }

    #

    #   Write the label out to the specified file so that the user

    #   can do something with it

    #

    if ( $opt_infofile )

    {

        my $data = JatsProperties::New();

        $data->setProperty('Label', $tag_label);

        $data->setProperty('WipLabel', $opt_wiplabel ) if $opt_wiplabel;

        $data->setProperty('PackageName', $opt_pname);

        $data->setProperty('PackageVersion', $opt_pversion);

        $data->setProperty('clearcase.branch', $opt_branch);

        $data->Dump('InfoFile') if ($opt_verbose);

        $data->store( $opt_infofile );

    }

}

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

# Function        : ClearCmd

#

# Description     : Execute a ClearCase command and capture the results

#                   Errors are held in one array

#                   Result are held in another

#

# Inputs          :

#

# Returns         :

#

sub ClearCmd

{

    my $cmd = QuoteCommand (@_);

    Verbose2( "cleartool $cmd" );

        @error_list = ();

        @last_results = ();

        $last_result = undef;

        open(CMD, "cleartool $cmd  2>&1 |")    || Error( "can't run command: $!" );

        while (<CMD>)

        {

            chomp;

            $last_result = $_;

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

            push @last_results, $last_result;

            Verbose2 ( "cleartool resp:" . $_);

            push @error_list, $_ if ( m~Error:~ );

        }

        close(CMD);

    Verbose2( "Exit Status: $?" );

    return $? / 256;

}

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

# Function        : display_error_list

#

# Description     : Display the error list and clean up

#                   This function is registered as an Error callback function

#                   it will be called on error exit

#

# Inputs          :

#

# Returns         :

#

sub display_error_list

{

    foreach ( @error_list )

    {

        print "$_\n";

    }

    #

    #   Perform cleanup

    #       Delete the label if created it anyway (which we did)

    #       This leaves checked in build file on branch (live with it)

    #

    JatsCmd( 'label', '-delete', $tag_label )

        if ($label_created);

}

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

#   Documentation

#

=pod

=head1 NAME

jats_save_build - Save a build view to version control system

=head1 SYNOPSIS

  jats etool jats_save_build [options]

 Options:

    -help[=n]           - brief help message

    -help -help         - Detailed help message

    -man[=n]            - Full documentation

    -verbose[=n]        - Verbose operation

    -infile=xxx         - Input file (auto.pl)

    -outfile=xxx        - Output file (build.pl)

    -branch=xxx         - Branch to create (AutoBuilder)

    -newbranch          - Force file to be on a new (project) branch

    -infofile=path      - Save label information in 'path'

    -pname=name         - Name of the package

    -pversion=text      - Package version

    -locatepkg=text     - Package locator string

    -wiplabel=text      - Current package WIP label

=head1 OPTIONS

=over 8

=item B<-help[=n]>

Print a brief help message and exits.

The verbosity of the help text can be controlled by setting the help level to a

number in the range of 1 to 3, or by invoking the option multiple times.

=item B<-man[=n]>

Without a numeric argument this is the same as -help=3. Full help will be

displayed.

With a numeric argument, this option is the same as -help=n.

=item B<-verbose[=n]>

This option will increase the level of verbosity of the utility.

If an argument is provided, then it will be used to set the level, otherwise the

existing level will be incremented. This option may be specified multiple times.

=item B<-infile=xxxx>

This option specifies the name of the generated build configuration file that

will be used as a data-source for the check-in build file.

The default file name is 'auto.pl'.

=item B<-outfile=xxxx>

This option specifies the name of the target build configuration file that

will be checked in to version-control. Data from from file specifies with '-

infile' will be used to update the file.

The default file name is 'build.pl'.

=item B<-branch=xxxx>

This options specifies the root name of the target branch that will be sued to

contain the checked-in build file. If the branch does not exist it will be

created.

The default branch will be based on "AutoBuilder".

=item B<-newbranch>

This option will force the file to be checked into a new branch

The branch will be created on /main/0 unless it is already found elsewhere

This option allows a build.pl file to be placed on a new project branch.

=item B<-infofile=path>

This option specifies a file that this utility will use to communicate with a

user script. It will write the new label text into the file.

The file path is relative to the current working directory.

The file will be deleted, and only created if the utility is successful.

=item B<-pname=name>

This option specifies the package name. It will be used to construct a new

label for the package.

=item B<-pversion=xxx>

This option specifies the package version. It will be used to construct a new

label for the package.

=item B<-locatepkg=text>

This option specifies a name, by which the package's build files may be located.

This is only needed for JATS builds and will only be used to resolve the

location of build files when a package contains multiple build files.

=item B<-wiplabel=text>

This option controls the manner in which this utility will label the build view.

If present, the label specifies a 'Work In Progress' label. The label will be

renamed.

If not present, then the view will be labeled with a new label.

=back

=head1 DESCRIPTION

This utility is used by the automated build system to place build view under

version control. The utility will:

=over 8

=item * Determine a suitable label for the package

The label is constructed from the package name and the package version. The

utility will ensure that the label does not already exist. If it does it will

use an alternate form of the label.

=item * Determine a suitable branch name for the build files

The modified build file is placed on a file-branch.

=item * Locate the build files within the package

JATS build files do not need to be at the root of the package. The utility

will locate the JATS build files.

=item * Update the build files and save them into the version control system

The build file will be updated with new version information as provided by a

secondary configuration file.

The updated file will be checked into version control. It will be placed on a

branch so as not to affect dynamic views.

The operation will fail if that file is checked out "reserved". The program

can work around this - but its not done yet.

If the build file is sourced from a different branch then a Merge arrow

will be created to indicate where the file and its label was taken from.   

=item * Ensure that the package is labeled

The build view will be labeled.

If a WIP label is provided then the label will be applied to the modified

build file and then the label will be renamed.

If a WIP label is not provided, then the entire package will be labeled with a

suitable label.

=item * Return the label to the user

The label used to label the package will be returned to the user in an 'info'

file. This is a 'properties' file. The following properties are defined:

=over 8

=item   1) Label - The label used to tag the file

=item   3) WipLabel - The WIP label provided (optional)

=item   4) PackageName - The package name

=item   5) PackageVersion - The package version

=back

=back

=cut