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

########################################################################
# Copyright (C) 2008 ERG Limited, All rights reserved
#
# Module name   : jats_sandbox.pl
# Module type   : JATS Utility
# Compiler(s)   : Perl
# Environment(s): JATS
#
# 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.008_002;
use strict;
use warnings;
use JatsError;
use JatsSystem;
use FileUtils;
use JatsBuildFiles;
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 dependencies
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->{mname} );
        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 Dependencies");
    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 my $pname ( glob("*") )
    {
        next if ( $pname =~ m~^\.~ );
        next if ( $pname =~ m~dpkg_archive$~ );
        next unless ( -d $pname );
        Verbose ("Package discovered: $pname");
        push @dirlist, $pname;

        #
        #   Locate the build files in each package
        #   Scan the build files and extract dependancy information
        #
        my $bscanner = BuildFileScanner( $pname, 'build.pl', '--LocateAll', '--ScanDependencies' );
        $bscanner->scan();
        my @blist = $bscanner->getInfo();
        Warning ("Package does not have build files: $pname") unless ( @blist );
        Warning ("Package has multiple build files: $pname") if ( $#blist > 0 );
        push @build_list, @blist;
    }

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

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

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

#DebugDumpData ("depends", \%depends );

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

    #
    #   Remove any dependencies 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
    #
    if ( keys %depends )
    {
        #DebugDumpData ("depends", \%depends );
        Error( "Internal algorithm error: Bad dependancy walk",
               "Possible circular dependency");
    }

#    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          : Arguments 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->{mname} ,
                  DisplayPath ("        Path: $fe->{dir}" ));

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

    exit 0;
}

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

=pod

=head1 NAME

jats_sandbox - Build in a Development Sandbox

=head1 SYNOPSIS

  jats sandbox [options] [commands]

 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]-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 maintenance of Development Sandboxes
More documentation will follow.

=cut
Subversion Repositories DevTools

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