Subversion Repositories DevTools

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

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

#

# Module name   : create_dpkg.pl

# Module type   : JATS Utility

# Compiler(s)   : Perl

# Environment(s): JATS

#

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

#

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

use JatsEnv;

use DescPkg;

use FileUtils;

# define Global variables

#

my $VERSION = "2.4.1";

my $PROGNAME = "create_dpkg.pl";

our $GBE_MACHTYPE;

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 $e_repository = "";

my $bad_merge_count = 0;

#

#   Option variables

#

my $opt_help = 0;

my $opt_manual = 0;

my $opt_verbose = 0;

my $opt_quiet = 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;

#

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

}

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

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

                "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

                );

    #

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

    #

    #   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

    #

    my $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");

    #

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

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

        unless $DPKG_ROOT;

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

        unless ( -d $DPKG_ROOT );

    $e_repository = ("      *Non Standard archive")

        unless ( $opt_archive eq 'main' );

    #

    #   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

    #

    unless ( $opt_archive eq 'local' || $opt_archive eq 'sandbox'   )

    {

        if ( $ENV{GBE_DPKG_SBOX} )

        {

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

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

                   "is not guaranteed.");

        }

    }

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

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

    #

    #   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]$e_repository");

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

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

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

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

    Information ("")                                if ( $opt_merge || $opt_override );

    Information ("Opt:Override  = Enabled")         if ( $opt_override );

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

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

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

    # done.

    return 1;

}

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

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

        unless ( $opt_override )

        {

            Error ("Package already exists") if ( $opt_quiet );

            if ( !GetYesNo("Do you wish to continue?") )

            {

                Error("Script terminated by user.");

            }

        }

        #

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

    # lets process the files.

    #

    if ( -d $SRC_ROOT )

    {

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

        if ( $bad_merge_count )

        {

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

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

        }

    }

    else

    {

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

              "Check JATS config.");

    }

    #

    #   Transfer of data is complete

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

    #       a multi-machine build have been performed

    #

    #

    my $touchfile = $opt_generic ? "$DPKG_DIR/built.generic" : "$DPKG_DIR/built.$GBE_MACHTYPE";

    LogFileOp("Mark File",$touchfile);

    TouchFile ( $touchfile) && Error("Failed to create file [$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);

        }

    }

    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("0775"), $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 )

                {

                    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]: $!");

                    }

                }

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

                {

                    LogFileOp("Copying File",$target);

                    CORE::chmod oct("0775"), $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" );

            }

            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

                #

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

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

                    close FILE;

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

                    binmode(FILE);

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

                    }

                }

                LogFileOp($msg,$target);

            }

        }

    }

}

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

sub GetYesNo

#

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

{

    my ($question) = @_;

    my ($u_tmp) = "";

    Question ("$question, (default: y) [y,n]: ");

    while ( <STDIN> )

    {

        $u_tmp = $_;

        chomp($u_tmp);

        return 1

            if ( "$u_tmp" eq "" );

        if( $u_tmp =~ /[yn]{1}/i )

        {

            return ( "$u_tmp" eq "y" );

        }

        else

        {

            Question("Please re-enter response? (default: y) [y,n]: ");

        }

    }

}

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

# 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

{

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

          "Check JATS config.") unless ( -d $SRC_ROOT );

    #

    #   Scan the package counting files and folders

    #

    $test_dir_count = 0;

    $test_file_count = 0;

    @test_root_file = ();

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

}

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, $_;

            }

        }

    }

}

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

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

# Main

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

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

# Initialise our world

#

Init();

# Check with the user they want to proceed

#

unless ( $opt_test )

{

    Information("Creating dpkg_archive package:", $DPKG_DIR);

    unless( $opt_override || $opt_quiet )

    {

        if ( !GetYesNo( "Do you wish to continue?" ) )

        {

            Error ("Script terminated by user.");

        }

    }

    # Create the archive and copy the files

    #

    CreateDpkgArchive();

}

else

{

    TestDpkgArchive();

}

# Done

#

Information ("Done.");

exit 0;

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

#   Documentation

#

=pod

=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          - Override 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]test          - Test package. Do not transfer.

    -[no]md5           - Use MD5 comparison of merged files(enabled)

=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 is enabled then any previous version of the target package will

be deleted, without any user intervention.

=item B<-merge>

If this option is enabled then the package will be merged with any existing

package, without any user intervention. 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:

=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<-test>

If this option is enabled the utility will perform initial sanity testing, but

it will not perform the copy.

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

=over 8

=item cache

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

=item local

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

=item main (default)

The location of the target archive will be taken from GBE_DPKG. This is the

default target archive.

=item store

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

=item sandbox

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

=item deploy

The location of the target archive will be taken from GBE_DPLY. This is the

default target archive is a deployment package is detected.

=back

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

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

=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