Subversion Repositories DevTools

########################################################################
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
#
# Module name   : JatsFileSet.pm
# Module type   : Makefile system
# Compiler(s)   : Perl
# Environment(s): jats
#
# Description   : Package to simplify the process of locating one or more
#                 files with the JATS build environment.
#
#                 Specifically designed to assist in the creation of:
#                       Day0 file systems
#                       Debian Packages
#                       Deployable packages
#
#                 Intended to locate files in dependent packages
#                 Supports LinkPkgArchive and BuildPkgArchive
#
#                 Knows about the construction of programs and shared
#                 libraries as well as other special file types.
#
#                 Uses a set of options to identify the file
#                 The file specifier is of the form
#                       Name[,--Option]+
#
#                 Available Options are:
#                       --prog          - Name is a program
#                                         Search where programs are stored
#                                         Append the target specific suffix
#                       --bin           - Similar to --prog, but does not modify
#                                         the provided name.
#                       --header        - Searches header file locations
#                       --deb           - Name is the base of a Debian Package
#                                         Searchs in BIN directories
#                       --dir=SubDir    - Search for Name in a subdir of the
#                                         dependent packages
#                       --pkg           - Search for Name in a pkg subdir
#                                         Limited by the current target
#                       --etc           - Same as --dir=etc
#                       --jar           - Same as --dir=jar
#                       --scripts       - Same as --dir=scripts
#
#                       --AllowMultiple - Allow multiple files to be located
#                       --AllowNone     - Allow no file to be located
#                       --Verbose       - Be a bit verbose about the process
#
#                       --FilterOutRe=xxx - An Re to filter out
#                       --FilterOut=xxx   - An glob to filter out
#
# Usage:
#
#   @data = JatsFileSet::LocateFile('MyProg,--prog');
#
#......................................................................#

require 5.008_002;

package JatsFileSet;

use strict;
use warnings;

use JatsError;
use JatsMakeConfig;
use FileUtils;

#
#   Globals
#
my  $data;                                  # Global Data
my %DirCache;
my %ReadDirCache;

#
#   Hash of known file location specifications
#   Only allowed to have one in any one definition
#
my %LocSpec = (
    'local'         => { code => \&searchLocal },
    'header'        => { code => \&searchInc },
    'prog'          => { code => \&searchProg },
    'bin'           => { code => \&searchBin },
    'deb'           => { code => \&searchDeb },
    'dir'           => { code => \&searchDir },
    'pkg'           => { code => \&searchPkg },
    'lib'           => { code => \&searchLib },
    'etc'           => { code => \&searchSimple, dir => 'etc' },
    'jar'           => { code => \&searchSimple, dir => 'jar'},
    'scripts'       => { code => \&searchSimple, dir => 'scripts'},
    'doc'           => { code => \&searchSimple, dir => 'doc'},
#    'thx'           => 1,
#    'jar'           => 1,
#    'local'         => 1,
#    'interface'     => 1,
);

#-------------------------------------------------------------------------------
# Function        : BEGIN
#
# Description     : Standard Package Interface
#
# Inputs          :
#
# Returns         :
#
BEGIN {
    use Exporter   ();
    our @ISA         = qw(Exporter);
    our @EXPORT      = qw(
                    FileSet
                      );

    our %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
    our @EXPORT_OK   = qw();    # Allowed exports
}

#-------------------------------------------------------------------------------
# Function        : import
#
# Description     : Package import function
#                   This function will examine arguments provided in the
#                   invoking 'uses' list and will configure the package
#                   accordingly.
#
# Inputs          : $pack           - Name of this package
#                   @vars           - User Config Options
#                   Config Options:
#                       :verbose=xxx
#                       :allowmultiple=xxx
#                       :allownone=xxx
#
# Returns         : 
#
sub import {
    my $pack = shift;
    my @vars;
    my @config;

    #
    #   Extract options of the form: :name=value and pass them to the
    #   ErrorConfig function. All other arguments will be passed to the
    #
    foreach ( @_ )
    {
        if ( m/^:verbose=(\d+)/i ) {
            $data->{'verbose'} = $1;

        } elsif ( m/^:allowmultiple=(\d+)/i ) {
            $data->{'allowmultiple'} = $1;

        } elsif ( m/^:allownone=(\d+)/i ) {
            $data->{'allownone'} = $1;

        } else {
            push @vars, $_;
        }
    }

    #
    #   Invoke Exporter function to handle the arguments that I don't understand
    #
    $pack->export_to_level(1, $pack , @vars);
}


#-------------------------------------------------------------------------------
# Function        : BEGIN
#
# Description     : Initialisation
#                   Load information create when the invoking makefile was
#                   created. This contains a lot of information
#                   as to the interface to the package
#
# Inputs          : None
#
# Returns         : Nothing
#
sub BEGIN
{
    #
    #   Load all the MakeFile generate information and  data structures
    #
    my $mi = JatsMakeConfigLoader::Load();

    #
    #   Document Class Variables
    #
    $data->{'platform'} = $mi->{'PLATFORM'};
    $data->{'type'}     = $mi->{'TYPE'};

    #
    #   Locate required entries
    #
    my @result;
    for my $entry ( @{$mi->GetDataItem('%ScmBuildPkgRules')} )
    {
        #
        #   If a BuildPkgArchive, then skip as its data will be embedded
        #   in the pseudo INTERFACE package
        #
        next if ( ($entry->{'TYPE'} eq 'build' ) );
        push @result, $entry->{'ROOT'};

    }

    $data->{'BuildPaths'} = \@result;
    $data->{'BuildParts'} = $mi->GetDataItem('%BUILDPLATFORM_PARTS');

    $data->{'a'}    =  $mi->GetDataItem('$a');
    $data->{'exe'}  =  $mi->GetDataItem('$exe');
    $data->{'so'}   =  $mi->GetDataItem('$so');

#    DebugDumpData(__PACKAGE__, $data );
}

#-------------------------------------------------------------------------------
# Function        : LocateFile
#
# Description     : Locate a file as specified by a user description
#
# Inputs          : $fspec                  - A file specification
#
# Returns         : A list of files that match
#                   May not return on error
#
sub LocateFile
{
    my ($fspec) = @_;
    my $mode;
    my $estate = ErrorReConfig ('function' => 'LocateFile');

    #
    #   Create a new instance using default data
    #
    my $self;
    while (my ($key, $value) = each %{$data} ) {
        $self->{$key} = $value;
    }

    bless ($self, __PACKAGE__);

    #
    #   Split the file spec into bits
    #   Extract options and the base file name
    #       Create a hash of options
    #       Convert options to lowercase
    #       Extract any assignments
    #       Treat --Flag as --Flag=1
    #
    $self->{'uspec'} = $fspec;
    while ( $fspec =~ m~^(.*),--(.*?)(=(.*?))?,*$~ )
    {
        $fspec = $1;
        my $opt = lc($2);

        #
        #   Process options
        #
        if ( $opt eq 'filteroutre' ) {
            push @{$self->{$opt}}, $4;

        } elsif ( $opt eq 'filterout' ) {
            push @{$self->{'filteroutre'}}, glob2pat($4);

        } elsif ( exists $LocSpec{$opt} ) {
            $mode = $LocSpec{$opt}

        } else {
            $self->{$opt} = defined($3) ? $4 : 1;
        }
    }
    #
    #   Merge system and user verbose mode
    #   Reconfigure the error control
    #
    if ( $self->{'verbose'} )
    {
        ErrorConfig ( 'verbose' =>  $self->{'verbose'} );
    }

    #
    #   Save the remainder as the filename
    #   It may not exist
    #
    $self->{'file'} = $fspec;
    $self->{'wildcard'} = ($fspec =~ m~[*?\[\]]~);

    #
    #   Determine the processing mode
    #
    $mode = $LocSpec{'local'} unless ( $mode );
    $self->{'Mode'} = $mode;

    #
    #   Error check - Internal sanity
    #
#    DebugDumpData(__PACKAGE__, $self );
    unless ( $mode->{'code'} )
    {
        DebugDumpData("File", $self);
        Error ("INTERNAL. Unknown search method: @_");
    }

    #
    #   Dispatch to a suitable processing routine
    #
    my @result = ( $mode->{'code'}( $self ) );

    @result = FilterRemove ( $self, \@result )
        if ( $self->{'wildcard'} );

    #
    #   Generate errors and warnings
    #
    if ( $#result < 0 )
    {
        Error ("No Files found: $self->{'uspec'}", $#result )
            unless ( $self->{'allownone'} );
    }

    if ( $#result > 0 )
    {
        Error ("Mutliple Files found: $self->{'uspec'}", @result )
            unless ( $self->{'allowmultiple'} );

        Warning("Mutliple Files found. Only the first will be used: $self->{'uspec'}", @result )
            unless ( wantarray );
    }

    #
    #   Create verbose output for the user
    #
    Verbose("LocateFiles: $self->{'uspec'}. Results:", @result );

    #
    #   Provide the user the required result
    #
    return wantarray ? @result : $result[0];
}

#-------------------------------------------------------------------------------
# Function        : searchLocal
#
# Description     : Looking for a file in the local file system
#                   This is the default mode of operation
#
# Inputs          : $self                   - Instance Data
#
# Returns         : Array of files that have been found
#
sub searchLocal
{
    my ($self) = @_;
    my @results;
    my $ufile = $self->{'file'};

    #
    #   Simple search
    #
    if ( ! $self->{'wildcard'} )
    {
        push @results, $ufile  if ( -f $ufile );
        return @results;
    }

    #
    #   Wildcarded Search
    #
    my $dir = StripFileExt( $ufile ) || '.';
    $ufile = StripDir( $ufile );

    foreach  ( ReadDir($dir) )
    {
        Verbose2 ("Test: $_, $ufile");
        push @results, $_  if ( $_ =~ "/$ufile\$" );
    }
    return @results;
}


#-------------------------------------------------------------------------------
# Function        : searchLib
#
# Description     : The user is looking for a shared library file
#                   It will have a specific extension
#                   It will be in one of the 'lib' directories known to JATS
#
#                   Current Limitations:
#                       Does not perform Unix Lib Prefix
#                       Does not handle Name.version.so
#                       Does not handle 'so' Name and 'real' name pairs
#
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchLib
{
    my ($self) = @_;

    my $ufile = $self->{'file'};
    my $ext =  $self->{so} ? '.' . $self->{a} : '';
    my @results;
    foreach my $dir ( @{ FancyDirs($self, 'lib') } )
    {
        foreach  ( ReadDir($dir) )
        {
            foreach my $type ( $self->{'type'}, '' )
            {
Verbose2 ("Test: $_, $ufile");
                push @results, $_  if ( $_ =~ "/$ufile$type$ext\$" );
            }
        }
    }
    return @results;
}


#-------------------------------------------------------------------------------
# Function        : searchProg
#
# Description     : The user is looking for a program file
#                   It will have a specific extension
#                   It will be in one of the 'Bin' directories known to JATS
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchProg
{
    my ($self) = @_;

    my $ufile = $self->{'file'} . $self->{exe};
    my @results;
    foreach my $dir ( @{ FancyDirs($self, 'bin') } )
    {
        foreach  ( ReadDir($dir) )
        {
Verbose2 ("Test: $_, $ufile");
            push @results, $_  if ( $_ =~ "/$ufile\$" );
        }
    }
    return @results;
}

#-------------------------------------------------------------------------------
# Function        : searchBin
#
# Description     : The user is looking for a program file
#                   It will be in one of the 'Bin' directories known to JATS
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchBin
{
    my ($self) = @_;

    my $ufile = $self->{'file'};
    my @results;
    foreach my $dir ( @{ FancyDirs($self, 'bin') } )
    {
        foreach  ( ReadDir($dir) )
        {
Verbose2 ("Test: $_, $ufile");
            push @results, $_  if ( $_ =~ "/$ufile\$" );
        }
    }
    return @results;
}

#-------------------------------------------------------------------------------
# Function        : searchInc
#
# Description     : The user is looking for a program file
#                   It will be in one of the 'include' directories known to JATS
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchInc
{
    my ($self) = @_;

    my $ufile = $self->{'file'};
    my @results;
    foreach my $dir ( @{ FancyDirs($self, 'include', 'inc') } )
    {
        foreach  ( ReadDir($dir) )
        {
Verbose2 ("Test: $_, $ufile");
            push @results, $_  if ( $_ =~ "/$ufile\$" );
        }
    }
    return @results;
}



#-------------------------------------------------------------------------------
# Function        : searchDeb
#
# Description     : The user is looking for a Debian Package
#                   It will have a specific extension
#                   It will be in one of the 'Bin' directories known to JATS
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchDeb
{
    my ($self) = @_;

    my $ufile = $self->{'file'};
    my @results;
    foreach my $dir ( @{ FancyDirs($self, 'bin') } )
    {
        foreach  ( ReadDir($dir) )
        {
Verbose2 ("Test: $_, $ufile");
            push @results, $_  if ( $_ =~ "$dir/$self->{file}_*.deb" );
        }
    }
    return @results;
}

#-------------------------------------------------------------------------------
# Function        : searchDir
#
# Description     : The user is looking for a file in a package subdir
#                   It will be in one of the package directories
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchDir
{
    my ($self) = @_;

    my $ufile = $self->{'file'};
    my @results;
    foreach my $dir ( @{ MiscDirs($self, $self->{'dir'}) } )
    {
        foreach  ( ReadDir($dir) )
        {
Verbose2 ("Test: $_, $ufile");
            push @results, $_  if ( $_ =~ "/$ufile\$" );
        }
    }
    return @results;
}

#-------------------------------------------------------------------------------
# Function        : searchSimple
#
# Description     : The user is looking for a file in known subdir subdir
#                   It will be in one of the package directories
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchSimple
{
    my ($self) = @_;

    my $mode = $self->{'Mode'}{'dir'};
    Error ("JatsFileSet. searchSimple. Internal Error. No 'dir' configured'",
            "Entry: $self->{'uspec'}") unless ( $mode );

    $self->{'dir'} = $mode;
    return searchDir( $self );
}

#-------------------------------------------------------------------------------
# Function        : searchPkg
#
# Description     : The user is looking for a file in a package pkg subdir
#                   It will be in one of the package directories
#
# Inputs          : $self                   - Instance Data
#
# Returns         : 
#
sub searchPkg
{
    my ($self) = @_;

    my $ufile = $self->{'file'};
    foreach my $dir ( @{ PkgDirs($self) } )
    {
        my $file = "$dir/$ufile";
        return $file
            if ( -f $file );
    }
    return undef;
}

#-------------------------------------------------------------------------------
# Function        : FancyDirs
#
# Description     : Return an array of directories to search for Lib/Bin files
#                   Cache results for future use
#
#                   Lib dirs are used to hold:
#                       Shared Libraries
#                       Static Libraries
#
#                   The file name should have an embedded type (P or D)
#
#                   Lookin:         {BASE}/DIR/{PLATFORM}
#                   Compatability:  {BASE}/DIR.{PLATFORM}
#                                   {BASE}/DIR/{PLATFORM}{TYPE}
#                                   {BASE}/DIR.{PLATFORM}{TYPE}
#                                   {BASE}/DIR/DIR.{PLATFORM}{TYPE}
#
# Inputs          : $self                   - Instance Data
#                   @dirs                   - Root dir name (lib or bin, include, inc)
#
# Returns         : An Array
#
sub FancyDirs
{
    my ($self, @dirs) = @_;
    #
    #   Return cached results
    #
    unless ( $DirCache{$dirs[0]} )
    {
        #
        #   Create an array of location to search
        #
        my @result;
        foreach my $base ( @{$self->{'BuildPaths'}} )
        {
            foreach my $type ( $self->{'type'}, '' )
            {
                foreach my $subdir ( @{$self->{'BuildParts'}})
                {
                    foreach my $dir ( @dirs )
                    {
                        foreach my $join ( '/', '.', "/$dir." )
                        {
                            my $tdir = "$base/$dir$join$subdir$type";
#print "----Try : $dir\n";
                            push @result, $tdir if ( -d $tdir );
                        }
                    }
                }
            }
        }
        $DirCache{$dirs[0]} = \@result;
    }
    return $DirCache{$dirs[0]}
}

#-------------------------------------------------------------------------------
# Function        : PkgDirs
#
# Description     : Return an array of directories to search for Pkg files
#                   Cache results for future use
#
#                   pkg dirs are used to contain foreign subdirectory trees
#                   Typically used to transparently transfer 3rd parts software
#
#                   There are two forms of pkg dir
#                   Both are not supported within the same package
#
#                   Form-1
#                   Template:       {BASE}/pkg
#
#                   Form-2
#                   Template:       {BASE}/pkg.{PLATFORM}
#                   Template:       {BASE}/pkg.{MACHTYPE}
#
#                   Currently NOT a very good pkg searcher
#                   It does not handle pkg/pkg.MACHTYPE dirs
#
# Inputs          : $self                   - Instance Data
#
# Returns         : An Array
#
sub PkgDirs
{
    my $self = shift;
    #
    #   Return cached results
    #
    unless ( $DirCache{'pkg'} )
    {
        #
        #   Create an array of location to search
        #
        my @dirs;
        foreach my $base ( @{$self->{'BuildPaths'}} )
        {
            next unless ( -d "$base/pkg" );
            foreach my $subdir ( @{$self->{'BuildParts'}} )
            {
                my $dir = "$base/pkg/$subdir";
#print "----Try : $dir\n";
                push @dirs, $dir if ( -d $dir );
            }

            unless ( @dirs )
            {
                push @dirs, $base;
            }

        }
        $DirCache{'pkg'} = \@dirs;
    }
    return $DirCache{'pkg'}
}

#-------------------------------------------------------------------------------
# Function        : MiscDirs
#
# Description     : Return an array of directories to search for Misc files
#                   Cache results for future use
#
#                   Misc dirs are used to contains files of known types
#                   Normally a flat directory structure
#                   No 'type' information
#
#                   Template:   {BASE}/{DIR}
#
#                   Used for dirs that are not special, like the Bin and Lib
#
# Inputs          : $self                   - Instance Data
#                   $root                   - Base of the section
#
# Returns         : An Array
#
sub MiscDirs
{

    my ($self, $root) = @_;

    #
    #   Clean up the user path
    #   Remove leading, trailing and multiple /
    #
    $root =~ s~/+~/~g;
    $root =~ s~^/~~;
    $root =~ s~/$~~;

    #
    #   Return cached results
    #
    unless ( $DirCache{$root} )
    {
        #
        #   Create an array of location to search
        #
        my @dirs;
        foreach my $base ( @{$self->{'BuildPaths'}} )
        {
            my $dir = "$base/$root";
#print "----Try : $dir\n";
            push @dirs, $dir if ( -d $dir );
        }
        $DirCache{$root} = \@dirs;
    }
    return $DirCache{$root}
}

#-------------------------------------------------------------------------------
# Function        : ReadDir
#
# Description     : Read in a directory entry or return the cached result
#                   of a previous read
#
# Inputs          : $dir                    - Dir to Read
#
# Returns         : Array of dir contents
#
sub ReadDir
{
    my ($dir) = @_;

    unless ( $ReadDirCache{$dir}  )
    {
        my @dirs = glob ( "$dir/*");;
        $ReadDirCache{$dir} = \@dirs;
    }
#    DebugDumpData("Cache", \%ReadDirCache );
    return @{$ReadDirCache{$dir}};
}

#-------------------------------------------------------------------------------
# Function        : FilterRemove
#
# Description     : Perform any required Filter Out operations
#
# Inputs          : $ref                - Ref to array of files to process
#
# Returns         : Nothing
#                   Modifies $ref
#
sub FilterRemove
{
    my ($self, $ref) = @_;

    return @{$ref} unless ( exists $self->{'filteroutre'} );

    foreach my $filter ( @{$self->{'filteroutre'}} )
    {
        my @results;
        foreach  ( @{$ref} )
        {
            push @results, $_ unless ( $_ =~ m~$filter~ );
        }
        $ref = \@results;

    }
    return @{$ref};
}

#-------------------------------------------------------------------------------
# Function        : glob2pat
#
# Description     : Convert four shell wildcard characters into their equivalent
#                   regular expression; all other characters are quoted to
#                   render them literals.
#
# Inputs          : Shell style wildcard pattern
#
# Returns         : Perl RE
#

sub glob2pat
{
    my $globstr = shift;
    $globstr =~ s~^/~~;
    my %patmap = (
        '*' => '[^/]*',
        '?' => '[^/]',
        '[' => '[',
        ']' => ']',
        '-' => '-',
    );
    $globstr =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
    return '/' . $globstr . '$';
}


#sub DESTROY
#{
#    DebugDumpData(__PACKAGE__, @_);
#}

1;