Subversion Repositories DevTools

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

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

#

# Module name   : jats_ccrelease.pl

# Module type   : Makefile system

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : A script to build a package from a clearcase element

#                 The script will:

#                   Create a clearcase view

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

#

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

require 5.008_002;

use strict;

use warnings;

use JatsError;

use JatsSystem;

use FileUtils;

use JatsBuildFiles;

use ArrayHashUtils;

use Pod::Usage;                             # required for help support

use Getopt::Long;

use File::Find;

use File::Copy;

use File::Path;

use Cwd;

my $VERSION = "1.6.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_vob;                                # Hint: which VOB to use

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;                            # Just create a static view

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

my $opt_delete;                             # Just delete the view

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_lock = 0;                           # Lock label before release

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_latest_root;                        # Modify config spec with rule (kludge)

my $opt_branch;                             # Create config spec with branch

my $opt_debug_build = 0;                    # Build Debug Only

my $opt_prod_build = 0;                     # Build ion Only

my $opt_config_spec;                        # User provided config spec

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

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

#

#   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 $VIEWTAG;                                # The view tag

my $VIEWDIR;                                # Absolute path to the view

my $VIEWPATH;                               # Path relative to clearcase

my $user_cwd;

my $error = 0;

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

my @label_not_locked;                       # List of unlocked labels

my @label_locked;                           # List of labels I locked

my @error_list;                             # ClearCmd detected errors

my $UNIX_VOB_PREFIX = '/vobs';

my $VOB_PREFIX = $UNIX ? $UNIX_VOB_PREFIX : '';

my $UNIX_VIEW_PREFIX = '/view/';            # Don't know how to determine this value

my $WIN32_VIEW_PREFIX = 'o:/';              # Don't know how to determine this value

my $VIEW_PREFIX = $UNIX ? $UNIX_VIEW_PREFIX : $WIN32_VIEW_PREFIX ;

my $VOB_SEP         = $UNIX ? '/' : '\\';

my $view_prefix     = "${USER}_";

#

#   ROOT_VOBS is a list of VOBS too look in first

#   If a label is not found in these vobs, then the program will

#   look in all vobs. This list is a hint to speed up searching

#

my $ROOT_VOB;

my $root_vob_spec;

my @ROOT_VOBS = qw( /LMOS /DPG_SWBase /DPG_SWCode /ProjectCD /MASS_Dev_Bus

                    /MASS_Dev_Infra /MOS /MASS_Dataman /MASS_Dev /MASS_Dev_Dataman

                    /COTS /GMPTE2005 /GMPTE2005_obe /MPR /MOS );

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

# Function        : Mainline Entry Point

#

# Description     :

#

# Inputs          :

#

#

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

#

if ( $GBE_SANDBOX )

{

   $GBE_VIEWBASE = $GBE_SANDBOX;

   $opt_prefix = 0;

   (my $sandbox_name = $GBE_SANDBOX) =~ s~.*/~~ ;

   $opt_tag = 'sandbox.'. $sandbox_name unless ( $opt_tag );

}

#

#   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

                "spec=s"        => \@opt_spec,              # Array of build specs

                "config=s"      => \$opt_config_spec,       # String

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

                "vob=s"         => \$opt_vob,               # 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

                "lock!"         => \$opt_lock,              # [no]flag

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

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

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

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

                "latestroot=s"  => \$opt_latest_root,       # String

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

                "mkbranch=s"    => \$opt_branch,            # 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

                );

                #

                #   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'    => 'RELEASE',

             'verbose' => $opt_verbose );

#

#   Validate user options

#   Use either -label or one command line argument

#

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

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

push @opt_spec, @ARGV;

if ( $opt_config_spec )

{

    Error("Cannot use -path with -config")      if($opt_path);

    Error("Cannot use -branch with -config")    if($opt_branch);

    Error("Cannot use -vob with -config")       if($opt_vob);

    Error("Cannot use a label with -config")    if( @opt_spec);

    Error("Config spec file not found: $opt_config_spec") unless ( -f $opt_config_spec );

    unless ( $opt_viewname )

    {

        $opt_viewname = StripDirExt($opt_config_spec);

        $opt_viewname =~ s~[\.:/\\]~_~g;

    }

    $opt_vob = "";

    #

    #   Convert file in an absolute file name

    #   Will be needed as we change directory

    #

    $opt_config_spec = FullPath($opt_config_spec);

}

unless(  @opt_spec || $opt_config_spec  )

{

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

    Error ("Need a label or config_spec. -help for options") unless $opt_delete;

}

#

#   Convert label with embedded VCS information into a 'normal' form.

#   Form:

#       CC::label

#       CC::path::label

#       CC::::label

#

foreach ( @opt_spec )

{

    if ( $_ =~ m~^(.+?)::(.*?)(::(.+))?$~ )

    {

        Error ("Label contains invalid Version Control Identifier($1): $_")

            if ( $1 ne 'CC' );

        my $ll = $2;

        my $path;

        if ( $3 )

        {

            $path = $2;

            $ll = $4;

            if ( $path  )

            {

                Error ("Multiple conflicting Embedded source paths",

                       "Path: $opt_path",

                     "VCS Spec: $_" ) if ( $opt_path && $path ne $opt_path );

                $opt_path = $path;

            }

        }

        $_ = $ll;

    }

    Verbose ("Clean URL: $_");

}

#

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

#

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 );

#

#   Ensure that the 'cleartool' program can be located

#

Verbose ("Locate clearcase utility in users path");

Error ("Cannot locate the 'cleartool' utility in the users PATH")

    unless ( LocateProgInPath('cleartool', '--All') );

#

#   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 );

#

#   Setup user specified viewname

#   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 = $opt_spec[0] unless ( defined $opt_viewname );

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

#

#   Create the view tag

#   Attempt to make this globally unique

#   Include USER name, MACHINE name, the view name

#   Optionally include a user 'tag'. Provided to allow the ABT to maintain

#   multiple instances of a view.

#

unless ( $opt_tag )

{

    $opt_tag = $opt_extract_files ? 'extract' : 'build';

}

$VIEWTAG = "${USER}_${MACHINENAME}_${opt_tag}_${opt_viewname}";

#

#   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( "Viewtag: $VIEWTAG" );

Verbose( "Viewpath: $VIEWPATH" );

Verbose( "Viewdir : $VIEWDIR" );

#

#   If the user has specified a "source path", then we can extract the VOB

#   from that path. It will be the first directory

#

Verbose("Locate Source VOB");

if ( $opt_path )

{

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

    $opt_path =~ s~/+$~~;

    Error( "Source Path needs leading '/'") unless ( $opt_path =~ m~^/~ );

    Error( "Source Path is a UNC" ) if ( $opt_path =~ m~^//~ );

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

    #

    #   Extract the VOB from the path

    #

    unless ( $opt_vob )

    {

        my $vob = $opt_path;

        $vob =~ s~^/~~g;

        $vob =~ s~/.*~~g;

        $opt_vob = $vob;

        Verbose ("Extract VOB from path: $vob" );

    }

}

#

#   If the view currently exists then it will be deleted if allowed

#

delete_view()

    unless ( $opt_reuse );

#

#   If the user is simply deleting the view then all has been done

#

exit 0

    if ( $opt_delete );

#

#   Setup user specified VOB

#

if ( defined($opt_vob) )

{

    $ROOT_VOB = "/$opt_vob";

    $ROOT_VOB =~ s~//~/~g;

    @ROOT_VOBS = $ROOT_VOB;

}

else

{

    #

    #   Extend the list of ROOT_VOBS with all the known vobs

    #   The initial ROOT_VOBS are treated as a "hint" to assist searching

    #

        my $cmd = ClearToolCmd ('lsvob', '-short');

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

        while (<CMD>)

        {

            #

            #   Filter output from the user

            #

            chomp;

            s~^$UNIX_VOB_PREFIX~~ if ($UNIX);

            Verbose2("lsvob: $_");

            tr~\\/~/~s;

            push @ROOT_VOBS, $_;

        }

        close(CMD);

}

#

#   Ensure that the label is present within the specified VOB

#   Hunt for the user specified label in a number of well known VOBs

#

if ( @opt_spec )

{

    Verbose("Ensure Label is found in a VOB");

    my $found = 0;

    my $spec = $opt_spec[0];

    foreach my $vob ( @ROOT_VOBS )

    {

        $vob = $UNIX_VOB_PREFIX . $vob if ( $UNIX );

        (my $vob_name = $vob) =~ s~/~$VOB_SEP~g;

        Verbose2 ("Examine label $spec in vob: $vob" );

        my $cmd = ClearToolCmd ('lstype', "lbtype:$spec\@$vob_name");

        my $cmd_done = 0;

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

        while (<CMD>)

        {

            #

            #   Filter output from the user

            #   Stay in loop to avoid Broken Pipe message

            #

            chomp;

            Verbose2("lstype: $_");

            next if ( $cmd_done );

            next if ( m~Error~ );

            next unless ( m~label type~ );

            push @label_not_locked, $spec unless( m~\(locked\)~ );

            $label_count++;

            $found = $vob;

            $cmd_done = 1;

        }

        close(CMD);

        last if ( $found );

    }

    Error ("Label $spec not found in @ROOT_VOBS")

        unless ( $found );

    Verbose ("Label $spec found in vob: $found" );

    $ROOT_VOB = $found;

    #

    #   Create a VOB spec extension

    #

    $root_vob_spec = '@' . $ROOT_VOB;

    $root_vob_spec =~ s~/~$VOB_SEP~g;

    #

    #   Ensure that all labels are found in the VOB

    #

    foreach my $spec ( @opt_spec[1..$#opt_spec] )

    {

        $label_count++;

        Verbose ("Testing label $spec in vob: $ROOT_VOB" );

        my $data = qx( cleartool lstype lbtype:$spec$root_vob_spec );

        Verbose ( "lstype: $data" );

        Error ("Label $spec not found in $ROOT_VOB. All labels must be in the same VOB")

            if ( ! $data );

        push @label_not_locked, $spec unless( $data =~ m~\(locked\)~ );

    }

    #

    #   Ensure that the branch is found in the VOB

    #

    if ( $opt_branch )

    {

            Verbose ("Testing branch $opt_branch in vob: $ROOT_VOB" );

            my $data = qx( cleartool lstype brtype:$opt_branch$root_vob_spec );

            Verbose ( "lstype: $data" );

            Error ("Branch $opt_branch not found in $ROOT_VOB.")

                if ( ! $data );

    }

    #

    #   Lock the label(s)

    #

    if ( $opt_lock )

    {

        my @still_not_locked;

        Message( "Locking labels" );

        foreach my $spec ( @label_not_locked )

        {

            Verbose ("Locking $spec");

            push @label_locked, $spec;

            ClearCmd ('lock', "lbtype:$spec$root_vob_spec" );

            push @still_not_locked, $spec if ( @error_list );

        }

        @label_not_locked = @still_not_locked;

        #

        #   Register function to unlock all the locked lables on failure

        #

        ErrorConfig ('on_exit' => \&unlock_on_error );

        Error ("Not all labels locked: @label_not_locked") if ( @label_not_locked  );

    }

}

#

#   If we are only extracting files then ...

#

if ( $opt_extract_files )

{

    extract_files_from_view();

    exit (0);

}

#

#   Create a new (static) view

#   Create a config spec and populate the view

#

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

{

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

    my $view_comment = "ViewDir: $VIEWDIR";

    $view_comment .= " Created: " . localtime;

    #

    #   Tried creating a co-located view under Windows, but had problems

    #       1) Did not work on WindowsServer based build machine ??

    #       2) Deleting the view could be a problem if the user had

    #          files open in the view.

    #       3) Documentation doesn't really like the use of -colocated

    #

    foreach my $view_count ( 1 .. 5 )

    {

        my $cc_race_condition;

        my $cmd = ClearToolCmd ('mkview', '-snapshot', '-tag', $VIEWTAG, '-tcomment', $view_comment, $VIEWDIR);

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

        @error_list = ();

        while (<CMD>)

        {

            #

            #   Filter output from the user

            #

            chomp;

            tr~\\/~/~s;

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

            Verbose2("mkview: $_");

            #

            #   Detect Race condition

            #   Multiple build daemons creating views too fast for ClearCase

            #   ClearCase can hit a race condition and fail to create a view

            #

            if ( $_ =~ m~Error: Unable to create directory "[^"]+": File exists\.~ )

            {

                $cc_race_condition = 1;

            }

        }

        close(CMD);

        #

        #   Race condition detected

        #   Back-off and try again. Will only try a limited number of times

        #

        if ( $cc_race_condition  )

        {

            Message ("ClearCase Race condition detected");

            sleep ( $view_count );

            next;

        }

        last;

    }

    Error ("Cannot locate the created static view", @error_list)

        unless ( -d $VIEWDIR );

    #   In order to operate in this view (ie set the config spec, we need to

    #   be in the directory of the view

    #

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

    #

    #   Create a local package archive

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

    #   finding any outside the view

    #

    mkdir ( 'local_dpkg_archive')

        unless ($GBE_SANDBOX);

    my $config_file = $opt_config_spec;

    unless ( $config_file )

    {

        $config_file = create_config_spec ('config_spec.txt');

    }

    Message( "Populating the view");

    ClearTool( 'setcs', '-tag', $VIEWTAG, $config_file );

}

#   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 dynmaic view will be

#   This differ between UNIX/WINDOWS

#

if ( $opt_path && $GBE_ABT)

{

    Message( "Create Build tagfile");

    my $cpath = $VIEWDIR . $VOB_PREFIX . $opt_path;

    if ( -d $cpath )

    {

        TouchFile ( "$cpath/.jats.packageroot" );

    }

}

#

#   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$ROOT_VOB", '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 locked") if ( @label_not_locked  );

    Message ("All labels are locked") unless ( @label_not_locked  );

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

    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) Building from a config spec

#       7) Cannot release from a sandbox

#

my @elist;

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

push @elist, "Package built from an unlocked label" if ( @label_not_locked  );

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, "View contains a branch" if ( $opt_branch );

push @elist, "Package based on a config spec" if ( $opt_config_spec );

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

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 );

#

#   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

#                   $VIEWTAG - name of the view

#                   $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: $VIEWTAG");

            RmDirTree( $VIEWDIR );

        }

    }

    else

    {

        #

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

        #

        if ( -d $VIEWDIR )

        {

            #

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

            #

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

            Verbose("Look for checked out files");

            chdir ( $VIEWDIR );

            foreach my $file ( glob ('*') )

            {

                next if ( $file =~ m~local_dpkg_archive~ );

                next if ( $file =~ m~^view\.~ );

                if ( -d $file )

                {

                    Verbose ("Examine $file for checked out files");

                    chdir "$VIEWDIR/$file";

                    my $cmd = ClearToolCmd('lsco', '-cview', '-rec' );

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

                    while (<CMD>)

                    {

                        #

                        #   Filter output from the user

                        #

                        chomp;

                        Verbose("lsco: $_");

                        if ( m~checkout version~ )

                        {

                            $cofound++ ;

                            Warning ("Checked out file: $_");

                        }

                    }

                    close(CMD);

                }

            }

            Error ("Will not delete view. Checked out files exist")

                if ( $cofound );

            #

            #   Get out of the view

            #   Cannot delete the view if we are in it.

            #

            chdir ( $user_cwd );

            #

            #   Static views should be removed by dirname, not by tag

            #

            ClearTool( 'rmview', $VIEWDIR );

            #

            #   Now try to delete the directory

            #

            RmDirTree( $VIEWDIR );

        }

        #

        #   If the view tag still exists then delete the view the hard way

        #   Use 'lsview' to locate the views uuid

        #

        Verbose("Look for View Tag");

        my $cmd = ClearToolCmd ('lsview', '-long', $VIEWTAG );

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

        while (<CMD>)

        {

            #

            #   Filter output from the user

            #

            chomp;

            Verbose("lsview: $_");

            $uuid = $1 if ( m~^View uuid:\s+(.*)~ );

        }

        close(CMD);

        if ( $uuid )

        {

            Warning ("Deleting view - the hard way");

            ClearTool( '--Quiet', 'rmview', '-force', '-all', '-uuid', $uuid );

            ClearTool( '--Quiet', 'unregister', '-view', '-uuid', $uuid );

            ClearTool( '--Quiet', 'rmtag','-view', '-all', $VIEWTAG );

        }

    }

    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

        #   Just make the directory entry. May result in empty directories

        #

        if ( -d $_ )

        {

            my $tdir = "$dest_dir/" . substr( $File::Find::dir, $slength);

            $tdir .= "/$_";

            File::Path::mkpath( $tdir )

                unless ( -d $tdir);

            return;

        }