Subversion Repositories DevTools

Rev

Rev 235 | Rev 263 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed 

#!/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 = $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
        #         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 = substr ( $target, 1+length ($SRC_ROOT) );

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