Subversion Repositories DevTools

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

# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.

#

# Module name   : create_dpkg.pl

# Module type   : Makefile system

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : This script is used to create a dpkg_archive.

#                 Features:

#                   * No user interaction

#                   * Generates files list for ReleaseNote integration

#                   * Can generate package fragemts as a tarball for build system

#

# Usage:        : See POD

#

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

require 5.008_002;

# Include Standard Perl Functions

#

use strict;

use warnings;

use Cwd;

use Getopt::Long;

use File::Basename;

use File::Find;

use File::Path;

use File::Copy;

use Pod::Usage;

use Digest::MD5;

use XML::Simple;

use Encode qw(decode encode);

use JatsError;

use JatsEnv;

use DescPkg;

use FileUtils;

use JatsSystem;

use JatsVersionUtils;

#

#   Under Windows we need the Win32::FileSecurity module

#   It only exists under windows

#

my $Win32 = eval "require Win32::FileSecurity";

# define Global variables

#

my $VERSION = "3.0.0";

my $PROGNAME = "create_dpkg.pl";

# Globals imported from environment

#

our $GBE_MACHTYPE;

our $GBE_HOSTNAME;

our $USER;

our $GBE_ABT;

# Global variables

#

my $DPKG_NAME     = "";

my $DESC_NAME     = "";

my $DPKG_VERSION  = "";

my $DPKG_PRJ      = "";

my $DESCPKG_FILE  = "";

my $DESCPKG_TYPE  = "";

my $CWD_DIR       = cwd;

my $SRC_ROOT;

my $DPKG_DIR;

my $DPKG_ROOT;

my $PKG_BASE;

my $bad_merge_count = 0;

my @bad_symlinks;

my @fileList;

my $descPkgCount = 0;

my @tmpFiles;

#

#   Option variables

#

my $opt_help = 0;

my $opt_manual = 0;

my $opt_verbose = 0;

my $opt_quiet = 0;

my $opt_delete = 0;

my $opt_override = 0;

my $opt_merge = 0;

my $opt_archive;

my $opt_generic;

my $opt_pname;

my $opt_pversion;

my $opt_test;

my $opt_md5 = 1;

my $opt_outfile;

my $opt_info;

my $opt_tarmode;

my $opt_testArchive;

my $opt_noBuild;

my $opt_keepTemp;

#

#   Structure to translate -archive=xxx option to archive variable

#   These are the various dpkg_archives known to JATS

#

my %Archive2Var =( 'main'      => 'GBE_DPKG',

                   'store'     => 'GBE_DPKG_STORE',

                   'cache'     => 'GBE_DPKG_CACHE',

                   'local'     => 'GBE_DPKG_LOCAL',

                   'sandbox'   => 'GBE_DPKG_SBOX',

                   'deploy'    => 'GBE_DPLY',

                   'replica'   => 'GBE_DPKG_REPLICA',

                   'escrow'    => 'GBE_DPKG_ESCROW',

                   );

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

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

# Subroutines

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

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

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

sub LogFileOp

#

# Description:

#       This sub-routine is used to generate a consistent informational log

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

{

    my ($opr, $file) = @_;

    $file =~ s/\Q$DPKG_DIR\E/PKGDIR/;

    $file =~ s/\Q$DPKG_ROOT\E/DPKG/;

    $file =~ s/\Q$SRC_ROOT\E/PKG/;

    $file =~ s/\Q$CWD_DIR\E/CWD/;

    Information (sprintf( "%-15s [%s]", $opr, $file));

}

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

# Function        : addFile 

#

# Description     : Add a file to the list of transferred files

#

# Inputs          : $type           - File type

#                   $source         - Source file - full path

#                                     Use local copy, not network copy for file ops

#                   $target         - Target file name

#                   $md5sum         - Precalculated MD5 sum 

#

# Returns         : 

#

sub addFile

{

    my ($type, $source, $target, $md5sum) = @_;

    my %data;

    if ((not defined $md5sum) && ($type eq 'file'))

    {

        Verbose("Calculate MD5 Digest: $source");

        open(my $fh , $source) or Error ("Can't open '$source': $!");

        binmode $fh, ':crlf';

        $md5sum = Digest::MD5->new->addfile($fh)->hexdigest;

        close $fh;

    }

    $target =~ s~\Q$DPKG_DIR\E~~;

    $target =~ s~^/~~;

    $target =~ s~/$~~;

    #

    #   Convert from iso-8859-1 into utf-8

    #

    $target = decode( 'iso-8859-1', $target );

    $target = encode( 'utf-8', $target );

    if ($type eq 'dir')

    {

        $data{path} = $target;

    }

    else

    {

        $data{path} = StripFileExt($target);

        $data{name} = StripDir($target);

        if ($type eq 'file')

        {

            $data{size} = (stat($source))[7];

            $data{md5sum} = $md5sum;

        }

    }

    $data{fullname} = $target;

    $data{type} = $type;

    $data{machtype} = $GBE_MACHTYPE;

    $data{host} = $GBE_HOSTNAME;

    # Put a nice '/' on the end of the path elements

    $data{path} .= '/'

        if ( exists ($data{path}) && length($data{path}) > 0);

    push @fileList, \%data;

}

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

# Function        : writeFileInfo 

#

# Description     : Write out an XML file that contains this processes

#                   contribution to the output package 

#

# Inputs          : $targetDir          - Base directory for the file 

#

# Returns         : 

#

sub writeFileInfo

{

    my ($targetDir) = @_;

    my $data;

    $data->{file} = \@fileList;

    #

    #   Write out sections of XML

    #       Want control over the output order

    #       Use lots of attributes and only elements for arrays

    #       Save as one attribute per line - for readability

    #

    $opt_outfile = $opt_generic ? "built.files.generic.xml" : "built.files.$GBE_HOSTNAME.xml";

    $opt_outfile = catfile( $targetDir, $opt_outfile); 

    LogFileOp ('Meta File', $opt_outfile);

    my $xs = XML::Simple->new( NoAttr =>0, AttrIndent => 1 );

    open (my $XML, '>', $opt_outfile) || Error ("Cannot create output file: $opt_outfile", $!);

    $xs->XMLout($data, 

                'RootName' => 'files', 

                'XMLDecl'  => '<?xml version="1.0" encoding="UTF-8"?>',

                'OutputFile' => $XML);

    close $XML;

}

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

sub Init

#

# Description:

#     This function is used to process any command line arguements

#     and print the start banner.

#

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

{

    # Process any command line arguements...

    my $result = GetOptions (

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

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

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

                'override!'     => \$opt_override,          # [no]flag (No longer used. Backward compat with build tool)

                'delete!'       => \$opt_delete,            # [no]flag

                'merge|m!'      => \$opt_merge,             # [no]flag.

                'archive=s'     => \$opt_archive,           # string

                'quiet+'        => \$opt_quiet,             # Flag

                'generic!'      => \$opt_generic,           # [no]Flag

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

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

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

                'md5!'          => \$opt_md5,               # [no]flag

                'info!'         => \$opt_info,              # [no]flag

                'tarmode!'      => \$opt_tarmode,           # [no]flag

                'testArchive'   => \$opt_testArchive,       # [no]flag

                'nobuild'       => \$opt_noBuild,           # flag

                'keepTemp'      => \$opt_keepTemp,          # flag

                );

    #

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

    #

    #   Init the error and message subsystem

    #

    ErrorConfig( 'name'    =>'CREATE_DPKG',

                 'verbose' => $opt_verbose,

                 'quiet'   => $opt_quiet );

    if ($opt_verbose)

    {

       Verbose ("Program: $PROGNAME");

       Verbose ("Version: $VERSION");

    }

    #

    #   Needed EnvVars

    #

    EnvImport ('GBE_MACHTYPE');

    EnvImport ('GBE_HOSTNAME');

    EnvImport ('USER' );

    EnvImportOptional ('GBE_ABT', "");

    EnvImportOptional ('GBE_DPKG_ESCROW', "");

    $CWD_DIR = catdir($CWD_DIR);

    #

    #   Determine the target archive

    #   The default archive is GBE_DPKG, but this may be changed

    #

    unless ( $opt_archive )

    {

        $opt_archive = 'main';

        $opt_archive = 'escrow' if ($::GBE_DPKG_ESCROW);

    }

    my $archive_tag = $Archive2Var{$opt_archive};

    Error("Unknown archive specified: $opt_archive")

        unless ( $archive_tag );

    $DPKG_ROOT = $ENV{$archive_tag} || '';

    Verbose ("Archive Variable: $archive_tag" );

    Verbose2 ("Archive Path: $DPKG_ROOT" );

    #

    #   Append testArchive path

    #

    $DPKG_ROOT = catdir ($DPKG_ROOT, '.dpkg_archive', 'test_dpkg') if $opt_testArchive;

    #

    #   Detect NoBuild marker

    #   This will bypass most of the operation of this package

    #

    $opt_noBuild = 2 if -f 'noBuild.gbe';

    if ( $opt_noBuild)

    {

        Verbose ("NoBuild Marker file found");

        $SRC_ROOT = '';

        $DPKG_NAME = 'pkg';

        $DESCPKG_FILE = 'descpkg';

        $PKG_BASE =$CWD_DIR;

        #

        #   Use provided name and version

        #   Comparatbility only with ANT build system. Not needed by JATS

        #

        if ($opt_pname && $opt_pversion) {

            $DPKG_NAME = $opt_pname;

            $DPKG_VERSION = $opt_pversion;

        }

        return;

    }

    #

    #   Check for a "pkg" directory

    #   This may be in:

    #       1) The deploy directory (DEPLOY) build/deploy/descpkg

    #       2) The build directory (ANT)     build/pkg/descpkg

    #       3) The current directory (JATS)  pkg/xxxx/descpkg

    #

    $PKG_BASE = "$CWD_DIR/build/deploy";

    Verbose2 ("Looking for descpkg: $PKG_BASE");

    if ( -f "$PKG_BASE/descpkg" )

    {

        #

        #   This is a deployment package.

        #   Force the use of the GBE_DPLY

        #

        $opt_archive = 'deploy' unless ( $opt_archive );

    }

    else

    {

        $PKG_BASE = "$CWD_DIR/build/pkg";

        Verbose ("Looking for descpkg: $PKG_BASE");

        if ( ! -f  "$PKG_BASE/descpkg" )

        {

            $PKG_BASE = "$CWD_DIR/pkg";

            Verbose ("Looking for descpkg: $PKG_BASE");

            Error("Failed to find a package to transfer. Looked in:",

                  "./build/deploy",

                  "./build/pkg",

                  "./pkg"

                  )

                unless( -d $PKG_BASE );

        }

    }

    Verbose("Package directory: $PKG_BASE");

    Error("Repository location not specified: $archive_tag")

        unless $DPKG_ROOT;

    Error("Failed to find Repository: $DPKG_ROOT")

        unless ( -d $DPKG_ROOT );

    #   Locate the package

    #   Packages are located by looking for a file called descpkg within the

    #   main package directory.

    #

    #   This installation process only handles one such file

    #

    $descPkgCount = 0;

    File::Find::find( \&pkgFind, $PKG_BASE);

    if ($descPkgCount > 1 )

    {

        Warning ("Package contains multiple ($descPkgCount) descpkg files");

    }

}

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

# Function        : CheckDescPkg

#

# Description     : Check the descpkg file

#

# Inputs          : Globals

#

# Returns         : Will not return on error

#

sub CheckDescPkg

{

    #

    #   May not need a package description if performing a no-build

    #       The package name and version will may be provided on the command line

    #   Compatability for ANT builds

    #       

    #

    if ($opt_noBuild) {

        if ($opt_pname && $opt_pversion) {

            return;

        }

        Error("NoBuild operation requires package name and version")

    }

    # Get the dpkg_archive version number we are  going to create.

    #

    Error("Descpkg file not found in package directory: $PKG_BASE")

        unless ( -f "$DESCPKG_FILE" );

    #

    #   Read in the package description and validate essential fields

    #

    GetDpkgArchiveVersion($DESCPKG_FILE);

    unless ( "$DPKG_VERSION" )

    {

        Error ("Incorrect descpkg content detected.",

               "Check JATS build.pl config.");

    }

    #

    #   Need to support two forms of pkg subdirectory

    #       1) packages are in a named subdir within 'pkg'

    #       2) package is within 'pkg' or 'deploy'

    #

    if ( $DPKG_NAME eq 'pkg' || $DPKG_NAME eq 'deploy' )

    {

        $DPKG_NAME = $DESC_NAME;

        unless ( $DESC_NAME )

        {

            Error ("Cannot determine package name",

                   "The packages 'descpkg' file is bad or missing");

        }

    }

    elsif ( $DESC_NAME ne $DPKG_NAME )

    {

        Error ("Package name MUST match package description",

               "Check build.pl and package.pl",

               "Package name: $DPKG_NAME",

               "Description : $DESC_NAME" );

    }

    #

    # lets just check to see if we have a version number before

    # we proceed.

    #

    unless ( $DPKG_VERSION )

    {

        Error("Cannot determine dpkg_archive version number.",

              "Check JATS build config.");

    }

    my ($pn, $pv, $ps ) = SplitPackage ($DPKG_NAME, $DPKG_VERSION );

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

    #

    #   Sanity test package name and version, if provided

    #

    if ( $opt_pname )

    {

        ReportError ("Package Name does not match expected name",

                     "Expected: '$opt_pname'",

                     "Descpkg : '$DPKG_NAME'") unless ( $DPKG_NAME eq $opt_pname );

    }

    if ( $opt_pversion )

    {

        ReportError ("Package Version does not match expected version",

                     "Expected: '$opt_pversion'",

                     "Descpkg : '$DPKG_VERSION'") unless ( $DPKG_VERSION eq $opt_pversion );

    }

    ErrorDoExit();

}

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

# Function        : ShowInfo

#

# Description     : Show info to the user

#

# Inputs          : 

#

# Returns         : 

#

sub ShowInfo

{

    #

    #   Set up the target directory path and name

    #   It will be created later

    #

    if ($opt_tarmode)

    {

        $DPKG_DIR = catdir($DPKG_ROOT, '.dpkg_archive', 'fragments');

    }

    else

    {

        $DPKG_DIR = catdir($DPKG_ROOT, $DPKG_NAME, $DPKG_VERSION );

    }

    #

    #   Information for the user

    #

    Information ("---------------------------------------------------------------");

    Information ("Dpkg archive creation tool...");

    Information ("Version: $VERSION");

    Information ("");

    Information ("Information:");

    Information ("Escrow Build") if ($opt_archive eq 'escrow');

    Information ("Working dir   = [$CWD_DIR]");

    Information ("Package Root  = [$SRC_ROOT]");

    Information ("Repository    = [$DPKG_ROOT]");

    Information ("                *Non Standard archive") unless ($opt_archive eq 'main' || $opt_archive eq 'escrow');

    Information ("Target dir    = [$DPKG_DIR]");

    Information1("DPKG_NAME     = [$DPKG_NAME]");

    Information1("DPKG_VERSION  = [$DPKG_VERSION]");

    Information1("DPKG_PRJ      = [$DPKG_PRJ]");

    Information1("GBE_MACHTYPE  = [$GBE_MACHTYPE]");

    Information1("GBE_HOSTNAME  = [$GBE_HOSTNAME]");

    Information1("GBE_ABT       = [$GBE_ABT]");

    Information1("USER          = [$USER]");

    Information ("")                                if ( $opt_merge || $opt_delete || $opt_info || $opt_tarmode || $opt_testArchive || $opt_noBuild);

    Information ("Opt:NoBuild       = Enabled")     if ( $opt_noBuild );

    Information ("Opt:TarMode       = Enabled")     if ( $opt_tarmode );

    Information ("Opt:Delete        = Enabled")     if ( $opt_delete );

    Information ("Opt:Merge         = Enabled")     if ( $opt_merge );

    Information ("Opt:testArchive   = Enabled")     if ( $opt_testArchive );

    Information ("Opt:TestMode      = Enabled. No Package Transferred") if ( $opt_test );

    Information ("Opt:Info          = Enabled. No Package Transferred") if ( $opt_info );

    Warning     ("Sandbox Build     = Yes") if ($ENV{GBE_DPKG_SBOX}) ;

    Information ("---------------------------------------------------------------");

    #

    #   If the environment variable GBE_DPKG_SBOX is defined then the package

    #   is being built within a development sandbox. In such a sandbox the

    #   version numbers of the packages are ignored. Publishing a package

    #   from such an environment is certainly not reproducible - so don't allow

    #   it to happen

    #

    #   Allow versions of 99.99.99 as these are known to be test versions

    #

    unless ( $opt_archive eq 'local' || $opt_archive eq 'sandbox' || $opt_testArchive || $::GBE_DPKG_ESCROW)

    {

        if ( $ENV{GBE_DPKG_SBOX} )

        {

            unless ( $DPKG_VERSION =~ /^99.99.99/ )

            {

                Error("Cannot not publish a package that has been generated",

                   "within a Sandbox as the version of dependent packages",

                   "is not guaranteed.",

                   "Only version 99.99.99 is allowed");

            }

        }

    }

}

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

sub pkgFind

#

# Description:

#     This subroutine is used to locate the FIRST descpkg file in

#     the local pkg dir.

#

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

{

    my($item)= "$File::Find::name";

    my($file)= File::Basename::basename($item);

    # we get the absolute path from the find, but we only require

    # a relative path from the starting dir.

    # so our start dir.

    # we need to determine which file we are dealing with

    if ( ! -d $item && $file =~ /^descpkg$/ )

    {

        $descPkgCount++;

        #

        #   Only grab the first one

        #

        if ( $DESCPKG_FILE )

        {

            $item =~ s~\Q$PKG_BASE\E/~~;

            Verbose ("Multiple descpkg files:", $item );

            return;

        }

        $DESCPKG_FILE = $item;

        my($dir)= File::Basename::dirname($item);

        $DPKG_NAME = File::Basename::basename($dir);

        $SRC_ROOT = catdir($dir);

    }

}

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

sub GetDpkgArchiveVersion

#

# Description:

#     This subroutine is used to determine the version of the dpkg_archive.

#     We assume that the version number is in the descpkg file.

#

#     Need to allow for two forms of descpkg. Some one decided that a Java

#     Manifest would be a good descpkg file - a long time after the rest of the

#     world had been using an existing file format.

#

#     Lines are tagged

#

#     Once the version number is determined we set the

#     global DPKG_VERSION variable.

#

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

{

    my ($path) = @_;

    my $line;

    my $type;

    #

    #   Use a common routine to parse the package descriptor

    #   There are several forms that may need to be processed

    #

    my $pkg_data = ReadDescpkg( $path );

    Error("Failed to open file [$path].") unless $pkg_data;

    $DESC_NAME    = $pkg_data->{'NAME'};

    $DPKG_VERSION = $pkg_data->{'VERSION_FULL'};

}

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

# Function        : TransferDescpkg

#

# Description     : Copy and process the descpkg file to the target

#

# Inputs          :

#

# Returns         :

#

sub TransferDescpkg

{

    my $result = CopyDescpkg( @_ );

    Error("Transfer descpkg: $result") if ( $result );

}

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

sub CreateDpkgArchive

#

# Description:

#     This subroutine is used to create the dpkg_archive in the $DPKG_ROOT

#     location 

#

#     We use the global DPKG_ROOT, DPKG_DIR, DPKG_NAME, and DPKG_VERSION

#     to create the required directory structure.

#

#     If the dpkg_archive is new (ie not a new version) it is assumed the user

#     has access to create the top level dir for the new dpkg_archive.

#

#     The new dpkg_archive is created with the permission of the user 

#     executing this script.

#

#     If an error ocurs during the dpkg_archive creation the script

#     will terminate.

#

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

{

    #

    # first we need to ensure we have the top level directory

    #

    if ( -d $DPKG_DIR )

    {

        Warning("Detected previous dpkg_archive [$DPKG_DIR]");

        Error ("Package already exists and Package merging not selected")

            unless ( $opt_delete || $opt_merge );

        #

        #   Target exists

        #   Unless we are merging, we need to blow the entire tree away

        #

        unless ( $opt_merge )

        {

            LogFileOp("Remove Prev Pkg",$DPKG_DIR);

            rmtree($DPKG_DIR);

            #

            #   At this point the target directory 'should not' exist

            #   but it may. Some packges (like JATS) have Unix links within

            #   dpkg_archive filesystem. These cannot be deleted under windows

            #

            #   Not nice, but we live with it.

            #

            Warning ("Unable to delete previous instance of the package")

                if ( -d $DPKG_DIR );

        }

    }

    Information("");

    #

    #   Create the top level directory

    #

    mkpath($DPKG_DIR, 0, 0775);

    #

    #   Transfer source directory, unless this is a noBuild

    #

    if ( $SRC_ROOT ne '' )

    {

        # Process the files

        #

        if ( -d $SRC_ROOT )

        {

            File::Find::find( \&pkgFind2, $SRC_ROOT );

            if (@bad_symlinks)

            {

                my $msg = "Bad Symlinks: " . scalar @bad_symlinks;

                $opt_test ? ReportError($msg, @bad_symlinks) : Warning($msg, @bad_symlinks);

            }

            if ( $bad_merge_count )

            {

                my $msg = "Merged files that differ: $bad_merge_count";

                $opt_md5 ? ReportError($msg) : Warning($msg);

            }

            ErrorDoExit();

        }

        else

        {

            Error("Failed to find dir [$SRC_ROOT]",

                  "Check JATS config.");

        }

    }

    #

    #   Transfer of data is complete

    #       Mark the archive with the build machine to indicate which parts of

    #       a multi-machine build have been performed

    #

    my $touchfile = createBuiltFile($DPKG_DIR);

    addFile('file', $touchfile, $touchfile);

    #

    #   If there is a .lnk file in the archive then remove it now that the

    #   archive has been transferred. The .lnk files are created in 'local'

    #   archives in order to simplify multi-package builds

    #

    my $link_file = "$DPKG_ROOT/$DPKG_NAME/$DPKG_VERSION.lnk";

    if ( -f $link_file )

    {

        LogFileOp("Removing Link",$link_file);

        unlink $link_file;

    }

    #

    #   Create the MD5 info file

    #   

    writeFileInfo($DPKG_DIR);

    return 1;

}

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

sub pkgFind2

#

# Description:

#   This subroutine is used to locate all associated pkg files in

#   the local pkg dir.

#

#   This routine is called for each file and directory within the package

#   Some files and directories are treated in a special manner

#       - Top level directory is ignored

#

#

#

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

{

    my $item = $File::Find::name;

    my $base = File::Basename::basename($item);

    #

    #   Calculate the target directory name

    #

    my $target = $item;

    $target = $DPKG_DIR . substr ( $item, length ($SRC_ROOT) );

    if ( -d $item )

    {

        #

        #   Ignore the top level directory

        #   It has already been created

        #

        return

            if ( $item eq $SRC_ROOT );

        #

        #   Directories are handled differently

        #       - Directories are created with nice permissions

        #       - If the directory already exists then it is being merged.

        #

        if ( ! -d "$target" )

        {

            LogFileOp("Creating Dir", $target);

            mkpath("$target", 0, 0775);

            addFile('dir', $item , $target);

        }

    }

    else

    {

        #

        #   File copy

        #   If merging then do not overwrite an existing file

        #

        unless ( $opt_merge && -f $target )

        {

            if ( $item =~ m~/descpkg$~ )

            {

                LogFileOp("Rewrite File",$target);

                TransferDescpkg( $item, $target );

                CORE::chmod oct("0664"), $target;

                addFile('file', $item, $target);

            }

            else

            {

                #

                #   Copy file to destination

                #   If the file is a link, then duplicate the link contents

                #   Use: Unix libraries are created as two files:

                #        lib.xxxx.so -> libxxxx.so.vv.vv.vv

                #

                if ( -l $item )

                {

                    my $niceBase = substr ( $item, 1+length ($SRC_ROOT) );

                    if (TestSymlink( $niceBase,$_))

                    {

                        # Don't copy broken Symlinks

                        # Perhaps this should be an error - but is will break escrow builds

                        #

                        LogFileOp("Bad SymLink", $target);

                    }

                    elsif (-f $item)

                    {

                        LogFileOp("Copying Link", $target);

                        my $link = readlink $item;

                        Verbose( "Link: $item, $link");

                        symlink ($link, $target );

                        unless ( $link && -l $target )

                        {

                            Error("Failed to copy link [$item] to [$target]: $!");

                        }

                        addFile('link', $item , $target);

                    }

                }

                elsif (File::Copy::copy($item, $target))

                {

                    LogFileOp("Copying File",$target);

                    #

                    #   Mark the file as executable by all

                    #   Under windows, this is tricky

                    #

                    if ( $Win32 )

                    {

                        my %hash;

                        $hash{Everyone} = Win32::FileSecurity::MakeMask( qw( FULL  ) );

                        Win32::FileSecurity::Set( $target, \%hash );

                    }

                    else

                    {

                        CORE::chmod oct("0775"), $target;

                    }

                    addFile('file', $item, $target);

                }

                else

                {

                    Error("Failed to copy file [$item] to [$target]: $!");

                }

            }

        }

        else

        {

            #

            #   Merging packages

            #   Ensure that the descpkg file is "touched" so that caches

            #   that use this file as a timestamp can be updated

            #

            if ( $item =~ m~/descpkg$~ )

            {

                LogFileOp("Touch File",$target);

                TouchFile( $target ) && Error ( "Failed to touch: $target" );

                addFile('merge', $item, $target);

            }

            else

            {

                #

                #   MD5 digest the files that are being merged

                #   Ignore version_*.h files as these are generated

                #   and may contain different dates and line endings

                #

                #   Don't put the files into 'binmode'

                #   Need to handle some level of Unix/DOS file endings

                #

                #

                my $msg = "Merge Skip File";

                unless ( $target =~ m~/version[^/]*\.h$~ )

                {

                    $msg = "Merge Test File";

                    #

                    #   Compare the two files with an MD5

                    #

                    local *FILE;

                    open(FILE, $target) or Error ("Can't open '$target': $!");

                    binmode FILE, ':crlf';

                    my $target_md5 = Digest::MD5->new->addfile(*FILE)->hexdigest;

                    close FILE;

                    open(FILE, $item) or Error ("Can't open '$item': $!");

                    binmode FILE, ':crlf';

                    my $source_md5 = Digest::MD5->new->addfile(*FILE)->hexdigest;

                    close FILE;

                    unless ( $source_md5 eq $target_md5 )

                    {

                        $msg = "DIFF: Merge Test File";

                        $bad_merge_count ++;

                    }

                    addFile('merge', $item, $target, $target_md5);

                }

                LogFileOp($msg,$target);

            }

        }

    }

}

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

# Function        : CreateDpkgArchiveTarBall 

#

# Description     : Similar to CreateDpkgArchive, but it will create a tar file within the target

#                   directory.

#                   

#                   This is used by the build system to:

#                       1) Greatly speedup the transfer of packages with a very large number of files

#                       2) Remove the need for an multi-filesytem, multi OS atomic lock on the package

#                       

#                   The build system will process the tarball and create the package archive

#                   In doing so it will handle merge errors

#

# Inputs          : 

#

# Returns         : 

#