Subversion Repositories DevTools

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

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

#

#   Option variables

#

my $opt_help = 0;

my $opt_manual = 0;

my $opt_verbose = 0;

my $opt_quiet = 0;

my $opt_delete = 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',

                   );

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

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

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

    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

                "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

    #

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

}

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

# 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")        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$/ )

    {

        #

        #   Only grab the first one

        #

        if ( $DESCPKG_FILE )

        {

            Warning ("Package contains multiple descpkg files");

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

    #

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