Subversion Repositories DevTools

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

# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.

#

# Module name   : jats_runutf.pm

# Module type   : JATS Utility

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : JATS Make Time Test Harness Support

#                 This package contains fucntions that will be used by JATS

#                 to invoke the tests.

#

#                 This is more powerful that the previous shell-based solution

#                 that had problems under windows.

#

#                 The functions are designed to be invoked as:

#                   $(GBE_PERL) -Mjats_runutf -e <function> -- <args>+

#

#                 The functions in this packages are designed to take parameters

#                 from @ARVG as this makes the interface easier to read.

#

# Usage         : See POD at the end of this file

#

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

require 5.008_002;

use strict;

use warnings;

package jats_runutf;

our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);

use Exporter;

use JatsError qw(:name=jats_runutf);

use Pod::Usage;                             # required for help support

use Getopt::Long;

use File::Spec;

use XML::Simple;

$VERSION = 1.00;

@ISA = qw(Exporter);

# Symbols to autoexport (:DEFAULT tag)

@EXPORT = qw( processUtf help man );

#

#   Global Variables

#

my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose

my $opt_help = 0;

#   Data to be passed into the filter function

#   Defined values are:

#       ARGS            - An hash of user arguments

#       DIR             - Optional. Name of test subdir

#       FILTER          - Name of the filter 

#       IDIR            - Path to original directory

#       INTERFACE       - Abs Path to Interface directory

#       LOCAL           - Abs Path to Local directory

#       OUTDIR          - Abs Path to output directory

#       OUTFILE         - Abs Path to suggested output file

#       PKGDIR          - Abs Path to Packaging directory

#       ROOT            - Abs Path to Root of the build

#       TARGET          - Current make target

#       TYPE            - Built type P or D

#       UTFUID          - Unique Test Identifier

#       UTFNAME         - Test Name

#       UTFTEST         - Recommended file root for test results

#       UTFRC           - Result Code from Unit Test run

#       RCFILE          - Path to the RC File (optional)

#

our %filterData;

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

# Function        : help

#                   man 

#

# Description     : Utility functions to make is easier for users to get POD

#                   from this module

#

# Inputs          : 

#

# Returns         : 

#

sub help

{

    pod2usage(-verbose => 0, -input =>  __FILE__);

}

sub man

{

    pod2usage(-verbose => 2, -input =>  __FILE__);

}

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

# Function        : processUtf  

#

# Description     : Main function to process UTF results

#                   This function will locate a suitable filter process and invoke

#                   it to process the results

#

#                   The filter process will be provided in a Perl Module

#                   It may be a part of JATS or an external modules provided

#                   within an external package. ie(utf may provide its own filter)

#

#

# Inputs          : None. Parameters are passed via @ARGV

#

# Returns         : Nothing

#

sub processUtf

{

    my $argCount = scalar @ARGV;

    my $result = GetOptions (

                    "help|h:+"      => \$opt_help,

                    "manual:3"      => \$opt_help,

                    "verbose:+"     => \$opt_verbose,       # Only set to to 0,1 or 3

                    "root=s"        => \$filterData{ROOT},

                    "filter=s"      => \$filterData{FILTER},

                    "interface=s"   => \$filterData{INTERFACE},

                    "local=s"       => \$filterData{LOCAL},

                    "target=s"      => \$filterData{TARGET},

                    "pkgdir=s"      => \$filterData{PKGDIR},

                    "type=s"        => \$filterData{TYPE},

                    "dir=s"         => \$filterData{DIR},

                    "rcfile=s"      => \$filterData{RCFILE},

                    "arg=s"         => sub {my ( $key, $value) = split('=', $_[1], 2); $filterData{ARGS}{uc $key} = $value;},

                    );

    pod2usage(-verbose => 0, -input =>  __FILE__) if ($opt_help == 1 || ! $result || $argCount < 1);

    pod2usage(-verbose => 1, -input =>  __FILE__) if ($opt_help == 2 );

    pod2usage(-verbose => 2, -input =>  __FILE__) if ($opt_help  > 2);

    #   Reconfigure the verbosity level

    ErrorConfig( 'verbose', $opt_verbose);

    Error("Internal: No Filter specified") unless defined $filterData{FILTER};

    Error("Internal: No PkgDir specified") unless defined $filterData{PKGDIR};

    #

    #   Locate the required filter module

    #   Filter modules have a name of the form:

    #       UtfFilter_<FilterName>.pm

    #   And can be located:

    #       within JATS

    #           in 'TOOLS/LIB'

    #       within a Package declared

    #           with a BuildPkgArchive or a LinkPkgArchive

    #           within the packages 'tools/scripts' subdirectory

    #       within the current package

    #           Perl modules with ROOT/gbe/utfFilters

    #                         or in the current directory

    my $module_name = join('_','UtfFilter', lc $filterData{FILTER});

    Verbose("Filter Module: $module_name");

    #   Extend Perl Module search path for package-local filters

    #   Check the current directory

    #       The current directory is also within @INC, but it is at the end

    #       thus local filter will not override external filters. Place the

    #       current directory first - if it conatins a filter.

    if (-f "$module_name.pm" )

    {

        Verbose("Extend the filter module search path: Current Directory");

        unshift @INC, '.';

    }

    else

    {

        #

        #   Check package-local directory

        #       <root>/gbe/utfFilters

        #

        my $localUtfPath = File::Spec->catfile($filterData{ROOT}, 'gbe', 'utfFilters');

        if ( -f( "$localUtfPath/$module_name.pm") )

        {

            Verbose("Extend the filter module search path: $localUtfPath");

            unshift @INC, $localUtfPath;

        }

    }

    #

    #   Locate a Perl Module of the required name

    #

    eval "require $module_name";

    if ($@)

    {

        Error ("Could not load required filter module: $module_name");

    }

    #

    #   Ensure that the filter contains the required interface methods

    #

    foreach my $fname ( qw(processUtf))

    {

        ReportError("Required function DOES NOT exist: $fname")

            unless (defined($module_name->can($fname)));

    }

    ErrorDoExit();

    #

    #   Convert potentially local paths to absolute paths

    #       Simplifies use when the CWD is changed

    #

    foreach my $entry ( qw(INTERFACE LOCAL PKGDIR ROOT))

    {

        $filterData{$entry}  = File::Spec->rel2abs($filterData{$entry} );

    }

    #

    #   Add in known values from the environment

    #

    $filterData{TYPE} = $ENV{'GBE_MAKE_TYPE'};

    Error("Internal: EnvVar 'GBE_MAKE_TYPE' not specified") unless $filterData{TYPE};

    $filterData{UTFUID} = $ENV{'GBE_UTFUID'};

    Error("Internal: EnvVar 'GBE_UTFUID' not specified") unless $filterData{UTFUID};

    $filterData{UTFNAME} = $ENV{'GBE_UTFNAME'};

    Error("Internal: EnvVar 'GBE_UTFNAME' not specified") unless $filterData{UTFNAME};

    $filterData{OUTFILE} = $ENV{'GBE_UTFFILE'};

    Error("Internal: EnvVar 'GBE_UTFFILE' not specified") unless $filterData{OUTFILE};

    $filterData{UTFTEST} = $ENV{'GBE_UTFTEST'};

    Error("Internal: EnvVar 'GBE_UTFTEST' not specified") unless $filterData{UTFTEST};

    $filterData{IDIR} = File::Spec->rel2abs('.');

    #

    # The environment provides a recommended (unqiue) output file

    #   Extact the directory part and ensure that it exists

    #   Brute file filename chop

    #

    $filterData{OUTDIR} = $filterData{OUTFILE};

    $filterData{OUTDIR} =~ s~/[^/]*$~~;

    Error("Internal: OUTDIR is empty") unless (length($filterData{OUTDIR}) > 1);

    mkdir $filterData{OUTDIR};

    Error("Creating utfResults directory", "Path: $filterData{OUTDIR}") unless -d $filterData{OUTDIR};

    #   Allow the output file to be used

    #       Not in the build system, but in a user development area

    #

    my $filename = $filterData{OUTFILE};

    unlink $filename if -e $filename;

    Error("Output file: Cannot delete $filename: $!") if -e $filename;

    Verbose("Writing output to: $filename");

    #

    #   Change to the test directory

    #       Only if required

    #       Ensure that the specified directory exists

    #

    if (defined $filterData{DIR})

    {

        Verbose("Change directory:", $filterData{DIR});

        Error("Internal: Test directory does not exist: $filterData{DIR}")

            unless (-d $filterData{DIR});

        chdir $filterData{DIR} || Error("Internal: Could not chdir to: $filterData{DIR}");

    }

    #

    #   Recover the result code of the unit test run

    #

    if (defined $filterData{RCFILE}) {

        my $rcFile = $filterData{RCFILE};

        Verbose("Result Code File:", $rcFile);

        if (-f $rcFile)

        {

            open( my $rcFile, '<', $rcFile) || Error ("Cannot open file : $!");

            $filterData{UTFRC} = <$rcFile>;

            $filterData{UTFRC} =~ s~\s+$~~;

            $filterData{UTFRC} =~ s~^\s+~~;

            Verbose("Recover Result Code: ", $filterData{UTFRC});

            close $rcFile;

        } else {

            Error("ResultCode file specified, but not found: $rcFile");

        }

    } 

    #

    #   Diagnostics

    #

    if (IsVerbose(1))

    {

        DebugDumpData("Filter Parameters", \%filterData);

    }

    #

    #   Invoke the process method

    #   If it has a problem it should use 'Error(...)' to report it

    #   There is no exit code processing, but if there is - needs to be false

    #

    Message("Processing UTF test results using filter: $filterData{FILTER}");

    my $rv = $module_name->processUtf(\%filterData);

    Error ("Unit Test Failure: Errors detected in the result set")

        if ( defined($rv) && ! $rv );

}

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

# Function        : Write XML 

#

# Description     : Write user XML results to file

#                   Will insert standard data

#

# Inputs          : $options    - Ref to a hash of options

#                   $results    - Ref to an array of results

#                                 Expect a ref to an array of Hash Values

#

# Returns         : Nothing 

#

sub writeXmlResults

{

    my ($options, $results) = @_;

    # Create a summary report - more for the user

    my $summary;

    my $total = 0;

    foreach my $entry ( @$results) {

        if (exists $entry->{OUTCOME}) {

            $summary->{$entry->{OUTCOME}}++;

            $total++;

        }

    }

    my $summaryString = '';

    my $joiner = '';

    foreach my $entry ( sort keys %{$summary}) {

        $summaryString .= $joiner . $entry . ':' . $summary->{$entry};

        $joiner = ', ';

    }

    Message("Total: $total. $summaryString");

    #

    #   Create a data structure to contain the dummy test result

    #   Insert TARGET and TYPE attributes

    #

    my %xml;

    $xml{TestResults}{TARGET} = $options->{TARGET};

    $xml{TestResults}{TYPE} = $options->{TYPE};

    @{$xml{TestResults}{TestResult}} = @$results;

    #   The 'MESSAGE' key for failed tests forms the content of the

    #   <TestResult> element. Other keys are converted to attributes.

    #   Assign <TestResults> as the root XML node.

    my $xmlData = XMLout(\%xml, ContentKey => 'MESSAGE', RootName => 'TestResults', KeepRoot => 1);

    #   Write the data to the XML file.

    my $filename = $options->{OUTFILE};

    open ( my $outFile, ">", $filename)

        || Error(" Cannot open results file:$filename for writing: $!\n");

    print $outFile $xmlData;

    close $outFile;

}

=pod 1

=for htmltoc    SYSUTIL::

=head1 NAME

jats_runutf - Post Process UTF results for build system

=head1 SYNOPSIS

  $(GBE_PERL) -Mjats_runutf -e processUtf -- <args>

 Options:

    -help[=n]           - Brief help message

    -help -help         - Detailed help message

    -man                - Full documentation

    -verbose[=n]        - Verbose operation

    -filter=name        - Name of the required processing filter

    -target=name        - Current build target

    -root=path          - Path to the root of the build

    -pkgdir=path        - Path to the packaging directory

    -interface=path     - Path to the build interface directory

    -local=path         - Path to the local build directory

    -dir=path           - Path to test directory

    -rcfile=path        - Path to a file that contains the test result code

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

This option will display progress information as the program executes.

=item B<-filter=name>

Name of the required processing filter.

=item B<-target=name>

The current build target.

=item B<-root=path>

The path to the root of the current build.

=item B<-pkgdir=path>

The path to the packaging directory

=item B<-interface=path>

The path to the build interface directory

=item B<-local=path>

The path to the local build directory

=item B<-dir=path>

The path to the directory in which the test was run.

This is optional. If provided the filter will be invoked with the 

current working directory

=item B<-rcfile=path>

The path to the file that will contain the rsult code of the test run.

This is optional, but if provided it should exist

=back

=head1 DESCRIPTION

This tool is not designed to be run directly by users. It is intended to be run by the 

JATS generated makefiles in conjunction with unit tests to process the output from a unit 

test to provide a common output format to be passed on the build system.

Normally this process only occurs with the Auto BuildTool environment.

The tool provides the following operations:

=over 4

=item *

Sanitize environment

The environment passed to the filter processing module will be verified. 

The path to the output directory will be created if required. All paths will be absolute.

=item *

Locate the required filter processing module. The module must be a Perl Module with a name of the form 'UtfFilter_<name>'

=item *

Invoke the required filter module.

=back

=head2 Locating the Filter Module

The filter module may be located, in order of precedence, within:

=over 4

=item *

The package currently being built.

The package may provide its own UTF post processing module. This is not encouraged.

The following locations will be examined for a suitable module:

=over 4

=item *

The current directory. The directory of the makefile.pl that is running the unit test.

=item *

A directory in the Build Root called 'gbe/UtfFilters'

=back

=item *

An external Package, within the gbe/scripts directory.

The package can be specified with either LinkPkgArchive or BuildPkgArchive directive 

within the current packages build.pl file.

=item *

Within JATS.

Jats may provide useful filter modules.

=back

=head2 Filter Module Interface

The filter module Interface consists of four items:

=over 4

=item 1 The name of the Package

=item 1 The named function with the package

=item 1 Arguments passed to the named function

=item 1 The processing expected to be done by the named function

=item 1 The Output Format

=back

=head3 The name of the Package

Each filter function is in its own package. The package name is created by concatenating the 

text 'UtfFilter_' with the name of the required filter. 

ie: If the required filter is 'junit4', then the name of the filter package must 

be UtfFilter_junit4 and it will be held in a file named UtfFilter_junit4.pm.

=head3 The named function with the package

The filter package must provide a function called 'processUtf'

=head3 Arguments passed to the named function

The processing function 'processUtf' is called with two arguments:

=over 4

=item 1

The name of the package

=item 2

A reference to a Perl hash. The hash will contain the following named items:

=over 4

=item       ARGS          

Optional. A hash of User Arguments passed into the filter. Use of these is filter specific.

Arguments of the form '--UtfArg=UserArg1=Value1' will be stored with a key of 'UserArg1 and a value of 'Value1'.

Arguments of the form '--UtfArg=UserArg2' will be stored with a key of 'UserArg2' and an undefined value.

=item       DIR          

Optional. If the Unit Test is executed in a subdirectory of the current build 

location, then DIR will be set to the name of the subdirectory. 

The current working directory will be changed to DIR before the filter function is invoked. 

This item will aways exist, but it may not be defined.

=item       FILTER          

The Name of the filter 

=item       IDIR

The absolute path to the working directory, when the module is invoked, before the working

directory has been changed to 'DIR'.

=item       INTERFACE       

The absolute path to Interface directory

=item       LOCAL

The absolute path to Local directory

=item       OUTDIR

The absolute path to output directory

=item       OUTFILE

The absolute path to suggested output file. The user does not need to use this name. It is 

provided to remove the need for each filter to create a unique name.

This file will not exist.

=item       PKGDIR

The absolute path to Packaging directory. This directory will exist.

=item       ROOT

The absolute path to Root of the build

=item       TARGET

The current make target

=item       TYPE

The build type P or D

=item       UTFNAME

The name of the test.

This may be provided by the user, or it may be system generated. Intended to be used by 

test filters that do not have test names generated as a part of the test

=item       UTFUID

A unique test identifier. This is unique with the build and is intended to:

=over 4

=item   *

Allow the generation of test-unique file names for the storage of results.

=item *

Allow the reuse of output file names.

=back

=item       UTFRC

The result code from the unit test run.

This will only be defined for JATS run unit tests.

=back

The return value from the function 'processUtf' is ignored. If the function encounters 

any error it should use the Jats 'Error' function to report the error.

=back

=head3 The processing expected to be done by the named function

The processing function is expected to transform the results of a unit test into 

a constient form so that they can be processed by the remainder of the build tool.

The processing should:

=over 4

=item *

Create information in the OUTDIR directory. 

The filter may create a new file or insert information into an existing file. 

The user may make use of the OUTFILE path, but this is not mandatory.

=item *

Report errors by calling the Jats 'Error' function. This will terminate processing.

=back

=head3 The Output Format

Yet to be defined.

The output format is known to the build system. It should not be 

changed without also chnaging it for the consuming tools.

=cut

1;