Subversion Repositories DevTools

Rev

Rev 227 | Rev 249 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed 

#! 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
            #
            if ( m~name=\"([^"]*)"~ )
            {
                $release_name = $1;
                Error ("Empty '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