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

#! /usr/bin/perl
########################################################################
# Copyright (C) 1998-2004 ERG Limited, All rights reserved
#
# Module name   : jats_cbuilder.pl
# Module type   : Makefile system
# Compiler(s)   : n/a
# Environment(s):
#
# Description   : A script to build a collection of packages in the
#                 same sandbox. This script will:
#
#                   Determine the packages in the sandbox
#                   Determine the build order of the packages
#                   Build the packages in the correct order
#                   Make the packages in the correct order
#
#                 The script will allow for:
#                   The creation of a sandbox
#                   The addition of packages to the sandbox
#                   Removal of packages from the sandbox
#
#
#                 Command syntax (basic)
#                   jats sandbox <command> (options | actions)@
#
#                 Commands include:
#                   create              - Create a sandbox
#                   delete              - Delete a sandbox
#
#                   add package_name    - Add a package to the sandbox
#                   rm  package_name    - Remove a package from the sandbox
#
#                   build               - Build all packages in the sandbox
#                   make                - make all packages in the sandbox
#
#......................................................................#

require 5.6.1;
use strict;
use warnings;
use JatsError;
use JatsSystem;
use FileUtils;
use BuildName;
use JatsVersionUtils;


use File::Find;
use Pod::Usage;                             # required for help support
use Getopt::Long qw(:config require_order); # Stop on non-option
my $VERSION = "1.0.0";                      # Update this

#
#   Options
#
my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
my $opt_help = 0;
my $opt_manual = 0;

#
#   Globals - Provided by the JATS environment
#
my $USER         = $ENV{'USER'};
my $UNIX         = $ENV{'GBE_UNIX'};
my $HOME         = $ENV{'HOME'};
my $GBE_SANDBOX  = $ENV{'GBE_SANDBOX'};
my $GBE_DPKG_SBOX= $ENV{'GBE_DPKG_SBOX'};

#
#   Globals
#
my @build_order = ();                     # Build Ordered list of entries
my %extern_deps;                          # Hash of external dependancies
my %packages;                             # Hash of packages


#-------------------------------------------------------------------------------
# Function        : Mainline Entry Point
#
# Description     :
#
# Inputs          :
#
my $result = GetOptions (
                "help+"         => \$opt_help,              # flag, multiple use allowed
                "manual"        => \$opt_manual,            # flag, multiple use allowed
                "verbose+"      => \$opt_verbose,           # flag, multiple use allowed
                );

                #
                #   UPDATE THE DOCUMENTATION AT THE END OF THIS FILE !!!
                #

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

#
#   Configure the error reporting process now that we have the user options
#
ErrorConfig( 'name'    => 'SANDBOX',
             'verbose' => $opt_verbose );

#
#   Validate user options
#

#
#   Parse the user command and decide what to do
#
#
my $cmd = shift @ARGV || "";
help(1)                                 if ( $cmd =~ m/^help$/ || $cmd eq "" );
create_sandbox()                        if ( $cmd =~ m/^create$/ );
info(@ARGV)                             if ( $cmd =~ m/^info$/ );
cmd(@ARGV)                              if ( $cmd =~ m/^cmd$/ );

Error ("Unknown sandbox command: $cmd");
exit 1;


#-------------------------------------------------------------------------------
#
#   Give the user a clue
#
sub help
{
    my ($level) = @_;
    $level = $opt_help unless ( $level );

    pod2usage(-verbose => 0, -message => "Version: ". $VERSION)  if ($level == 1 );
    pod2usage(-verbose => $level -1 );
}

#-------------------------------------------------------------------------------
# Function        : create_sandbox
#
# Description     : create a sandbox in the current current directory
#
# Inputs          : None
#
#
sub create_sandbox
{
    Error ("Cannot create a sandbox within a sandbox",
           "Sandbox base is: $GBE_SANDBOX" ) if ( $GBE_SANDBOX );
    mkdir ('sandbox_dpkg_archive') || Error ("Cannot create the directory: sandbox_dpkg_archive") ;
    exit  0;
}

#-------------------------------------------------------------------------------
# Function        : info
#
# Description     : Display Sandbox information
#
# Inputs          : Command line args
#                   -v  - Be more verbose
#
# Returns         : Will exit
#
sub info
{
    #
    #   Allow user to specify verboseness as an argument
    #
    foreach  ( @_ )
    {
        $opt_verbose++ if ( m/^-v/ )
    }

    #
    #   Determine Sandbox information
    #   Populate global variables
    #
    calc_sandbox_info();

    #
    #   Display information
    #
    Message ("Base: $GBE_SANDBOX");
    Message ("Archive: $GBE_DPKG_SBOX");

    Message ("Build Order");
    foreach my $fe ( @build_order )
    {
        Message( "    Level:" . $fe->{level} . " Name: " . $fe->{pname} );
        Message( DisplayPath ("        Path: $fe->{dir}" )) if $opt_verbose;

        if ( $opt_verbose )
        {
            foreach my $idep ( sort keys %{$fe->{ideps}} )
            {
                my ($ppn,$pps) = split( $; , $idep);
                Message ("        I:$ppn.$pps");
            }

            foreach my $edep ( sort keys %{$fe->{edeps}} )
            {
                my ($ppn,$pps) = split( $; , $edep);
                my $pv = $fe->{edeps}{$edep};
                Message ("        E:$ppn $pv.$pps");
            }
            
        }
    }

    Message("External Dependancies");
    foreach my $de ( sort keys %extern_deps )
    {
        my ($pn,$ps) = split( $; , $de);
        my @vlist = keys %{$extern_deps{$de}};
        my $flag = $#vlist ? '*' : ' ';
        foreach my $pv ( @vlist )
        {
            Message ("   $flag$pn $pv.$ps");
            if ( $opt_verbose )
            {
                foreach my $pkg ( @{$extern_deps{$de}{$pv}} )
                {
                    my ($ppn,$pps) = split( $; , $pkg);
                    Message ("        U:$ppn.$pps");

                }
            }
        }
    }

    if ( $opt_verbose > 2 )
    {
        DebugDumpData( "extern_deps", \%extern_deps);
        DebugDumpData( "build_order", \@build_order);
        DebugDumpData( "packages", \%packages);
    }
    exit (0);
}

#-------------------------------------------------------------------------------
# Function        : calc_sandbox_info
#
# Description     : Examine the sandbox and determine all the important
#                   information
#
# Inputs          : None
#
# Returns         : Will exit if not in a sandbox
#                   Populates global variables
#                       @build_order - build ordered array of build entries
#
sub calc_sandbox_info
{
    #
    #   Start from the root of the sandbox
    #
    Error ("Command must be executed from within a Sandbox") unless ( $GBE_SANDBOX );
    chdir ($GBE_SANDBOX) || Error ("Cannot chdir to $GBE_SANDBOX");

    #
    #   Locate all packages within the sandbox
    #   These will be top-level directories - one per package
    #
    my @dirlist;
    my @build_list;
    foreach ( glob("*") )
    {
        next if ( m~^\.~ );
        next if ( m~dpkg_archive$~ );
        next unless ( -d $_ );
        Verbose ("Package discovered: $_");
        push @dirlist, $_;

        #
        #   Locate the build files in each package
        #
        my @blist = locate_build_files( $_ );
        Warning ("Package does not have build files: $_") unless ( @blist );
        Warning ("Package has multiple build files: $_") if ( $#blist > 0 );

        foreach my $fe ( @blist )
        {
            push @build_list, $fe;
        }
    }

    #
    #   Process each build file and extract
    #       Name of the Package
    #       Dependency list
    #   Build up a hash of dependence information
    #

#    Verbose "Packages Found: @dirlist\n";

    my %depends;
    foreach my $fe ( @build_list )
    {
        Verbose( DisplayPath ("Build file: " . $fe->{dir} . " Name: " . $fe->{file} ));
        process_build_file ( $fe );
#        DebugDumpData ("fe", $fe );

        #
        #   Add into dependency struct
        #
        $depends{$fe->{package}}{depends} = $fe->{depends};
        $depends{$fe->{package}}{entry} = $fe;
    }

    #
    #   Determine the build order
    #
    @build_order = ();
    my $more = 1;
    my $level = 0;

    #
    #   Remove any dependancies to 'external' packages
    #   These will not be met internally and can be regarded as constant
    #
    foreach my $key ( keys %depends )
    {
        foreach my $build ( keys( %{$depends{$key}{depends}} ))
        {
            unless (exists $depends{$build})
            {
                push @{$extern_deps{$build}{$depends{$key}{depends}{$build}}}, $key;
                $depends{$key}{entry}{edeps}{$build} = $depends{$key}{depends}{$build};
                delete ($depends{$key}{depends}{$build}) ;
                Verbose2( "Not in set: $build");
            }
            else
            {
                $depends{$key}{entry}{ideps}{$build} = 1;
            }
        }
    }
    while ( $more )
    {
        $more = 0;
        $level++;
        my @build;

        #
        #   Locate packages with no dependencies
        #
        foreach my $key ( keys %depends )
        {
            next if ( keys( %{$depends{$key}{depends}} ) );
            push @build, $key;
        }

        foreach my $build ( @build )
        {
            $more = 1;
            my $fe = $depends{$build}{entry};
            $fe->{level} = $level;
            $packages{$build} = $fe;
            push @build_order, $fe;
            delete $depends{$build};
            delete $fe->{depends};                          # remove now its not needed
        }

        foreach my $key ( keys %depends )
        {
            foreach my $build ( @build )
            {
                delete $depends{$key}{depends}{$build};
            }
        }
    }

    #
    #   Just to be sure to be sure
    #
    Error( "Internal algorithm error: Bad dependancy walk") if ( keys %depends );

#    DebugDumpData ("Order", \@build_order);
}

#-------------------------------------------------------------------------------
# Function        : cmd
#
# Description     : Execute a command in all the sandboxes
#                       Locate the base of the sandbox
#                       Locate all packages in the sandbox
#                       Locate all build files in each sandbox
#                       Determine build order
#                       Issue commands for each sandbox in order
#
# Inputs          : Arugments passed to jats build
#
# Returns         : Will exit
#
sub cmd
{
    my @cmds = @_;
    #
    #   Determine Sandbox information
    #   Populate global variables
    #
    calc_sandbox_info();
    foreach my $fe ( @build_order )
    {
        my $dir = $fe->{dir};
        Message( "Level:" . $fe->{level} . " Name: " . $fe->{pname} ,
                  DisplayPath ("        Path: $fe->{dir}" ));

        my $result = JatsCmd( "-cd=$dir @cmds");
        Error ("Cmd faulure") if ( $result );
    }

    exit 0;
}

#-------------------------------------------------------------------------------
# Function        : parse_build_file
#
# Description     : Parse a build file and extract useful information
#
#
# Inputs          : fe  - Reference to a build entry
#
# Returns         : Populates data into the build entry
#
sub process_build_file
{
    my ($fe) = @_;
    Debug ("Processing build file: " . $fe->{dir} );
    my $infile =  $fe->{dir} . "/" . $fe->{file};

    #
    #   Open the input and output files
    #
    my $build_info;
    my $release_name;
    my $release_version;

    open ( INFILE, "<$infile" ) || Error( "Cannot open $infile" );
    while ( <INFILE> )
    {
        next if ( m~^\s*#~ );            # Skip comments
        #
        #   Process BuildName
        #
        if ( m~\s*BuildName[\s\(]~ )
        {
            #   Build names come in many flavours, luckily we have a function
            #
            m~\(\s*(.*?)\s*\)~;
            my @args = split /\s*,\s*/, $1;
            my $build_info = parseBuildName( @args );
            $fe->{package} = join $;, $build_info->{BUILDNAME_PACKAGE},$build_info->{BUILDNAME_PROJECT};
            $fe->{pname}= $build_info->{BUILDNAME};
        }

        #
        #   Process BuildPkgArchive and LinkPkgArchive
        #   Retain the Name and the ProjectSuffix and the version
        #
        if ( m/^LinkPkgArchive/ or m/^BuildPkgArchive/ )
        {
            m/['"](.*?)['"][^'"]*['"](.*?)['"]/;

            my ( $package, $rel, $suf, $full ) = SplitPackage( $1, $2 );
            $fe->{depends}{$package,$suf} = $rel;
        }
    }
    close INFILE;
}


#-------------------------------------------------------------------------------
# Function        : locate_build_files
#
# Description     : Locate all potential buildfiles in the view
#
# Inputs          : base_dir     - Start directory
#
# Returns         : An array of build file entries
#                   Each entry in the array is a hash
#                       dir =>  Directory to the build files
#                       file => Name of the build file
#
my @located_files;
my $locate_files_base;
sub locate_build_files
{
    my ( $base_dir) = @_;

    #
    #   Locate build files ( JATS and ANT )
    #
    sub locate_build_files_wanted
    {

        my $dir = "$File::Find::dir";
        my $file = $_;
        my $arg = "$dir/$file";

        return if ( -d $arg );

        #
        #   Detect a JATS build file
        #
        if ( $file eq "build.pl"  )
        {
            push @located_files, { 'dir' =>$dir, 'file' => $file };
            return;
        }

        #
        #   Detect ANT {packagename}depends.xml file
        #
        if ( $file =~ m/(.+)depends.xml$/ )
        {
            if ( -f $1 . ".xml" )
            {
                push @located_files, { 'dir' =>$dir, 'file' => $file, 'ant' => $1 . ".xml" };
                return;
            }
        }
    }

    @located_files = ();
    $locate_files_base = $base_dir;
    File::Find::find ( \&locate_build_files_wanted, $base_dir );
    return @located_files;
}


#-------------------------------------------------------------------------------
#   Documentation
#

=pod

=head1 NAME

jats_sandbox - Build in a Development Sandbox

=head1 SYNOPSIS

  jats sandbox [options] [comamnds]

 Options:
    -help              - brief help message
    -help -help        - Detailed help message
    -man               - Full documentation

 Commands:
    help                - Same as -help
    create              - Create a sandbox in the current directory
    info [-v]           - Sandbox information. -v: Be more verbose
    cmd                 - Do commands in all sandbox components

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

=head1 DESCRIPTION

This program is the primary tool for the maintainnace of Development Sandboxes
More documentation will follow.

=cut
Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/jats_sandbox.pl – Rev 235
