Subversion Repositories DevTools

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

# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.

#

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

        unlink $dstFile; 

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