WebSVN – DevTools – /core_devl/trunk/TOOLS/installpkg.pl

########################################################################
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
#
# Module name   : installpkg.pl
# Module type   : Makefile system
# Compiler(s)   : Perl
# Environment(s): jats
#
# Description:    Install package definition file.
#                 This file is invoked by the BuildPkgArchive directive
#
###############################################################################
#
#   The main purpose of this program is to take packages from dpkg_archive and
#   place them into the build's 'interface' directory in a form that can be used
#   by the rest of the build. This process is complicated by the number of
#   variants in package format. In the pre-JATS2 days the users were encourgaed
#   to dream up there own format for packages. The hard part of this script is
#   dealing with all the known variations. Under JATS2 the default package
#   layout is much easier to implemenet and users generally adhere to it.
#
#   The target 'interface' format is of the form:
#
#           interface/
#               include/
#                   PLATFORM/
#                   PRODUCT/
#                   TARGET/
#               lib/                                    - Should not be populated
#                   PLATFORM/                           - Ideal
#                   PRODUCT/                            - Not practical
#                   TARGET/
#               bin/                                    - Should not be populated
#                   PLATFORM[P|D]/                      - Ideal
#                   PRODUCT[P|D]/                       - Not practical
#                   TARGET[P|D]/
#
#               tools/
#                   bin/
#                       MACHTYPE/
#                   scrips/
#                       MACHTYPE/
#
#               pkg/
#
#               OTHERS
#
#

use strict;
use warnings;

use JatsError;
use DescPkg;
use JatsEnv;

use Cwd;
use File::Basename;
use File::Find;
use File::Path;
use File::Copy;

#
#   Global variables
#
our $GBE_VERBOSE;
our $GBE_MACHTYPE;

my %PLATFORMS = ();
my %dirs_processed = ();
my $symlinks;
my $allow_overwrite = 0;

#...
#
my $INTDIR;                                 # Interface directory (target)
my $BINDIR;                                 # Build directory (Not used)
my $PKG_ROOT=cwd();                         # Package source (CWD)

#
#   Global used for File::Find callback function
#
my $FF_SRC_DIR="";                          # Src subdir base
my $FF_DST_DIR="";                          # Dst subdir base

################################################################################
#
#
#
#   Init the error reporting package
#
ErrorConfig( 'name'    => 'installpkg' );

#
#   Ensure required environment variables are present
#
EnvImport ('GBE_MACHTYPE');
EnvImport ('GBE_VERBOSE');

ErrorConfig( 'verbose' => $GBE_VERBOSE );

#
#   Determine if symlinks are available
#   They may not be available at all, in which case we don't even try
#
$symlinks = eval { symlink("",""); 1 } || 0;

#
#   Report machine information
#
Verbose ("GBE_VERBOSE    : $GBE_VERBOSE" );
Verbose ("GBE_MACHTYPE   : $GBE_MACHTYPE" );
Verbose ("SymLinks       : $symlinks" );
Verbose ("AllowOverwrite : $allow_overwrite" );
Verbose ("Cmd            : @ARGV");

################################################################################
#
#   Parse user arguments
#   Arguments
#       Arg0    - Interface directory
#       Arg1    - Build Directory ( Not Used )
#       Arg2..  - A list of Platform specifications
#                 One for each platform that needs to be processed
#                 Each plaform specification consists of:
#                   --Platform:PlatformName:PlatformParts:Options
#                   Where:
#                       --Platform      - is a leadin switch
#                       PlatformName    - The the target platform
#                       PlatformParts   - A colon seperated list of platform 'parts'
#                                         This consist of: Platform, Product, ... Target
#
$INTDIR = shift @ARGV;
Error("Interface directory not specified") unless( defined $INTDIR );
Error("Interface directory not found: $INTDIR") unless( -d $INTDIR );

$BINDIR = shift @ARGV;
Error("Program directory not specified")   unless( defined $BINDIR );
Error("Program directory not found: $BINDIR") unless( -d $BINDIR );

foreach ( @ARGV )
{
    if ( /^--Platform/ ) {
        Verbose2 ("ARGV = <$_>");
        my ($tmpVar, @platforms) = split /:/, $_;

        my $platform = $platforms[0];
        $PLATFORMS{$platform}{'PARTS'} = \@platforms;

    } elsif ( /^--NoSymlinks/i ) {
        $symlinks = 0;

    } elsif ( /^--AllowOverWrite/i ) {
        $allow_overwrite = 1;

    } else {
        Warning("Unknown argument(ignored): $_");

    }
}

#
# lets review what we have read in
#
foreach my $i ( sort keys %PLATFORMS )
{
    Verbose( "PLATFORMS{$i} = ", join( ',', @{$PLATFORMS{$i}{'PARTS'}} ) );
}

################################################################################
#   Read in the Packages descpkg file
#   The contents are not used. More a sanity test than anything else
#
my $rec = ReadDescpkg ( "descpkg" );
if ( $rec )
{
    Verbose ("Installing the package $rec->{NAME} $rec->{VERSION} $rec->{PROJ}");
}
else
{
    Message ("Installing the package ($PKG_ROOT)");
}


################################################################################
#
#   Lets deal with the top level flat dirs include dir(s)
#
#   For each directory listed in the ModuleList simply duplicate the entire
#   directory to the target location
#
my (@ModuleList) = ( "etc",
                     "swsfiles", 
                     "classes", 
                     "jar",
                     "sar",
                     "sql", 
                     "war", 
                     "scripts", 
                     "infofiles", 
                     "jsp", 
                     "thx", 
                     "rox", 
                     "rpt", 
                     "java", 
                     "achtml", 
                     "epedia", 
                     "doc", 
                     "docs",
                     "devcd",
                     "dat",
                     "mug",
                     "wsdl",                # Store wsdls
                     "include",             # Need the entire directory
                     "MergeModules",        # InstallShield Merge Modules
                     "deployfiles",         # Deployment internals
);

foreach my $i (@ModuleList)
{
    do_dir( $i, $i);
}

################################################################################
#
#   Process a "pkg" directory
#
#   There are two forms of pkg directory
#       1) pkg directory contains ONLY directories of the form pkg.$(GBE_MACHTYPE)
#          These are processed by coying:
#               pkg/pkg.GBE_MACHTYPE -> pkg
#
#       2) pkg without any pkg.* subdirs
#          Copy the entire subtree
#
#       3) Mixture
#          Cannot handle
#
#
my (@ModuleList2) =  ( "pkg" );

foreach my $i (@ModuleList2)
{
    #
    #   Determine the mode of operation
    #   Scan files in the directory for known format
    #
    my @dir_list = glob( "$i/*" );
    my $pkg_count = 0;
    my $other_count = 0;

    foreach ( @dir_list )
    {
        if ( m~/$i\.~ )
        {
            $pkg_count++;
        }
        else
        {
            $other_count++;
        }
    }

    if ( $pkg_count && $other_count )
    {
        Warning( "Cannot handle mixed \"${i}\" directory",
                 "Only machine directory will be copied" );
    }

    if ( $pkg_count )
    {
        #
        #   pkg/pkg.GBE_MACHTYPE -> pkg
        #
        do_dir("$i/$i\.$GBE_MACHTYPE", $i, );
    }
    else
    {
        #
        #   pkg -> pkg
        #
        do_dir($i, $i);
    }
}


################################################################################
#
#   Deal with the complex directories:
#           bin,
#           lib,
#           inc
#           include
#
#   Look for, and process the first of:
#
#   for each item in module list we shall process (if it exists) 
#   the following variants:
#
#       module.<platform>
#       module.<product>
#       module.<target>
#
#       module/<platform>
#       module/<product>
#       module/<target>
#
#   The platform, product and target are all passed on the command
#   line.  They are configured in the build.pl using the BuildProduct
#   directives.
#
#   For the bin dirs we need to consider the 'Debug' and 'Prod' 
#   build types as well as some cots packages that are both.
#
#   For the bin and lib dirs we also need to consider the format:
#       bin/bin.<platform>
#       lib/lib.<platform>
#
#

my %ModuleList3 =   (
                    "lib"           => 1,       # Copy root files
                    "inc"           => 1,       # Copy root files
                    "bin"           => 0,       # Should not be any root files
                    "include"       => 0,       # Root files already processed
                    );

foreach my $i (sort keys %ModuleList3)
{
    my $mDstDir;
    my $bType;
    my $mPart;
    my $mode =  $ModuleList3{$i};

    Verbose ("Processing: [Mode:$mode] $i");

    foreach my $j ( sort keys %PLATFORMS )
    {
        foreach $bType ( 'D', 'P', '' )
        {
            foreach $mPart ( sort @{$PLATFORMS{$j}{'PARTS'}} )
            {
                $mDstDir = "$i/$mPart$bType";

                #
                #   Try various combinations of directories to catter for
                #   all the crazy legacy combinations
                #
                do_dir("$i.$mPart$bType"    ,$mDstDir);
                do_dir("$i/$mPart$bType"    ,$mDstDir);
                do_dir("$i/$i.$mPart$bType" ,$mDstDir);
            }
        }
    }

    #
    # Transfer files in the root directory if required
    #
    # Now lets us deal with the simple case
    # here we are only interested in the top level files
    # sub-dirs are handles separately.
    #
    if ( ($mode & 1) && -d $i)
    {
        Verbose ("Processing: $i - Copy root directory files");
        do_FilesOnly ( $i );
    }
}

################################################################################
#   Deal with toolset extensions
#   These are JATS extensions that are platform specific and not a function of
#   the target. ie: If we are building on a 'win32' piece of hardware then we
#   need the win32 tools, independant of the target platforms
#
#   Use GBE_MACHTYPE to determine correct subdirs
#
my %ModuleList4 =   (
                    "tools/bin"             => 3,       # Copy GBE_MACHTYPE + root files
                    "tools/scripts"         => 4,       # Copy Subdir
                    "gbe"                   => 4,       # JATS General Build Environment
                    );
foreach my $i (sort keys %ModuleList4)
{
    my $mode = $ModuleList4{$i};
    Verbose ("Processing: $i, Machine Type: $GBE_MACHTYPE, Mode: $mode");

    #
    #   Transfer a machine specfic subdir
    #
    if ( $mode & 1 )
    {
        do_dir("$i.$GBE_MACHTYPE", "$i/$GBE_MACHTYPE") ;
        do_dir("$i/$GBE_MACHTYPE", "$i/$GBE_MACHTYPE") ;
    }

    #
    # Transfer files in the root directory if required
    #
    # Now lets us deal with the simple case
    # here we are only interested in the top level files
    # sub-dirs are handles separately.
    #
    if ( ($mode & 2) && -d $i)
    {
        Verbose ("Processing: $i - Copy root directory files");
        do_FilesOnly ( $i );
    }

    #
    #   Copy the entire subtree
    #   Used for non-machine specifc directories
    #
    if ( ($mode & 4) && -d $i)
    {
        Verbose ("Processing: $i - Copy directory tree");
        do_dir($i, $i) ;
    }
    
}



# done
exit 0;


#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# subroutines
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# Function        : do_FilesOnly
#
# Description     : Copy all files in the current directory to the target
#                   directory. Assume that the target directory will be called
#                   the same as the source directory
#
#                   Do not process sub directories. These may be handled elsewhere
#
# Inputs          : $dir        - Src and Dst subdir name
#
# Returns         : Nothing
#
sub do_FilesOnly
{
    my ($dir) = @_;
    Verbose2 ("do_FilesOnly: dir=[$dir]");

    # define the type of dir we are working on

    my ($srcDir) = "$PKG_ROOT/$dir";
    my ($dstDir) = "$INTDIR/$dir";

    Verbose2("do_FilesOnly: INTDIR=[$INTDIR]");
    Verbose2("do_FilesOnly: dstDir=[$dstDir]");
    Verbose2("do_FilesOnly: srcDir=[$srcDir]");
    
    #
    # Create the interface dir if it does not exists
    #
    mkpath ( $dstDir, $GBE_VERBOSE, 0775) unless ( -d $dstDir );

  
    # Have a valid dst value we now need to get a hold of all the
    # lib scripts files.
    #
    local *DIR;
    opendir ( DIR, $srcDir ) or  Error ("Failed to open dir [$srcDir]");

    #
    # Process all directory entries
    #
    while (defined(my $_item = readdir(DIR)))
    {
        next if ( $_item eq '.' );
        next if ( $_item eq '..' );

        my $srcFile = "$srcDir/$_item";
        if ( -d $srcFile )
        {
            Verbose2 ("NOT processing dir item [$srcFile]");
        }
        else
        {
            FileLinkCopy ($srcFile, "$dstDir/$_item" );
        }
    }
    closedir DIR;


    # done
    return 1;
}
#-------------------------------------------------------------------------------
# Function        : do_dir
#
# Description     : Transfer an entire subdirectory tree
#                   Can detect that the tree has already been processed
#
# Inputs          : $src            - Source subdir (within PKG_ROOT)
#                   $dst            - Target path (within INTDIR)
#
# Returns         : Nothing
#
sub do_dir
{
    my ($src, $dst) = @_;
    Verbose2 ("do_dir: src=[$src], dst=[$dst]");

    #
    #   Prevent processing of the same source directory by multiple
    #   operations. Need only do them once
    #
    if ( $dirs_processed{$src} )
    {
        Verbose2 ("do_dir: Already processed");
        return 1;
    }

    $dirs_processed{$src} = 1;

    #
    #   Only if it exists
    #   Do the test in this function to simplify processing
    #
    unless ( -d $src )
    {
        Verbose2 ("do_dir: Directory not found");
        return 0;
    }

    #
    #   Setup values for the File::Find callback
    #   These need to be global due to the way that File::Find works
    #
    $FF_SRC_DIR = "$PKG_ROOT/$src";
    $FF_DST_DIR = "$INTDIR/$dst";

    Verbose2("do_dir: FF_SRC_DIR=[$FF_SRC_DIR]");
    Verbose2("do_dir: FF_DST_DIR=[$FF_DST_DIR]");

    #
    #   Handle directories that are really symbolic links
    #   This will only occur on system that handle symlinks
    #   May not always want to use symlinks.
    #
    if ( $symlinks && -l $FF_SRC_DIR )
    {
        Verbose2("do_dir: symlink $FF_SRC_DIR,$FF_DST_DIR");
        unless (symlink $FF_SRC_DIR, $FF_DST_DIR  )
        {
            Error("Failed to create symlink",
                  "Src: $FF_SRC_DIR",
                  "Dst: $FF_DST_DIR");
        }
        return 1;
    }

    #
    # Create the interface dir if it does not exists
    #
    mkpath ( $FF_DST_DIR, $GBE_VERBOSE, 0775)
        unless ( -d $FF_DST_DIR );

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

    # done
    return 1;
}

#-------------------------------------------------------------------------------
sub pkgFind2
#
# Description     : Callback function: Process a directory
#                   Target name is NOT the same as the source name
#
#                   The function is called for each file to be processed
#                   The name of the file is extracted from $File::Find::name
#
#                   Processes
#                       Directory: Create same directory in the target
#                       File     : Link/Copy file to the target
#
# Inputs          : None passed
#                   Globals are used
#
# Returns         :
#
#------------------------------------------------------------------------------
{
    Verbose2("pkgFind2:");

    my $item = "$File::Find::name";                     # Full source path
    my $dest_path = $FF_DST_DIR . substr ( $item, length ($FF_SRC_DIR) ); # Full destination path

    Verbose2 ("---- Src = [$item]");
    Verbose2 ("---- Dst = [$dest_path]");
    if ( -d $item )
    {
        #
        #   Create a directory
        #
        mkpath ( $dest_path, $GBE_VERBOSE, 0775) unless( -d $dest_path );

        #
        #   Flag the subdir as being processed
        #   Prevent multiple copy operations (and warnings)
        #
        my $subdir = substr ( $item, 1 + length ($PKG_ROOT) );
        $dirs_processed{$subdir} = 1;

    }
    else
    {
        #
        #   Copy/Link the file
        #
        FileLinkCopy ( $item, $dest_path);
    }
    return 1;
}

#-------------------------------------------------------------------------------
# Function        : FileLinkCopy
#
# Description     : Copy a file to a destination
#                   If possible create a symlink (Not always be possible)
#                   If the file is copied, then chmod it.
#
# Inputs          : $srcFile                 - Source path (Full)
#                   $dstFile                 - Destination path (Full)
#
#
# Globals         : symlinks                - Set if Symlinks are available
#                                             Will be cleared if the operation
#                                             failed, forcing copy
#
# Returns         : Nothing
#                   Will terminate, with a message, on error
#
sub FileLinkCopy
{
    my ($srcFile, $dstFile ) = @_;
    my $done;
    (my $file = $srcFile) =~ s~.*/~~;       # Filename. Just to be pretty

    #
    #   Delete target file. If it exists
    #       Don't warn if we are allowed to overwrite files
    #       This is done for sandbox and local_archive packages
    #
    if ( -f $dstFile )
    {
        unlink ($dstFile );
        Message("overwriting existing dpkg_archive item [$file] --> [$dstFile]\n")
            unless ( $allow_overwrite );
    }

    #
    #   Try a symlink first
    #
    if ( $symlinks )
    {
        Verbose("linking file [$file] --> [$dstFile]...ok");
        unless (symlink ($srcFile, $dstFile)  )
        {
            #
            #   Symlink has failed
            #   Flag: Don't symlink anymore
            #
            $symlinks = 0;
            Verbose ("Failed to create symlink from: [$file] --> [$dstFile]");
        }
        else
        {
            $done = 1;
        }
    }

    #
    #   Try a copy
    #
    unless ( $done )
    {
        if(File::Copy::copy($srcFile, $dstFile))
        {
            Verbose("copying file [$file] --> [$dstFile]...ok");
            CORE::chmod oct("0755"), $dstFile;
        }
        else
        {
            Error("copying file [$file] --> [$dstFile]: $!");
        }
    }
}

############ EOF ###############################################################
Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/installpkg.pl – Rev 4466
