Subversion Repositories DevTools

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