Subversion Repositories DevTools

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

# Copyright ( C ) 2008 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.3.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;

#

#   Globals

#

my %component =  ();

my %component_use =  ();

my $not_use_count = 0;

my $suffix_count = 0;

#

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

                "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_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 );

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

        #

        #   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 ( $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 ( $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 = 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" 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_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> )

    {

        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 th 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( '', $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;

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

    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

#

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

    }

    #

    #   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

=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 indiocates 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'

=back

=head1 DESCRIPTION

This utility is used within the automated build system to rewrite build files

so that they contain suitable version numbers.

The program takes a configuration file, described below, that contains package

and version information for the build.

The program takes a JATS build.pl file, or an ANT style dependency file, and

will create a file that is similar, but contains modified package-version

information.

The build tools are designed to use this I<auto> file, in preference to the

original build file.

=head2 Format of the Configuration File

The format of the configuration file is defined below.

The file is a line oriented text file.

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

There are three types of configuration line:

=over 8

=item Assigned Items

These are of the form: B<tag = value> and are used to specify the value of

the following B<special> properties:

=over 8

=item releasemanager.projectname

The name of the Release Manager project used for the build.

=item releasemanager.releasename

The name of the Release Manager release, within the project, used for the build.

=back

These may be used to brand installer programs with Release Information.

Currently the use of these tags is only supported by the XML build files.

=item Package Version

Specifies the version of a package to use as two, space separated words of the

form C<package_name package_version> where package version is of the form:

=over 8

=item   * nn.nn.nnnn.aaa

=item   * nn.nn.nnnn

=item   * Other

=back

=item LinkPkgArchive or BuildPkgArchive

These are standard JATS LinkPkgArchive or BuildPkgArchive statements.

=back

=head2 XML File Rewrite

This program will process an ERG style ANT build dependency definition file

and replace the values of the properties seen within the file.

The following properties are special within the rewrite process:

=over 8

=item	packagename

This is the name of the package. It is not modified, but it

is used in conjunction with the C<packageversion> to identify the package, such

that the packageversion can be updated. This property is mandatory and must

appear before the C<packageversion>.

=item	packageversion

This is the version of the package. It can be rewritten by this program. This

property is mandatory.

=item	releasemanager.projectname

If this property is found the value will be replaced with an B<Assigned Item> of the

same name.

=item	releasemanager.releasename

If this property is found the value will be replaced with an B<Assigned Item> of the

same name.

=back

Properties that are not B<special> will be treated as the name of a package and

the value will be updated to reflect the required version of the package.

The XML rewrite process does not, and cannot handle, instances of packages

that have the same name, but different project suffixes. This is a limitation of

the ERG ANT build system and not a limitation of this utility.

=head2 JATS Build File Rewrite

This program will process a JATS style build.pl file and modify some