Subversion Repositories DevTools

#! perl

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

# Copyright ( C ) 2004 ERG Limited, All rights reserved

#

# Module name   : jats.sh

# Module type   : Makefile system

# Compiler(s)   : n/a

# Environment(s): jats

#

# Description   : Rewrite a build.pl file

#                 Use an external configuration file to provide a common

#                 source of configuration information

#

# Usage:

#

# Version   Who      Date        Description

#

#......................................................................#

require 5.6.1;

use strict;

use warnings;

use JatsError;

use BuildName;

use Getopt::Long;

use Pod::Usage;                             # required for help support

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

#   Option variables

#

my $VERSION = "1.2.4";                      # Update this

my $opt_verbose = 0;

my $opt_datafile = "";

my $opt_ofile  = "auto.pl";

my $opt_infile = "build.pl";

my $opt_help = 0;

my $opt_manual;

my $opt_errors = 0;

my $opt_xml;

my $opt_oldproject;

my $opt_newproject;

#

#   Globals

#

my %component =  ();

my %component_use =  ();

my $not_use_count = 0;

my $suffix_count = 0;

my $result = GetOptions (

                "help+"     => \$opt_help,          # flag, multiple use allowed

                "manual"    => \$opt_manual,        # flag

                "verbose+"  => \$opt_verbose,       # flag

                "config=s"  => \$opt_datafile,      # string

                "outfile=s" => \$opt_ofile,         # string

                "infile=s"  => \$opt_infile,        # string

                "errors"    => \$opt_errors,        # flag

                "xml!"       => \$opt_xml,          # flag

                "oldproject=s"  => \$opt_oldproject,

                "newproject=s"  => \$opt_newproject,

                );

#

#   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'    =>'REWRITE',

             'verbose' => $opt_verbose );

Error ("Must specify both Old and New project tags")

    if ( $opt_newproject xor $opt_oldproject );

Error ("No configuration file specified")

    unless ( $opt_datafile || $opt_newproject  );

Error ("Input and output file are the same" )

    if ( $opt_infile eq $opt_ofile );

#

#   Auto detect XML files

#

$opt_xml = 1

    if ( $opt_infile =~ m~\.xml$~i );

#

#   Process config and input files

#

read_config_file()          if $opt_datafile;

process_build_file()        unless( $opt_xml);

process_xml_build_file()    if ( $opt_xml);

Verbose ("Number of project extensions changed: $suffix_count")

    if ( $ opt_newproject );

Warning("No project extensions changed")

    if ( !$suffix_count && $opt_newproject);

Error("Unused packages found: $not_use_count")

    if ( $opt_errors && $not_use_count && $opt_datafile);

exit 0;

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

# Function        : read_config_file

#

# Description     : Read and store config file information

#

# Inputs          :

#

# Returns         :

#

sub read_config_file

{

    open ( FILE, "<$opt_datafile" ) or Error ("Config file ($opt_datafile) not found" );

    while ( <FILE> )

    {

        #

        #   Clean up lines

        #   Skip comments and blank lines

        #   Remove leading and training white space

        #

        chomp;

        s~^\s*~~;

        s~#.*$~~;

        s~\s*$~~;

        next if ( length( $_) <= 0 );

#        Verbose ($_);

        #

        #   Process LinkPkgArchive and BuildPkgArchive statements

        #   These allow simple updating of the config file from Release manager

        #

        if ( m/LinkPkgArchive/ or m/BuildPkgArchive/ )

        {

            m/'(.*)'[^']*'(.*)'/;

            my $comp = $1;

            my $ver = $2;

#print "Got Archive stuff: $_ : $comp, $ver\n";

            Error "Version not specified for: $comp" unless ( $ver );

            Warning "Suspect version format for: $comp ($ver)" unless ( $ver =~ m~^\w+\.\w+\.\w+.\w+$~ || $ver =~ m~^\w+\.\w+\.\w+$~ );

            save_package( $comp, $ver );

            next;

        }

        #

        #   Process line as

        #       component version

        #

        my ( $comp, $ver, $opt ) = split( /[\s,]+/, $_, 3);

        Error "Version not specified for: $comp" unless ( $ver );

        Warning "Suspect version format for: $comp ($ver)" unless ( $ver =~ m~^\w+\.\w+\.\w+.\w+$~ || $ver =~ m~^\w+\.\w+\.\w+$~ );

        save_package( $comp, $ver );

    }

    close FILE;

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

}

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

# Function        : print_update

#

# Description     : Generate a display line tracking the changes made

#

# Inputs          :

#                   $title          - Update Type

#                   $name           - Package name

#                   $version        - Original version of package

#                   $new_version    - New version

#

# Returns         :

#

sub print_update

{

    my ($title, $name, $version, $new_version ) = @_;

    my $diff = ( $version ne $new_version ) ? '*' : '';

    #

    #   Always display diffs

    #   Display all if verbose

    #

    if ( $diff || $opt_verbose  )

    {

        $title = 'Package' unless ( $title );

        Message( sprintf("%-8s: %-35s, Version: %-15s %1.1s-> %-15s\n", $title, $name ,$version, $diff, $new_version));

    }

}

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

# Function        : process_build_file

#

# Description     : Rewrite one file

#                   build.pl -> build-new.pl

#

# Inputs          :

#

# Returns         :

#

sub process_build_file

{

    Verbose ("Processing build file: $opt_infile");

    #

    #   Unlink any OLD output file

    #

    unlink $opt_ofile;

    #

    #   Open the input and output files

    #

    open ( INFILE, "<$opt_infile" ) || Error( "Cannot open $opt_infile" );

    open ( OUTFILE, ">$opt_ofile" ) || Error( "Cannot create $opt_ofile" );

    my $build_info;

    my $release_name;

    my $release_version;

    while ( <INFILE> )

    {

        next if ( m~^\s*#~ );            # Skip comments

        #

        #   Process BuildName

        #

        if ( m~\s*BuildName[\s\(]~ )

        {

            #   Build names come in many flavours

            #   Must support a number of different formats

            #       "name nn.nn.nn prj"

            #       "name nn.nn.nn.prj"

            #

            #       "name nn.nn.nn prj", "nn.nn.nn"

            #       "name nn.nn.nn.prj", "nn.nn.nn"

            #

            #       "name", "nn.nn.nn.prj"

            #

            m~\(\s*(.*?)\s*\)~;

            my @args = split /\s*,\s*/, $1;

            $build_info = parseBuildName( @args );

            my $new_ver = get_package ( $build_info->{BUILDNAME_PACKAGE}, $build_info->{BUILDVERSION} );

            my $build_args = genBuildName( $build_info, $new_ver );

            #

            #   Rewrite the body of the directive

            #

            s~\(\s*(.*?)\s*\)~( $build_args )~;

            print_update( '', $build_info->{BUILDNAME_PACKAGE}, $build_info->{BUILDVERSION}, $new_ver );

        }

        #

        #   Process BuildPreviousVersion

        #   Save the current version information in this directive

        #

        if ( m/^\s*BuildPreviousVersion/ )

        {

            Error ("BuildPreviousVersion directive before BuildName") unless ( $build_info );

            m/['"](.*?)['"]/;

            my $prev = $1;

            s/['"](.*?)['"]/'$build_info->{BUILDVERSION}'/;

            print_update( 'PrevVer', '', $prev, $build_info->{BUILDVERSION} );

        }

        #

        #   Process BuildPkgArchive and LinkPkgArchive

        if ( m/^\s*LinkPkgArchive/ or m/^\s*BuildPkgArchive/ )

        {

            m/['"](.*?)['"][^'"]*['"](.*?)['"]/;

            my $comp = $1;

            my $ver = $2;

            my $new_ver = get_package ( $comp, $ver );

            s/['"](.*?)['"]([^'"]*)['"](.*?)['"]/'$comp'$2'$new_ver'/;

            print_update ('', $comp ,$ver, $new_ver );

        }

    } continue

    {

        #

        #   Always output the resultant line

        #

        print OUTFILE $_;

    }

    #

    #   Cleanup

    #

    close INFILE;

    close OUTFILE;

    display_unused();

}

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

# Function        : process_xml_build_file

#

# Description     : Rewrite one depends.xml file

#                   depends.xml -> auto.xml

#

#                   A very cheap and nasty XML (not)parser

#                   It assumes that entries are all on one line so that we can

#                   do trivial substitutions

#

#                   Processes

#                       <using ... >

#                       <property name="packagename" ...>

#                       <import file=...>

#

#

# Inputs          :

#

# Returns         :

#

sub process_xml_build_file

{

    Verbose ("$opt_infile");

    #

    #   Unlink any OLD output file

    #

    unlink $opt_ofile;

    #

    #   Open the input and output files

    #

    open ( INFILE, "<$opt_infile" ) || Error( "Cannot open $opt_infile" );

    open ( OUTFILE, ">$opt_ofile" ) || Error( "Cannot create $opt_ofile" );

    my $release_name;

    my $release_version;

    while ( <INFILE> )

    {

        #

        #   Process "project" statement

        #

        if ( m~<project~ )

        {

            #   Extract the package name

            #   this to determine the required version of the package

            #

            m~name=\"([^"]*)"~;

            $release_name = $1;

            Error ("Name attribute not found in 'project'") unless ( $release_name );

            Verbose2 ("Project: $release_name");

        }

        #

        #   Process "property" statements

        #

        elsif ( m~<property~ )

        {

            #

            #   Extract the package name and version

            #   and use this to determine the required version of the package

            #

            m~name=\"([^"]*)"~;

            my $name = $1;

            Error ("Name attribute not found in 'property'") unless ( $name );

            Verbose2 ("Property: $name");

            #

            #   Update the package name

            #   The real package name is held in the value attribute

            #

            if ( $name eq 'packagename' )

            {

                m~value=\"([^"]*)"~;

                $release_name = $1;

                Error ("Value attribute not found in packagename 'property'") unless ( $release_name );

            }

            elsif ( $name eq 'packageversion' )

            {

                m~value=\"([^"]*)"~;

                $release_version = $1;

                Error ("Value attribute not found in packageversion 'property'") unless ( $release_version );

                #

                #   Ensure that we already have the package name

                #

                Error ("packageversion before packagename") unless ( $release_name );

                my $new_ver = get_package ( $release_name, $release_version );

                s~(.*)value=\"([^"]*)"~$1value=\"$new_ver\"~;

                print_update( '', $release_name ,$release_version, $new_ver );

            }

            elsif ( $name eq 'env' )

            {

                #

                #   'env' is special

                #   Its not a package. Skip it

                #

            }

            else

            {

                m~value=\"([^"]*)"~;

                $release_version = $1;

                Error ("Value attribute not found in package 'property' : $name") unless ( $release_version );

                my $new_ver = get_package ( $name, $release_version );

                s~(.*)value=\"([^"]*)"~$1value=\"$new_ver\"~;

                print_update( '', $name ,$release_version, $new_ver );

            }

        }

        #

        #   Process "using" statements

        #

        elsif ( m~<using~ )

        {

            #

            #   Extract the package name and version

            #   and use this to determine the required version of the package

            #

            m~name=\"([^"]*)"~;

            my $name = $1;

            Error ("Name attribute not found in 'using'") unless ( $name );

            Verbose2 ("Using: $name");

            #

            #   Extract the version

            #

            m~version=\"([^"]*)"~;

            $release_version = $1;

            Error ("Version attribute not found in package 'using' : $name") unless ( $release_version );

            my $new_ver = get_package ( $name, $release_version );

            s~(.*)version=\"([^"]*)"~$1version=\"$new_ver\"~;

            print_update( '', $name ,$release_version, $new_ver );

        }

        #

        #   Import File

        #   Only used to imprt ant-using

        #

        elsif ( m~<import~ )

        {

            #

            #   Extract the file

            #

            m~file=\"([^"]*)"~;

            my $file = $1;

            Error ("File attribute not found in 'import'") unless ( $file );

            #

            #   Extract the package name and version from the file

            #   Will be of the form /package/version/filename

            #

            $file =~ m~(.*?)/([^/]+)/([^/]+)/([^/]+)$~;

            my $prefix = $1;

            my $pname = $2;

            my $pver = $3;

            my $fname = $4;

            Error ("Package details not found in import file") unless ( $fname );

            my $new_ver = get_package ( $pname, $pver );

            #

            #   Rewrite the body of the directive

            #

            s~(.*)file=\"([^"]*)"~$1file=\"$prefix/$pname/$new_ver/$fname\"~;

            print_update( '', $pname ,$pver, $new_ver );

        }

    } continue

    {

        #

        #   Always output the resultant line

        #

        print OUTFILE $_;

    }

    #

    #   Cleanup

    #

    close INFILE;

    close OUTFILE;

    display_unused();

}

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

# Function        : display_unused

#

# Description     : Generate warnings about config items that were not used

#

# Inputs          :

#

# Returns         :

#

sub display_unused

{

    foreach my $comp ( sort keys %component_use )

    {

        foreach my $suf ( keys %{$component_use{$comp}} )

        {

            my $ver = get_version( $comp, $suf );

            Warning("Unused package: ${comp}_${ver}");

            $not_use_count++;

        }

    }

}

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

# Function        : save_package

#

# Description     : Save the package name and version

#

# Inputs          : $package

#                   $version

#

# Returns         : Nothing

#

sub save_package

{

    my ($package, $version) = @_;

    #

    #   Split the suffix off the version

    #

    my ($rel, $suf ) = extract_version( $package, $version);

    Error ("Multiple definitions for $package $version" )

        if ( $component{$package}{$suf} );

    $component{$package}{$suf} = $rel;

    $component_use{$package}{$suf} = $rel;

    Verbose2 ("Package: $package, $version, $rel, $suf");

}

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

# Function        : get_package

#

# Description     : get the package version

#

# Inputs          : $package

#                   $version ( suffix is used only )

#

# Returns         : Replacement version

#

sub get_package

{

    my ($package, $version) = @_;

    #

    #   Split the suffix off the version

    #       Suffixes are not numeric

    #   Must allow for

    #       9.9.9

    #       9.9.cots

    #       9.9.9.cots

    #

    my ($rel, $suf ) = extract_version( $package, $version);

    Verbose2 ("Get Package: $package, $version, $rel, $suf");

    #

    #   If the CFG file has 'new' project extensions then we

    #   must transform them before attempting to look up the versions

    #

    if ( $opt_oldproject && $suf eq $opt_oldproject )

    {

        $suf = $opt_newproject;

        $suffix_count++;

    }

    #

    #   If a datafile was provided, then the packages MUST be present

    #

    if ( $opt_datafile )

    {

        Error ("No definitions for the package '$package'" )

            unless ( exists $component{$package} );

    #    print Data::Dumper->Dump ( [\%component], ["Component" ]);

        Error ("No definitions for '$package' '$version' '$suf'" )

            unless ( exists $component{$package}{$suf} );

    }

    #

    #   remove used packages from the "use" hash

    #

    delete $component_use{$package}{$suf};

    delete $component_use{$package} unless ( keys %{$component_use{$package}} );

    #

    #   Was the suffix real

    #

    return get_version( $package, $suf, $rel );

}

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

# Function        : extract_version

#

# Description     : Extracts a version and project suffix from a string

#

# Inputs          : $1  - Package name

#                   $2  - Package Version Input string

#

# Returns         : $1  - Vesrion part

#                   $2  - Suffix (project) part

#

sub extract_version

{

    my ($package, $version) = @_;

    my $rel;

    my $suf;

    if ( $version =~ m~^(.*?)([\.\s]([^0-9]+))$~ )

    {

        $rel = $1;

        $suf = $3;

        $suf = '' unless ( $suf );

    }

    else

    {

        $rel = $version;

        $suf = '';

    }

    return ( $rel, $suf );

}

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

# Function        : get_version

#

# Description     : Create a nice package version

#

# Inputs          : $package

#                   $suf

#

# Returns         :

#

sub get_version

{

    my ($package,$suf, $version) = @_;

    if ( exists( $component{$package}{$suf} ) )

    {

        $version = $component{$package}{$suf};

    }

    if ( $opt_oldproject && $suf eq $opt_oldproject )

    {

        $suf = $opt_newproject;

        $suffix_count++;

    }

    $version .= '.' . $suf if ( length( $suf) );

    return  $version;

}

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

# Function        : genBuildName

#

# Description     : Generate a BuildName argument string

#

# Inputs          : build_info      - Hash of buildname arguments

#                   new_ver         - New version

#

# Returns         : A string of quoted BuildName arguemnts

#

sub genBuildName

{

    my ( $build_info, $new_ver ) = @_;

    my @args;

    #

    #   Remove the project part from the new version name

    #

    my $prj = $build_info->{BUILDNAME_PROJECT};

    $prj = $opt_newproject

        if ( $opt_oldproject && $prj eq $opt_oldproject );

    $new_ver =~ s~\.$prj$~~ if ( $prj );

    #

    #   Determine the format of the BuildName

    #

    if ( $build_info->{RELAXED_VERSION} )

    {

        #

        #   Relaxed format

        #

        push @args, $build_info->{BUILDNAME_PACKAGE};

        push @args, $new_ver;

        push @args, $prj if ( $prj );

        push @args, '--RelaxedVersion';

    }

    else

    {

        #

        #   Generate two field version as some of the deployment scripts

        #   need this format.

        #

        push @args, "$build_info->{BUILDNAME_PACKAGE} $new_ver $prj";

        push @args, "$new_ver";

    }

    #

    #   Common arguments

    #

    push @args, "--PatchNum=$build_info->{DEPLOY_PATCH}"

        if ( $build_info->{DEPLOY_PATCH} );

    push @args, @{$build_info->{EXTRA_ARGS}} if exists ($build_info->{EXTRA_ARGS});

    #

    #   Format the arguments

    #

    return join ", ", map { "'$_'" } @args;

}

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

#   Documentation

#

=pod

=head1 NAME

jats_rewrite - Rewrite a build.pl file

=head1 SYNOPSIS

  jats etool jats_rewrite [options]

 Options:

    -help               - brief help message

    -help -help         - Detailed help message

    -man                - Full documentation

    -verbose            - Verbose operation

    -config xxx         - Configuration file. Full file name

    -oldproject         - Old project extension (optional)

    -newproject         - New project extension (optional)

    -infile xxx         - Input file (build.pl)

    -outfile xxx        - Output file (auto.pl)

    -errors             - Generate errors for unused config items

    -xml                - Process a build.xml file

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

=item B<-verbose>

Increases program output. This option may be specified mutiple times

=item B<-config=xxx>

This option specifies the name of a configuration file that will provide the

transformation between of version numbers. The format of the config file is

described later.

The option is not required if -newproject and -oldproject are specified

=item B<-oldproject=xxx>

This option, in conjunction with B<-oldproject=xxx> allows the project

extensions to be modified. ie: .syd projects can eb converted into .bej

projects.

If this option is present thenthe config data file is not required, although

it will be sued if it is present.

=item B<-newproject=xxx>

See B<-oldproject=xxx>

=item B<-infile=xxx>

The name of the input file. The default file is build.pl

=item B<-outfile=xxx>

The name of the output file. The default is auto.pl, even if an XML file is

being processed.

=item B<-errors>

This option will force the program to generate an error message if there are

packages in the config file that were not used by the re-write process.

=item B<-xml>

Process a build.xml file instead of a build.pl file.

This option will be set internally if the infile extesnion is '.xml'

=back

=head1 DESCRIPTION

=head2 CONFIG FILE FORMAT

The format of the configuration file is defined below.

Comments begin with a # and go the end of the line

  There are two types of config line

      package version

          Specifies the version of a package to use 

          The version may be of the form:

              nn.nn.nn.aaa

              nn.nn.nn

              other

    Standard LinkPkgArchive or BuildPkgArchive statements

=cut