Subversion Repositories DevTools

#!/usr/local/bin/perl

#

# Copyright (C) 1998-2003 ERG Limited, All rights reserved

#

#========================================================

# **** Source Information ****

#

# Source File Name    : create_dpkg.pl

#

# Source File Type    : Perl file

#

# Original Author(s)  : V.Chatzimichail(vasilic)

#                       D.D.Purdie(dpurdie)

#

# Description / Purpose:

#     This script is used to create a dpkg_archive. 

#

# References:

#    -None-

#

#========================================================

# Include Standard Perl Functions

#

use strict;

use Cwd;

use Getopt::Long;

use File::Basename;

use File::Find;

use File::Path;

use File::Copy;

use Pod::Usage;

use JatsError;

use DescPkg;

use FileUtils;

# define Global variables

#

my $VERSION = "2.4.0";

my $PROGNAME = "create_dpkg.pl";

my $GBE_MACHTYPE = $ENV{'GBE_MACHTYPE'} ||

                die "Need JATS 'GBE_MACHTYPE' environment variable\n";

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

#

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

#

#   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"        => \$opt_manual,            # 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

                );

    #

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

    }

    #

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

            }

        }

    }

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

    }

    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 =~ s/^$SRC_ROOT/$DPKG_DIR/;

    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

        #         replaced or merged. It is not possible to merge some

        #         directories - they must be deleted first.

        #

        if ( ! -d "$target" )

        {

            LogFileOp("Creating Dir", $target);

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

        }

        else

        {

            if ( !$opt_merge &&

                 "$base" !~ m/^lib$/ &&

                 "$base" !~ m/^bin$/ &&

                 "$base" !~ m/^jar$/ )

            {

                LogFileOp("Remove Prev Dir",$target);

                rmtree("$target");

            }

            unless ( -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

            {

                LogFileOp("Merge Skip File",$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 =~ s~^$SRC_ROOT/*~~;

    if ( -d $_ ) {

        $test_dir_count++;

    } else {

        $test_file_count++;

        unless ( $target )

        {

            next if ( $_ eq 'descpkg' );

            next if ( $_ 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

    -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

    -test              - Test package. 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 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.

=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