Subversion Repositories DevTools

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

# 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::Path qw(rmtree);

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;

#

#   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'};

my $GBE_MACHTYPE = $ENV{'GBE_MACHTYPE'};

my $GBE_DPKG_LOCAL = $ENV{'GBE_DPKG_LOCAL'};

my $GBE_DPKG_CACHE = $ENV{'GBE_DPKG_CACHE'};

my $GBE_DPKG       = $ENV{'GBE_DPKG'};

my $GBE_DPLY       = $ENV{'GBE_DPLY'};

my $GBE_DPKG_STORE = $ENV{'GBE_DPKG_STORE'};

#

#   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|h:+"      => \$opt_help,

                "manual:3"      => \$opt_help,

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

delete_sandbox()                        if ( $cmd =~ m/^delete$/ );

create_sandbox()                        if ( $cmd =~ m/^create$/ );

info(@ARGV)                             if ( $cmd =~ m/^info$/ );

cmd(@ARGV)                              if ( $cmd =~ m/^cmd$/ );

buildcmd($cmd, @ARGV )                  if ( $cmd =~ m/(^all$)|(^build$)/  );

cmd($cmd, @ARGV )                       if ( $cmd =~ m/(^make$)/  );

clean($cmd, @ARGV)                      if ( $cmd =~ m/(^clobber$)|(^clean$)/  );

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 ("Unexpected arguments: @ARGV") if ( @ARGV );

    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        : delete_sandbox

#

# Description     : Delete a sandbox

#                   Its up to the user the delete the components in the sandbox

#

# Inputs          : None

#

# Returns         : 

#

sub delete_sandbox

{

    Error ("Unexpected arguments: @ARGV") if ( @ARGV );

    unless ( $GBE_SANDBOX )

    {

        Warning("No sandbox found to delete");

    }

    else

    {

        my $sdir = "$GBE_SANDBOX/sandbox_dpkg_archive";

        rmtree($sdir,0,0);

        Error ("Sandbox directory not completly removed")

            if ( -e $sdir );

        Message("Sandbox information deleted",

                "Sandbox components must be manually deleted");

    }

    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

    #

    my @unknown;

    foreach  ( @_ )

    {

        $opt_verbose++, next if ( m/^-v/ );

        push @unknown, $_;

    }

    Error ("sandbox info: Unknown options: @unknown") if @unknown;

    #

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

        {

            my $exists = check_package_existance( $pn, "$pv.$ps") ? '' : '*';

            my $flags = sprintf ("%4.4s", $flag . $exists);

            Message ("${flags}${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        : check_package_existance

#

# Description     : Determine if a given package-version exists

#

# Inputs          : $name           - Package Name

#                   $ver            - Package Version

#

# Returns         : true            - Package exists

#

sub check_package_existance

{

    my ($name, $ver) = @_;

    #

    #   Look in each package archive directory

    #

    foreach my $dpkg ( $GBE_DPKG_SBOX,

                       $GBE_DPKG_LOCAL,

                       $GBE_DPKG_CACHE,

                       $GBE_DPKG,

                       $GBE_DPLY,

                       $GBE_DPKG_STORE )

    {

        next unless ( $dpkg );

        if ( -d "$dpkg/$name/$ver" )

        {

            return 1;

        }

    }

   return 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 if ( $pname =~ m~^CVS$~ );

        next unless ( -d $pname );

        Verbose ("Package discovered: $pname");

        if ( -f "$pname/stop" || -f "$pname/stop.$GBE_MACHTYPE" )

        {

            Warning("Package contains stop file: $pname");

            next;

        }

        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;

    my %multi;

    foreach my $be ( @build_list )

    {

        Verbose( DisplayPath ("Build file: " . $be->{dir} . " Name: " . $be->{file} ));

#        DebugDumpData ("be", $be );

        #

        #   Catch multiple builds for the same package

        #   Report later - when we have all

        #

        next unless ( $be->{mname} );

        push @{$multi{$be->{mname}}},$be->{dir};

        #

        #   Add into dependency struct

        #

        $depends{$be->{package}}{depends} = $be->{depends};

        $depends{$be->{package}}{entry} = $be;

    }

    foreach my $mname ( sort keys %multi )

    {

        ReportError ("Mutiple builders for : $mname", @{$multi{$mname}} )

            if ( scalar @{$multi{$mname}} > 1 );

    }

    ErrorDoExit();

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

}

#-------------------------------------------------------------------------------

# Function        : buildcmd

#

# Description     : Build the entire sandbox

#                   The all and the build are similar.

#                   Its not really useful to do a build without a make

#                   so we don't try

#

# Inputs          : Arguments passed to jats make

#

#

# Returns         : Will exit

#

sub buildcmd

{

    my ($cmd, @make_opts) = @_;

    my @build_opts;

    #

    #   Insert default options

    #

    push @build_opts, '-noforce' if ( $cmd eq 'all' );

    push @build_opts, '-force' if ( $cmd ne 'all' );

    push @make_opts, 'all'  unless ( @make_opts  );

    #

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

        JatsCmd( "-cd=$dir", 'build', @build_opts) && Error ("Build Cmd failure") if ( $result );

        JatsCmd( "-cd=$dir", 'make',  @make_opts)  && Error ("Make Cmd failure")  if ( $result );

    }

    exit 0;

}

#-------------------------------------------------------------------------------

# Function        : clean

#

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

{

    my ($mode, @cmds ) = @_;

    #

    #   Determine Sandbox information

    #   Populate global variables

    #

    calc_sandbox_info();

    my @cmd = $mode eq 'clobber' ? ('clobber') : ('make', 'clean' );

    #

    #   Clobber and clean need to be done in the reverse order

    #

    foreach my $fe ( reverse @build_order )

    {

        my $dir = $fe->{dir};

        Message( "Level:" . $fe->{level} . " Name: " . $fe->{mname} ,

                  DisplayPath ("        Path: $fe->{dir}" ));

        my $result = JatsCmd( "-cd=$dir", @cmd, @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[=n]          - Display help with specified detail

    -help -help        - Detailed help message

    -man               - Full documentation

 Commands:

    help                - Same as -help

    create              - Create a sandbox in the current directory

    delete              - Delete the sandbox

    info [[-v]-v]       - Sandbox information. -v: Be more verbose

    cmd                 - Do commands in all sandbox components

    all                 - Do 'build', if required, then a make in all sandbox components

    build               - Force 'build and make' in all sandbox components

    make                - Do 'make' in all sandbox components

    clean               - Do 'make clean' in all sandbox components

    clobber             - Do 'build clobber' is all sandbox components

=head1 OPTIONS

=over 8

=item B<-help[=n]>

Print a brief help message and exits.

There are three levels of help

=over 8

=item   1 Brief synopsis

=item   2 Synopsis and option summary

=item   3 Detailed help in man format

=back 8

=item B<-help -help>

Print a detailed help message with an explanation for each option.

=item B<-man>

Prints the manual page and exits. This is the same a -help=3

=back

=head1 DESCRIPTION

This program is the primary tool for the maintenance of Development Sandboxes.

More documentation will follow.

=head2 SANDBOX DIRECTORY

The sandbox directory is marked as being a sandbox through the use of the

'sandbox create' command. This will create a suitable structure within the

current directory.

Several JATS commands operate differently within a sandbox. The 'extract' and

'release' commands will create static viwes within the sandbox and not the

normal directory. The 'sandbox' sub commands can only be used within a sandbox.

The sandbox directory contains sub directories, each should contain a single

package. Sub directories may be created with the 'jats extract' command.

Note: Symbolic links are not supported. They cannot work as he sandbox mechanism

requires that all the packages be conatined within a sub directory tree so

that the root of the sandbox can be located by a simple scan of the directory

tree.

If a package subdirectory contains a file called 'stop' or 'stop.

<GBE_MACHTYPE>', then that package will not be considered as a part of the

build-set. A 'stop' file will prevent consideration all build platforms. The 'stop.

<GBE_MACHTYPE>' will only prevent consideration if being built on a GBE_MACHTYPE

type of computer.

=head2 COMMAND SUMMARY

=head3 create

The 'create' command will create a sandbox in the users current directory. It is

not possible to create a sandbox within a sandbox.

A sandbox can be created in a directory that contains files and subdirectories.

The create command simply places a known directory in the current directory.

This dorectory is used by the sandboxing process. It may be manually deleted, or

deleted with the 'delete' command.

=head3 delete

The 'delete' command will delete the sandbox's marker directory. The command may

be executed anywhere within the sandbox.

Once the sanbox has been deleted, the user must remove the components within the

sandbox.

=head3 info

The 'info' command will display information about the build order and the

depenedencies of packages that it finds within the sandbox.

The command will accept one option '-v' to increase the verbosity of the

information being displayed.

=over 8

=item * No Verbosity

The basic command will display the build order and the external

dependencies. External dependencies may be prefixed with one of the

following indicators:

=over 8

=item   +   Multiple versions of this package are being used by sandboxed components.

=item   *   The package cannot be found in any of the package archives.

=back

=item Verbosity of 1

This level of verbosoity will display the build order and detailed information

on the dependencies. The dependencies will be prefixed with:

=over 8

=item   E   Dependent Package is external to the sandbox

=item   I   Dependent Package is internal to the sandbox

=back

External dependencies may be prefixed with one of the indicators described for

no-verbosity. Additionally the internal consumer of the external package is also

shown. These are prefixed with a 'U'.

=item Verbosity of 2

Reserved forfuture use

=item Verbosity over 2

This should be considered a debug option. Undocument internal information will

be displayed.

=back

=head3 all

The 'all' command will perform build, if the build files are out of date,

followed by a make in each of the packages within the sandbox, in the correct

build order.

Any arguments are passed to the 'make' phase of the process.

This command may be used to:

=over 8

=item * Pickup any build file changes.

=item * Resume a failed build.

=back

=head3 build

The 'build' command will force a build followed by a make in each of the packages

within the sandbox, in the correct build order.

Any arguments are passed to the 'make' phase of the process.

In practice, the 'sandbox all' command is quicker.

=head3 make

The 'make' command will perform a 'make' operation in each of the packages

within the sandbox, in the correct build order.

Any arguments are passed to the 'make'.

=head3 cmd

The 'cmd' command will pass all of its arguments to JATS in the build directory

of each of the packages within the sandbox, in the package build order.

=head3 clean

The 'clean' command will perform a 'jats make clean' in all components in the

sandbox.

=head3 clobber

The 'clobber' command will perform a 'jats clobber' in all components in the

sandbox.

=cut