Subversion Repositories DevTools

#! perl

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

# Copyright ( C ) 2005 ERG Limited, 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;