Subversion Repositories DevTools

Rev

Rev 4688 | Blame | Compare with Previous | Last modification | View Log | RSS feed

########################################################################
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
#
# Module name   : create_dpkg2.pl
# Module type   : Makefile system
# Compiler(s)   : Perl
# Environment(s): jats
#
# Description   : This script is used to create a dpkg_archive.
#                 Based on create_dpkg with following changes
#                   * No user interaction
#                   * Generates files list for ReleaseNote integration 
#
# 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;

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

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


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

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# Subroutines
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------

#------------------------------------------------------------------------------
sub LogFileOp
#
# Description:
#       This sub-routine is used to generate a consistent informational log
#------------------------------------------------------------------------------
{
    my ($opr, $file) = @_;
    $file =~ s/$DPKG_ROOT/DPKG/;

    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~$DPKG_DIR~~;
    $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 patch 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          : 
#
# Returns         : 
#
sub writeFileInfo
{
    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 ? "$DPKG_DIR/built.files.generic.xml" : "$DPKG_DIR/built.files.$GBE_HOSTNAME.xml";

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


    #
    #   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', "");

    #
    #   Determine the target archive
    #   The default archive is GBE_DPKG, but this may be changed
    #
    $opt_archive = 'main' unless ( $opt_archive );
    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" );

    #
    #   Detect NoBuild marker
    #   This will bypass most of the operation of this package
    #
    if ( -f 'noBuild.gbe' )
    {
        Verbose ("No Build Marker file found");
        Error("Use of noBuild marker should only be done by a build daemon")
            unless ( $GBE_ABT );

        $SRC_ROOT = '';
        $DPKG_NAME = 'pkg';
        $DESCPKG_FILE = 'descpkg';
        $PKG_BASE =$CWD_DIR;
        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
{
    # 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.");
    }

    #
    #   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
    #
    $DPKG_DIR = "$DPKG_ROOT/$DPKG_NAME/$DPKG_VERSION";
    
    #
    #   Information for the user
    #
    Information ("---------------------------------------------------------------");
    Information ("Dpkg archive creation tool...");
    Information ("Version: $VERSION");
    Information ("");
    Information ("Information:");
    Information ("Working dir   = [$CWD_DIR]");
    Information ("Package Root  = [$SRC_ROOT]");
    Information ("Repository    = [$DPKG_ROOT]");
    Information ("                *Non Standard archive") unless $opt_archive eq 'main';
    Information ("Target dir    = [$DPKG_DIR]");
    Information1("DPKG_NAME     = [$DPKG_NAME]");
    Information1("DPKG_VERSION  = [$DPKG_VERSION]");
    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);
    Information ("Opt:Delete    = Enabled")         if ( $opt_delete );
    Information ("Opt:Merge     = Enabled")         if ( $opt_merge );
    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
    #   fromm 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' )
    {
        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~$PKG_BASE/~~;
            Verbose ("Multiple descpkg files:", $item );
            return;
        }

        $DESCPKG_FILE = $item;
        my($dir)= File::Basename::dirname($item);
        $DPKG_NAME = File::Basename::basename($dir);
        $SRC_ROOT = $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_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 = $opt_generic ? "$DPKG_DIR/built.generic" : "$DPKG_DIR/built.$GBE_HOSTNAME";

    #
    #   Create a string to be appended to the 'built' file
    #   Comma seperated list of (possibly) useful info
    #       Date-Time ( Local and GMT)
    #       machine type, machine name and the user
    #       GBE_ABT value
    #
    my $built_info = localtime() ."," . gmtime() . " GMT,$GBE_MACHTYPE,$GBE_HOSTNAME,$USER,$GBE_ABT";
    LogFileOp("Mark File",$touchfile);
    FileAppend ( $touchfile, $built_info );
    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;
    }

    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 )
                {
                    if (-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);
                    }
                    else
                    {
                        # Don't copy broken Symlinks
                        # Perhaps this should be an error - but is will break escrow builds
                        #
                        LogFileOp("Broken SymLink", $target);
                        push @bad_symlinks, substr ( $item, 1+length ($SRC_ROOT) );
                    }
                }
                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        : TestDpkgArchive
#
# Description     : Test the structure of the source achive
#                   Ensure that it has some files
#                   Warn if files are present in the root directory
#
# Inputs          : None
#
# Returns         : Warnings
#
my $test_dir_count = 0;
my $test_file_count = 0;
my @test_root_file = ();
sub TestDpkgArchive
{
    $test_dir_count = 0;
    $test_file_count = 0;
    @test_root_file = ();

    if ( $SRC_ROOT ne '' )
    {
        Error("Failed to find dir [$SRC_ROOT]",
              "Check JATS config.") unless ( -d $SRC_ROOT );


        #
        #   Scan the package counting files and folders
        #
        File::Find::find( \&pkgFind3, $SRC_ROOT );
    }

    Information ("Package contains:",
                 "Files: $test_file_count",
                 "Dirs: $test_dir_count",
                 );
    #
    #   There shouldn't be any files in the root directory
    #   other than the descpkg and incpkg.
    #
    Warning ("Unexpected files in package root:", @test_root_file)
        if ( @test_root_file  );

    Error ("Bad symbolic links found:", @bad_symlinks)
            if ( @bad_symlinks );

}

sub pkgFind3
{

    #
    #   Calculate the target directory name
    #
    my $target = $File::Find::dir;
    $target = substr ( $target, length ($SRC_ROOT) );
    $target =~ s~^.~~;

    if ( -d $_ ) {
        $test_dir_count++;
    } else {
        $test_file_count++;
        unless ( $target )
        {
            #
            #   Locate files in the package root directory that
            #   are not expected to be there.
            #
            unless ((  $_ eq 'descpkg' ) || ( $_ eq 'incpkg' ))
            {
                push @test_root_file, $_;
            }
        }
        if (-l $_ && ! -f $_)
        {
            push @bad_symlinks, substr ( $File::Find::name, 1+length ($SRC_ROOT) );
        }
    }
}

# ---------------------------------------------------------
# ---------------------------------------------------------
# Main
# ---------------------------------------------------------
# ---------------------------------------------------------


# Initialise our world
#
Init();
CheckDescPkg();
ShowInfo();
unless ($opt_info)
{
    unless ( $opt_test )
    {
        Information("Creating dpkg_archive package:", $DPKG_DIR);
        CreateDpkgArchive();
        writeFileInfo();
    }
    else
    {
        Information("Testing user package.");
        TestDpkgArchive();
    }
}

# Done
#
Information ("Done.");
exit 0;


#-------------------------------------------------------------------------------
#   Documentation
#

=pod

=for htmltoc    SYSUTIL::

=head1 NAME

create_dpkg - Create a dpkg_archive entry

=head1 SYNOPSIS

 jats create_dpkg [options]

 Options:
    -help              - Brief help message
    -help -help        - Detailed help message
    -man               - Full documentation
    -quiet             - Suppress progress messages, then warning messages
    -verbose           - Display additional progress messages
    -override          - Deprecated option
    -delete            - Delete any previous version of the package
    -[no]merge         - merge with existing version of the package
    -archive=name      - Specify archive (cache, local, main, store, sandbox, deploy)
    -pname=name        - Ensure package is named correctly
    -pversion=version  - Ensure package version is correct
    -generic           - Create a built.generic file
    -[no]md5           - Use MD5 comparison of merged files(enabled)
    -[no]test          - Test package. Do not transfer.
    -[no]info          - Display packaging info. Do not transfer.

=head1 OPTIONS

=over 8

=item B<-help>

Print a brief help message and exits.

=item B<-help -help>

Print a detailed help message with an explanation for each option.

=item B<-man>

Prints the manual page and exits.

=item B<-quiet>

This option will suppress almost all of the progress messages, except for a single
copy message. It is intended to be used when the program is called from another
script.

=item B<-override>

If this option has been deprecated. It has no effect.

It is still present to preserve backward compatability with the automated 
build system.

=item B<-delete>

If this option is enabled then any previous version of the target package will
be deleted.

=item B<-merge>

If this option is enabled then the package will be merged with any existing
package. This option is used by the auto build tool to assemble multi-machine 
packages in dpkg_archive.

=item B<-archive=name>

This option specifies the destination archive to be used. The following names
are supported:

=over 8

=item cache

The location of the target archive will be taken from C<GBE_DPKG_CACHE>.

=item local

The location of the target archive will be taken from C<GBE_DPKG_LOCAL>.

=item main (default)

The location of the target archive will be taken from C<GBE_DPKG>. This is the
default target archive.

=item store

The location of the target archive will be taken from C<GBE_DPKG_STORE>.

=item replica

The location of the target archive will be taken from C<GBE_DPKG_REPLICA>.

=item sandbox

The location of the target archive will be taken from C<GBE_DPKG_SBOX>.

=item deploy

The location of the target archive will be taken from C<GBE_DPLY>. This is the
default target archive is a deployment package is detected.

=back

=item B<-pname=name>

If this option is provided, the utility will ensure that the package is named
correctly.

=item B<-pversion=version>

If this option is provided, the utility will ensure that the package version is
that expected.

=item B<-generic>

This option will create a built.generic file, instead of one based on the machine
that actually built the package. This is used by the AutoBuilder toolchain.

=item B<-[no]md5>

If package builds are being merged then a validity check is performed using
an MD5 digest over the current and the existing file.

By default, it is an error for the user file to differ from the merged file.

This option disabled the error. The test is still done and the results are
reported.

=item B<-test>

If this option is enabled the utility will perform initial sanity testing, but
it will not perform the copy.

=item B<-[no]info>

This option will cause the program to display information about the packaging 
process and then exit. 

No data will be transferred to the archive.

=back

=head1 DESCRIPTION

This utility program is used to transfer a package that has been built into
dpkg_archive. The package is then available for general consumption.

The utility will perform several operations in the transfer process. These incude:

=over 4

=item * 

Create a tag file to indicate the machine that has performed the transfer

=item * 

Create an XML file of files that have been transferred. This file contains information
used by the build system when it releases the package, including: name, size and MD5SUM.

=item *

Detect file conflicts when different builds are merged into a single package. Header files are 
allowed to differ in line ending style, but other files must not conflict. The package will not be 
reproducible if file conflicts exist.

=item *

Suppress dead symbolic links. A valid symlink will be preserved, but invalid links will be 
removed from the transferred image.

=back

=head2 PACKAGE LOCATION

The utility will locate a package by examining the following directores for
the package description file(descpkg).

=over 8

=item ./build/deploy

This format is generated by the deployment builds. The default target archive
will be taken from the environment variable GBE_DPLY.

=item ./pkg

This format is generated by JATS builds.

=item ./build/pkg

This format is generated by ANT builds.

=back

The program should be run in the same directory as the build control files as
the package subdirectory will be created in that directory.

=head1 EXAMPLE

=head2 jats create_dpkg

This will locate a generated package and install it into the dpkg_archive repository.

=cut