Subversion Repositories DevTools

#! perl

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

# 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 create a makefile entry

#                 The entry may consist of the following (optional) fields

#

#                 .PHONY <targets>

#                 <targets> : VARAIBLE = VALUE

#                 <targets> : <prerequisites>

#                       @echo "Run time comment"

#                       Recipe

#                       ( ShellRecipe )

#

#                 The order that information is added is not important

#                 Recipes and prerequisites may be mixed to simplify

#                 programming.

#

#                 The --Define option creates

#                 define <name>

#                   Recipe

#                 endef

#

#                The --Raw option creates

#                   Recipe

#

#                The --Raw with --Phony option creates

#                   .PHONY <targets>

#                   <targets>:

#                       Recipe

#

#

#

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

use 5.006_001;

use strict;

use warnings;

package MakeEntry;

use JatsError;

use ArrayHashUtils;

#

#   Global variables

#

my $llength = 80;                           # Target line length

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

# Function        : New

#

# Description     : Create a new empty entry

#

# Inputs          : handle              - FILEHANDLE or variable ref

#                                         eg: *MAKEFILE     - print to handle

#                                              \$var        - print to variable

#

#                   name                - Primary target name

#                   options             - Preload the fields

#                           --Target=name,name,name

#                           --Comment=text

#                           --Prereq=name,name,name

#                           --Recipe=text

#                           --Phony

#                           --Define

#                           --Raw

#                           --Print

#

# Returns         : Ref to a an object that can be manipulated

#

sub New

{

    my ($handle, $name, @args ) = @_;

    my $self  = {};

    $self->{DEPENDANCY}     = [];

    $self->{NAME}           = [];

    $self->{RECIPE}         = [];

    $self->{SHELL}          = [];

    $self->{PRINTED}        = 0;

    $self->{COMMENT}        = [];

    $self->{DEFN}           = {};

    $self->{PHONY}          = 0;

    $self->{DEFINE}         = 0;

    $self->{RAW}            = 0;

    $self->{FH}             = $handle;

    $self->{FH_inmemory}    = 0;

    $self->{RECIPE_PREFIX}  = '';

    $self->{RECIPE_WRAPPER}  = ['(', ')'];

    $self->{RECIPE_COMMENT} = '';

    $self->{STACK}          = [];

    $self->{SDEF}           = '';

    push @{$self->{NAME}}, split(/,/,$name) if ( $name );

    bless ($self, __PACKAGE__);

    #

    #   Process any argument

    #

    my $print = 0;

    foreach ( @args )

    {

        if ( m/^--Target=(.*)/ ) {

            $self->AddName(split(/,/,$1));

        } elsif ( m/^--Comment=(.*)/ ) {

            $self->AddComment($1);

        } elsif ( m/^--Prereq=(.*)/ ) {

            $self->AddDependancy(split(/,/,$1));

        } elsif ( m/^--Phony/ ) {

            $self->Phony();

        } elsif ( m/^--Define/ ) {

            $self->Define();

        } elsif ( m/^--Raw/ ) {

            $self->Raw();

        } elsif ( m/^--Recipe=(.*)/ ) {

            $self->AddRecipe($1);

        } elsif ( m/^--Print/ ) {

            $print = 1;

        } elsif ( m/^--/ ) {

            Error ("MakeEntry: Unknown option: $_");

        } else {

            $self->AddDependancy( $_ );

        }

    }

    #

    #   Set up the printer handle

    #   May be

    #       Empty           - use stderr

    #       ref to a scalar - use in memory file

    #       typeglob        - normal handle

    #

    if ( ref $handle eq 'SCALAR' )

    {

        $$handle = '' if ( ! defined $$handle );

        open(MEMORY,'>>', $handle) || Error ("Cannot open in-memory file");

        $self->{FH_inmemory} = $handle;

        $self->{FH} = \*MEMORY;

    } elsif ( ! $handle ) {

       $self->{FH} = \*STDERR;

    }

    #

    #   Print simple entry if required

    #

    $self->Print() if ( $print );

    return $self;

}

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

# Function        : AddName

#

# Description     : Add a target name to the entry

#

# Inputs          : An array of names to add

#

# Returns         :

#

sub AddName

{

    my $self = shift;

    push @{$self->{NAME}}, @_

}

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

# Function        : Phony

#

# Description     : Flag the entry as a phony

#

# Inputs          :

#

# Returns         :

#

sub Phony

{

    my $self = shift;

    $self->{PHONY} = 1;

}

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

# Function        : Define

#

# Description     : Flag the entry as a define, rather than a normal target

#                   Many of the other commands are not supported

#                   Only AddComment and AddRecipe

#

# Inputs          :

#

# Returns         :

#

sub Define

{

    my $self = shift;

    $self->{DEFINE} = 1;

}

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

# Function        : Raw

#

# Description     : Flag the entry as raw text

#                   Many of the other commands are not supported

#                   Only AddComment and AddRecipe

#

# Inputs          :

#

# Returns         :

#

sub Raw

{

    my $self = shift;

    $self->{RAW} = 1;

}

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

# Function        : AddComment

#

# Description     : Add a comment to the entry

#

# Inputs          : An array of names to add

#

# Returns         :

#

sub AddComment

{

    my $self = shift;

    push @{$self->{COMMENT}}, @_

}

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

# Function        : QuoteDependency

#

# Description     : Escape/Quote a pathname for make

#                       Allow files with a $ in the name

#                       Allow files with a space in the name

#                       Allow files with a comma in the name

#                       Allow files with a colon in the name

#                       Allow for paths that have make-varible prefixes

#                           $(GBE_...) or ${GBE_...} or $(OBJDIR)

#                           as these may be generated internally

#

#                       Must also allow $(GBE_TYPE) in the remainder

#

# Inputs          : uarg                - Arg to quote

#

# Returns         : Quoted arg

#

sub QuoteDependency

{

    my ($uarg) = @_;

    #

    #   Split into two

    #       $(xxx)/             - Makefile variables

    #       Remainder           - Stuff to quote

    #

    $uarg =~ m~^((\$\(.*?\)/)*)(.*)~;

    my $prefix = defined $1 ? $1 : '';

    my $arg    = defined $3 ? $3 : '';

    $arg =~ s~\$(?!\(GBE_[A-Z]+\)|{GBE_[A-Z]+}|\(OBJDIR\))~\$\$~g;       # $, not followed by (GBE_ or ${GBE_ or (OBJDIR)- is not $(GBE_ AND not $(OBJDIR)

    $arg =~ s~ ~\\ ~g;

    $arg =~ s~,~\$(comma)~g;

    $arg =~ s~%~\\%~g;

    $arg =~ s~:~\\:~g if ($::ScmHost eq 'Unix');

    return $prefix . $arg;

}

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

# Function        : AddDependancyEscaped

#

# Description     : Add a dependancy to the entry and Quote the value so that

#                   it can be it can be processed by make

#

# Inputs          : An array of dependencies to add

#

# Returns         :

#

sub AddDependancyEscaped

{

    my $self = shift;

    my @escaped;

    push @escaped, QuoteDependency($_) foreach (@_);

    UniquePush $self->{DEPENDANCY}, @escaped ;

}

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

# Function        : AddDependancy

#

# Description     : Add a dependancy to the entry

#                   These will not be escaped.

#

# Inputs          : An array of dependencies to add

#

# Returns         :

#

sub AddDependancy

{

    my $self = shift;

    UniquePush $self->{DEPENDANCY}, @_ ;

}

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

# Function        : AddDefn

#

# Description     : Add a definition to the entry

#

# Inputs          : A hash of definitions to add

#                   The Hash gets lost in the subcall. Its simply a list

#                   of NAME, VALUE pairs

#

# Returns         :

#

sub AddDefn

{

    my $self = shift;

    while ( @_ )

    {

        my $defn = shift;

        my $value = shift || '';

        $self->{DEFN}{$defn} = $value;

    }

}

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

# Function        : RecipePrefix

#

# Description     : Set the recipe prefix

#                   This will be added to ALL recipe entries

#

# Inputs          :

#

# Returns         :

#

sub RecipePrefix

{

    my $self = shift;

    my $prefix = shift || '';

    $self->{RECIPE_PREFIX} = $prefix;

}

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

# Function        : RecipeComment

#

# Description     : Add a runtime comment to the entry

#

# Inputs          : String to print at runtime

#

# Returns         :

#

sub RecipeComment

{

    my $self = shift;

    $self->{RECIPE_COMMENT} = join( ' ', @_);

}

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

# Function        : RecipeWrapper

#

# Description     : Add a wrapper around the recipe

#

# Inputs          : begin   - Start of wrapper

#                   end     - End of wrapper

#

# Returns         :

#

sub RecipeWrapper

{

    my $self = shift;

    Error("RecipeWrapper requires exacly two arguments") unless scalar @_ == 2;

    my ($begin, $end) = @_;

    $self->{RECIPE_WRAPPER}[0] = $begin;

    $self->{RECIPE_WRAPPER}[1] = $end;

}

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

# Function        : AddRecipe

#

# Description     : Add a line to the line-by-line recipe

#

# Inputs          : One or more recipe lines

#                   Each line of the recipe will be prefixed with the current

#                   recipe prefix.

#

#                   An array will be treated as a recipe with implicit line

#                   breaks for formatting purposes.

#

# Returns         :

#

sub AddRecipe

{

    my $self = shift;

    my $prefix = $self->{RECIPE_PREFIX};

    foreach ( @_ )

    {

        if (ref($_) eq "ARRAY")

        {

            $_->[0] = $prefix . $_->[0];

            push @{$self->{RECIPE}}, $_;

        }

        else

        {

            push @{$self->{RECIPE}}, $prefix . $_;

        }

    }

}

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

# Function        : AddShellRecipe

#

# Description     : Add recipe lines that will be processed within a 'shell'

#

# Inputs          : One or more recipe lines

#

#                   An array will be treated as a recipe with implicit line

#                   breaks for formatting purposes.

#

# Returns         :

#

sub AddShellRecipe

{

    my $self = shift;

    push @{$self->{SHELL}}, @_

}

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

# Function        : NewSection 

#

# Description     : Create a new section within the current recipe

#                   Only used within a standard recipe (not raw or defined)

#                   Used to create multiple sections in cases with multiple shell

#                   and recipe sections.

#

#                   Save existing entries and start again

#

# Inputs          : None 

#

# Returns         : 

#

sub NewSection

{

    my $self = shift;

    my %data;

    $data{RECIPE}           = $self->{RECIPE};

    $data{SHELL}            = $self->{SHELL};

    $data{RECIPE_PREFIX}    = $self->{RECIPE_PREFIX};

    $data{RECIPE_COMMENT}   = $self->{RECIPE_COMMENT};

    $data{RECIPE_WRAPPER}   = $self->{RECIPE_WRAPPER};

    $data{SDEF}             = $self->{SDEF};

    push @{$self->{STACK}}, \%data;

    $self->{RECIPE}         = []; 

    $self->{SHELL}          = [];

    $self->{RECIPE_PREFIX}  = '';

    $self->{RECIPE_COMMENT} = '';

    $self->{RECIPE_WRAPPER} = ['(', ')'];

    $self->{SDEF}           = '';

}

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

# Function        : SectionIfDef 

#

# Description     : Place the current section within a ifdef ... endif block

#

# Inputs          : defn        - Definition to use within the ifdef construct 

#

# Returns         : Nothing

#

sub SectionIfDef

{

    my $self = shift;

    $self->{SDEF} = $_[0];

}

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

# Function        : Print

#

# Description     : Print the entry

#

# Inputs          : None

#

# Returns         : Nothing

#

sub Print

{

    my $self = shift;

    #

    #   Set the default print stream to the desired stream

    #   This greatly simplifies the use of print

    #

    my $fh = $self->{FH};

    my $old_fh = select($fh);

    #

    #   A nice comment header

    #

    if ( @{$self->{COMMENT}} )

    {

        print( "#\n" );

        print map {"# $_\n"} @{$self->{COMMENT}};

        print( "#\n" );

    }

    #

    #   Print the targets

    #   Print PHONY information

    #   Print on multiple lines if multiple targets are very long

    #

    if ( $self->{PHONY} )

    {

        my $phony_string = ".PHONY: ";

        my $tstring = join $;, @{$self->{NAME}};

        my $join = length ($tstring) < $llength ? ' ' : "\n$phony_string";

        $tstring =~ s~$;~$join~g;

        print "$phony_string$tstring\n";

    }

    #

    #   Print any definitions

    #       target: DEFN := VALUE

    #

    if ( $self->{DEFN}  )

    {

        my $tstring = join $;, @{$self->{NAME}};

        my $join = length ($tstring) < $llength ? ' ' : " \\\n    ";

        $tstring =~ s~$;~$join~g;

        foreach  ( keys %{$self->{DEFN}}  )

        {

            my $value = $self->{DEFN} {$_};

            print( "$tstring: $_ := $value\n" );

        }

    }

    if ( $self->{RAW}  )

    {

        if ( $self->{PHONY} )

        {

            my $tstring = $self->{NAME}[0];

            print($tstring . ":\n");

        }

        my $tstring = join ("\n", @{$self->{RECIPE}});

        print $tstring;

    }

    elsif ( $self->{DEFINE}  )

    {

        my $tstring = $self->{NAME}[0];

        print "define $tstring";

        print_list ( '', '', $self->{RECIPE}, '');

        print "\nendef";

    }

    else

    {

        #

        #   Print the main target name

        #   Print on multiple lines if multiple targets are very long

        #

        my $tstring = join $;, @{$self->{NAME}};

        my $join = length ($tstring) < $llength ? ' ' : " \\\n";

        $tstring =~ s~$;~$join~g;

        my $nlength = length $tstring;

        print "$tstring:";

        #

        #   Print the prerequisites

        #   Print on multiple lines if long

        #

        $tstring = join $;, @{$self->{DEPENDANCY}};

        $join = $nlength + length ($tstring) < $llength ? ' ' : " \\\n\t";

        $tstring =~ s~$;~$join~g;

        print $join . $tstring;

        #

        #   Push the current section onto the stack

        #   This will simplify processing of all sections

        #

        $self->NewSection();

        foreach my $recipeEntry (@{$self->{STACK}})

        {

            my $comment = $recipeEntry->{RECIPE_COMMENT};

            my $wrapper = $recipeEntry->{RECIPE_WRAPPER};

            my $prefix =  $recipeEntry->{RECIPE_PREFIX};

            my $recipe =  $recipeEntry->{RECIPE};

            my $shell =   $recipeEntry->{SHELL};

            my $sdef =    $recipeEntry->{SDEF};

            if ($sdef)

            {

                print "\nifdef $sdef";

            }

            #

            #   Print the Recipe runtime comment

            #

            if ( $comment )

            {

                print "\n\t\@echo \"$comment\"";

            }

            #

            #   Print the recipe

            #

            print_list ( '', '', $recipe, '');

            #

            #   Print the recipe as a shell command

            #   Bracket the recipes with ( .. ) and place semi colons between lines

            #   Use the current recipe prefix

            #

            print_list ( $prefix . $wrapper->[0], ';\\', $shell, $wrapper->[1]);

            if ($sdef)

            {

                print "\nendif";

            }

        }

    }

    print "\n\n";

    #

    #   Flag the entry as having been printed

    #   Used as a sanity test when the object is destroyed

    #

    $self->{PRINT} = 1;

    #

    #   Restore default output stream handle

    #

    select($old_fh);

}

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

# Function        : print_list

#

# Description     : Internal helper rouitine

#

# Inputs          : $prefix     - Optional prefix to wrap the list

#                                 If present will cause extra indentation

#                   $linesep    - Line seperator string

#                   $ref        - Ref to the list to display

#                                 Each element will be a line of text, or an

#                                 array of arguments which will be displayed on

#                                 new lines for pretty printing

#                   $suffix     - Optional suffix.

#

# Returns         :

#

sub print_list

{

    my ($prefix, $linesep ,$ref, $suffix) = @_;

    my @entry = @{$ref};

    my $leadin = "\t";

    if ( @entry  )

    {

        if ( $prefix )

        {

            print( "\n" . $leadin . $prefix . "\\" );

            $leadin .= "\t";

        }

        foreach ( @entry )

        {

            if (ref($_) eq "ARRAY")

            {

                my @array = @{$_};

                my $indent = '';

                my $tail = '';

                foreach ( @array )

                {

                    print( $tail . "\n" . $leadin . $indent . $_ );

                    $indent = "\t";

                    $tail = " \\";

                }

                print $linesep;

            }

            else

            {

                print( "\n" . $leadin . $_ . $linesep );

            }

        }

        if ( $suffix )

        {

            $leadin = chop($leadin) if ($prefix);

            print( "\n" . $leadin . $suffix );

        }

    }

}

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

# Function        : DESTROY

#

# Description     : Sanity test

#

# Inputs          :

#

# Returns         :

#

sub DESTROY

{

    my $self = shift;

    unless ($self->{PRINT} )

    {

        $self->{PRINT} = 1;

        Error ("Destroying MakeEntry before printing.",

               "Name: @{$self->{NAME}}");

    }

    #

    #   If using an in-memory file close the handle

    #

    close $self->{FH} if ( $self->{FH_inmemory} );

}

1;