Subversion Repositories DevTools

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

# Copyright ( C ) 2008-2009 ERG Limited, All rights reserved

#

# Module name   : jats_rewrite.pl

# Module type   : JATS Utility

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : Rewrite a build.pl file

#                 Use an external configuration file to provide a common

#                 source of configuration information

#

# Usage         : See POD

#

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

require 5.006_001;

use strict;

use warnings;

use JatsError;

use BuildName;

use Getopt::Long;

use Pod::Usage;                             # required for help support

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

#   Option variables

#

my $VERSION = "1.4.0";                      # 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_errors = 0;

my $opt_xml;

my $opt_oldproject;

my $opt_newproject;

my $opt_noconfig;

my $opt_validate;

my $opt_mode = 0;

my $opt_work_file = 'auto.new';

#

#   Globals

#

my %component =  ();

my %component_use =  ();

my $not_use_count = 0;

my $suffix_count = 0;

my @pkg_errors;

my @pkg_errors_val;

my $max_pkglen = 10;

#

#   Known extended fields

#   Only these values may be configured with the value=tag syntax

#   These may not be used as package names

#

my %fields = (

    'releasemanager.releasename' => undef,

    'releasemanager.projectname' => undef,

);

my $result = GetOptions (

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

                "manual:3"      => \$opt_help,          # flag

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

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

                "noconfig"      => \$opt_noconfig,      # flag

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

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

                "errors"        => \$opt_errors,        # flag

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

                "oldproject=s"  => \$opt_oldproject,    # string

                "newproject=s"  => \$opt_newproject,    # string

                "validate"      => \$opt_validate,      # flag

                "mode=s"        => \$opt_mode,          # Flag

                );

#

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

             'verbose' => $opt_verbose );

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

    if ( $opt_newproject xor $opt_oldproject );

Error ("Conflicting options -config=file and -noconfig")

    if ( $opt_datafile && $opt_noconfig );

Error ("No configuration file specified")

    unless ( $opt_datafile || $opt_newproject || $opt_noconfig );

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

    if ( ! $opt_mode && $opt_infile eq $opt_ofile );

#

#   Auto detect XML files

#

$opt_xml = 1

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

#

#   When opt_mode is invoked, allow reuse auto.xxx files

#   if they are present. The user may be changing the file

#

if ( $opt_mode )

{

    #

    #   Use later of build.pl or auto.pl for input

    #

    my $bstamp = -M "build.pl";

    my $astamp = -M "auto.pl";

    $opt_infile = 'auto.pl'

        if ( $astamp && $astamp < $bstamp );

    $opt_infile = 'auto.xml' if ( -f 'auto.xml' );

    Message ("Using: $opt_infile");

}

#

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

#

#   Report errors or warnings for packages that are not in the configuration

#   File. These will not have been updated inthe output file.

#

if ( @pkg_errors || @pkg_errors_val)

{

    my $report = $opt_mode ? \&Warning : \&ReportError;

    $report->("Errors encountered in the following packages:");

    $report->( @pkg_errors );

    $report->( @pkg_errors_val );

    $report->( "Package Names and Versions in build files may not match Release Manager");

}

ReportError("Unused packages found: $not_use_count")

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

ErrorDoExit();

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 ($_);

        #

        #   Extract special fields

        #   These are not dependent packages and are not mandatory

        #   These are of the form tag = name

        #

        if ( m{(\S+)\s*=\s*(.+)} )

        {

            Error ("Unsupported named field")  unless ( exists $fields{$1} );

            $fields{$1} = $2;

            Verbose ("Field: $1, \"$2\"");

            next;

        }

        #

        #   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 ( $opt_mode || $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 ( $opt_mode || $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 || $opt_mode  )

    {

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

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

    }

}

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

# Function        : process_build_file

#

# Description     : Rewrite one file

#                   build.pl -> auto.pl

#

# Inputs          :

#

# Returns         :

#

sub process_build_file

{

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

    #

    #   Unlink any OLD output file

    #

    unlink $opt_work_file;

    #

    #   Open the input and output files

    #

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

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

    my $build_info;

    my $release_name;

    my $release_version;

    while ( <INFILE> )

    {

        next if ( $opt_noconfig );       # Nothing to do

        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;

            #

            #   In Special Mode, don't change the version of this package

            #   Assume that the user has fiddled with it.

            #

            if ( $opt_mode ) {

                $new_ver = $build_info->{BUILDVERSION};

            } else {

                $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( 'Name', $build_info->{BUILDNAME_PACKAGE}, $build_info->{BUILDVERSION}, $new_ver );

        }

        #

        #   Process BuildPreviousVersion

        #   Save the current version information in this directive

        #

        if ( m/^\s*BuildPreviousVersion/ && ! $opt_mode )

        {

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

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

            my $prev = $1;

            my $new_ver = $opt_validate ? $prev : $build_info->{BUILDVERSION};

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

            print_update( 'PrevVer', '', $prev, $new_ver );

        }

        #

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

    unlink $opt_ofile;

    rename $opt_work_file ,$opt_ofile;

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

#                       <property name="packageversion" value="...">

#                       <property name="releasemanager.releasename" value="...">

#                       <property name="releasemanager.projectname" value="...">

#                       <import file=...>

#

#                  Note: This function handles a wider scope of XML files

#                        than it really needs to. All thats needed is

#                        the <property name= value=> fields.

#

# Inputs          :

#

# Returns         :

#

sub process_xml_build_file

{

    Verbose ("$opt_infile");

    #

    #   Unlink any OLD output file

    #

    unlink $opt_work_file;

    #

    #   Open the input and output files

    #

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

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

    my $release_name;

    my $release_version;

    while ( <INFILE> )

    {

        next if ( $opt_noconfig );       # Nothing to do

        #

        #   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 name and value

            #   Both must exist

            #

            my $name;

            my $value;

            if ( m~name="([^"]*)"~  )

            {

                $name = $1;

            }

            else

            {

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

            }

            if ( m~value="([^"]*)"~ )

            {

                $value = $1;

            }

            else

            {

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

            }

            Verbose2 ("Property: $name, Value: $value");

            #

            #   Examine the property name

            #   Some of the them are special, others will be package names

            #

            if ( $name eq 'packagename' )

            {

                $release_name = $value;

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

            }

            elsif ( $name eq 'packageversion' )

            {

                $release_version = $value;

                #

                #   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( 'Name', $release_name ,$release_version, $new_ver );

            }

            elsif ( defined $fields{$name} )

            {

                #

                #   Use tagged values in preference to packages

                #   There are very few tagged values.

                #

                my $new_value = $fields{$name};

                Error ("Release attribute not found: $name") unless ( $new_value );

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

                print_update( 'Release', $name ,$value, $new_value );

            }

            else

            {

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

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

                print_update( '', $name ,$value, $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 import 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;

    unlink $opt_ofile;

    rename $opt_work_file ,$opt_ofile;

    display_unused();

}

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

# Function        : display_unused

#

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

#

# Inputs          :

#

# Returns         :

#

sub display_unused

{

    return

        if ( $opt_mode );

    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) = @_;

    #

    #   Determine longest package name

    #

    my $len = length $package;

    $max_pkglen = $len

        if ( $len > $max_pkglen );

    #

    #   Split the suffix off the version

    #

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

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

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

    Error ("Package Name is a reserved key field: $package" )

        if ( exists $fields{$package} );

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

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

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

}

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

# Function        : get_package

#

# Description     : Get the package version

#                   Validates package-version if required

#

#                   Does not generate errors, but will generate error information

#                   to be reported later.

#

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

    {

        unless ( exists $component{$package} )

        {

            push @pkg_errors, "No definitions for package '$package'";

            return $version;

        }

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

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

        {

            push @pkg_errors, "No definitions for '$package' '$version' '$suf'";

            return $version;

        }

    }

    #

    #   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

    #

    my $new_version = get_version( $package, $suf, $rel );

    if ( $opt_validate )

    {

        if ( $new_version ne $version )

        {

            push @pkg_errors_val, sprintf("Validation mismatch: %-${max_pkglen}s, %-15s != %-15s", $package ,$version,  $new_version);

            return $version;

        }

    }

    return $new_version;

}

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

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

    }

    #

    #   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

    -noconfig           - No configuration file

    -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

    -validate           - Validate dependencies only

    -mode=nn            - Special operational modes

=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 multiple 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<-noconfig>

This option indicates that no config file is present and that the output file

is to be created without reference to the configuration.

=item B<-oldproject=xxx>

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

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

projects.

If this option is present then the 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 extension is '.xml'

=item B<-validate>

This option will validate the build files against the configuration file. This

option is used by build tools to validate dependency information.

=item B<-mode=n>

This option is used internally, by JATS, to indicate that the utility is being

used to perform controlled rewrite operations. Currently only a value of 1 is

supported. This will:

=over 8

* Suppress warnings about unused packages. The config file may is expected to contain

  many more packages than required by the rewrite.

* Suppress warnings about badly formatted config entries.