Subversion Repositories DevTools

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

# 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.006_001;

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