Subversion Repositories DevTools

# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.
#
# Module name   : jats.sh
# Module type   : Perl Package
# Compiler(s)   : n/a
# Environment(s): jats
#
# Description   : This package contains functions to manipulate desckpkg files
#
# Usage:
#
# Version   Who      Date        Description
#
#......................................................................#

require 5.006_001;
use strict;
use warnings;

package DescPkg;

our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
use Exporter;
use JatsVersionUtils;
use JatsEnv;

$VERSION = 1.00;
@ISA = qw(Exporter);

# Symbols to autoexport (:DEFAULT tag)
@EXPORT = qw( ReadDescpkg
              CopyDescpkg
            );

#-------------------------------------------------------------------------------
# Function        : ReadDescpkg
#
# Description     : Read in a descpkg file
#                   Support both old and new formats of the file
#
# Inputs          : path    - path of the file to process
#                   mode    - 1 == process dependancies
#
# Returns         : undef if the file was not found
#                   Pointer to a hash of useful information
#
sub ReadDescpkg
{
    my ($path, $mode) = @_;
    my $line;
    my $rec;
    my $ver_string;

    open (DESCPKG, "$path") || return undef;

    #
    #  Slurp the first line and determine the type of the file
    #  If the descpkg file is empty then this is an error
    #
    $line = <DESCPKG>;
    if ( ! $line )
    {
        close DESCPKG;
        return undef;
    }
    elsif ( $line =~ m/^Manifest-Version:/ )
    {
        #
        #   Manifest form
        #
        my $section;
        while ( defined( $line = <DESCPKG> ) )
        {
            $line =~ s~\s+$~~;                              # Kill DOS and UNIX line endings

            #
            #   Detect section break;
            #
            if ( $line =~ m/^Name:\s*(.*)/ )
            {
                $section = $1;
                next;
            }
            next unless ( $section );

            #
            #   Extract Build Properties
            #
            if ( $section eq "Build Properties" )
            {
                if ( $line =~ m/^Package Name:\s*(.*)/ )
                {
                    $rec->{'NAME'} = $1;
                }
                elsif ( $line =~ m/^Package Version:\s*(.*)$/ )
                {
                    $ver_string = $1;
                }
            }
            elsif ( $mode && $section eq "Build Dependencies" )
            {
                my %data;
                if ( $line =~ m/(.*):\s*(.*)/ )
                {
                    $data{name} = $1;
                    $data{version} = $2;
                    push @{$rec->{'PACKAGES'}}, \%data;
                }
            }
        }
    }
    elsif ( $line =~ m/^Package Name:\s/ )
    {
        #
        #   New form
        #
        while ( 1 )
        {
            $line =~ s~\s+$~~;                              # Kill DOS and UNIX line endings
            if ( $line =~ m/^Package Name:\s*(.*)/ )
            {
                $rec->{'NAME'} = $1;
            }
            elsif ( $line =~ m/^Version:\s*(.*)$/ )
            {
                    $ver_string = $1;
            }
            elsif ( $line =~ m/^Build Dependencies:/ )
            {
                last;
            }
            last unless ( defined ($line = <DESCPKG>) )
        }

        #
        #   Extract dependancies
        #   Keep the order of the dependancies as this may be important
        #   These are stored in an array of hashes.
        #
        #   Locate lines of the form:
        #       <sandbox .... />
        #   and extract all attributes. These are of the form
        #       attribute_name="attribute_value"
        #   The values are stored in a hash for later use
        #
        if ( $mode )
        {
            while ( defined( $line = <DESCPKG> ) )
            {
                $line =~ s~\s+$~~;                              # Kill DOS and UNIX line endings
                if ( $line =~ m~<sandbox\s+(.*)/>~ )
                {
                    my $raw = $1;
                    my $data;
                    while ( $raw =~ m/(\w*?)="(.*?)"/g )
                    {
                        $data->{$1} = $2;
                    }
                    push @{$rec->{'PACKAGES'}}, $data;
                }
            }
        }
    }
    else
    {
        #
        #   Old form
        #   Cleanup various bad habits
        #       1) Remove trailing comments ie: space-space
        #       2) Replace , with a space
        #
        $line =~ s~\s+-\s+.*~~;
        $line =~ s~,~ ~g;

        my $proj;
        ($rec->{'NAME'}, $ver_string, $proj) = split( ' ', $line );
        #
        #   Attempt to correct for a common error in old packages
        #   where the project is attached to to the version
        #   ie: name 1.2.3.cr instead of name 1.2.3 cr
        #
        $ver_string .= '.' . $proj if ( $proj );
    }

    close DESCPKG;

    #
    #   Ensure the package Name has been found
    #
    return undef
        unless ( exists ($rec->{'NAME'}) && $rec->{'NAME'} && $ver_string );

    #
    #   Split the version string into bits and save the results
    #
    (
     $rec->{'NAME'},
     $rec->{'VERSION'},
     $rec->{'PROJ'},
     $rec->{'VERSION_FULL'} ) = SplitPackage( $rec->{'NAME'} ,$ver_string);
        
    return $rec;
}

#-------------------------------------------------------------------------------
# Function        : CopyDescpkg
#
# Description     : Copy a descpkg file and update various fields
#                   Several fields will be re-written or modified
#                   Used when creating a package to maintain package contents
#                   Supports all the formats of descpkg
#
# Inputs          : $src       - Source Path
#                   $dest      - Destination path
#
#
# Returns         : 0    - All is well
#                   Else - Error string
#
#
sub CopyDescpkg
{
    my ($src,$dest) = @_;

    #
    #   Ensure that we have user and machine name
    #
    EnvImport( "USER");
    EnvImport( "GBE_HOSTNAME");

    #
    #   Open files
    #
    open (DESCPKG, "<$src") || return "File not found [$src]";
    open (DESCPKGOUT, ">$dest")    || return "Failed to create file [$dest]";

    #
    #   Need to sniff the header of the file to determine which type of file
    #   it is. There are several types of file
    #
    my $line = <DESCPKG>;
    $line =~ s~\s+$~~;                              # Kill DOS and UNIX line endings
    return ("Empty descpkg file: $src") unless ( $line );
    print DESCPKGOUT $line, "\n";

    if ( $line =~ m/^Manifest-Version:/ )
    {
        ########################################################################
        #   Manifest format
        #
        my $active = 'h';
        my %attributes =
                (
                    'Built By:'         => $::USER,
                    'Built On:'         => scalar( localtime()),
                    'Build Machine:'    => $::GBE_HOSTNAME
                );

        while ( $line = <DESCPKG> )
        {
            $line =~ s~\s+$~~;                              # Kill DOS and UNIX line endings
            if ( $active eq 'h' )
            {
                #
                #   Hunt for the Build Properties section
                #
                if ( $line =~ m/^Name: Build Properties/ )
                {
                    $active = 'p';
                }
            }
            elsif ($line)
            {
                #
                #   Process Build Properties
                #

                #
                #   Extract attribute name
                #   Pass on those we don't know
                #   Susbstitute those we do
                #
                $line =~ m/^(.*?:)\s+(.*)/;
                if ( exists $attributes{$1} )
                {
                    $line = "$1 $attributes{$1}";
                    delete $attributes{$1};
                }
            }
            else
            {
                $active = 'h';

                #
                #   End of the section
                #   Write out attributes not already processed
                #
                foreach  ( sort keys %attributes )
                {
                    print DESCPKGOUT "$_ $attributes{$_}\n";
                }
            }
        }
        continue
        {
            print DESCPKGOUT $line, "\n";
        }
    }
    elsif ( $line =~ m/^Package Name: / )
    {
        ########################################################################
        #   Original JATS format
        #
        while ( $line = <DESCPKG> )
        {
            $line =~ s~\s+$~~;                              # Kill DOS and UNIX line endings
            if ( $line =~ m/^(Released By:\s+)/ ) {
                $line = $1 . $::USER;

            }
            elsif ( $line =~ m/^(Released On:\s+)/ ) {
                $line = $1 . localtime();
            }
        }
        continue
        {
            print DESCPKGOUT $line, "\n";
        }
    }
    else
    {
        ########################################################################
        #   Naughty format
        #   Possible a very old format
        #
        while ( $line = <DESCPKG> )
        {
            print DESCPKGOUT $line;
        }
    }

    close DESCPKG;
    close DESCPKGOUT;
    return undef;
}

1;