Subversion Repositories DevTools

########################################################################
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
#
# Module name   : JatsLocatePkgFile.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.
#                       --deb           - Name is the base of a Debian Package
#                                         Searchs in BIN directories
#                       --lib           - Name is the base of a Shared Library
#                                         Searchs in LIB 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
#
# Usage:
#
#   $Locator = JatsLocatePkgFile::New( Platform, 'P' );
#   $result = $Locator->LocateFile ('busybox,--prog');
#
#
#......................................................................#

require 5.008_002;
use strict;
use warnings;

package JatsLocatePkgFile;

use JatsError;
use JatsMakeConfig;

# automatically export what we need into namespace of caller.
use Exporter();
our (@ISA, @EXPORT);
@ISA         = qw(Exporter);
@EXPORT      = qw(
                    FileSet
                );

#
#   Hash of known file location specifications
#   Only allowed to have one in any one definition
#
my %LocSpec = (
    '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'},
#    'thx'           => 1,
#    'jar'           => 1,
#    'local'         => 1,
#    'interface'     => 1,
);

#-------------------------------------------------------------------------------
# Function        : FileSet
#
# Description     : Create a new instance of a File Locator
#                   Used to provide the basic configuration of the target
#                   system
#
# Inputs          : None
#                   Useful information is prsent in the environment
#
#
# Returns         : Class Ref
#
sub FileSet
{
    Debug ("New JatsLocatePkgFile");
    my $self;

    #
    #   Load all the MakeFile generate information and  data structures
    #
    my $mi = JatsMakeConfigLoader::Load();

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

    #
    #   Create a class
    #   Bless my self
    #
    bless ($self, __PACKAGE__);

    #
    #   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'};
    }
    $self->{'BuildPaths'} = \@result;
    $self->{'BuildParts'} = $mi->GetDataItem('%BUILDPLATFORM_PARTS');

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

#    DebugDumpData(__PACKAGE__, $self );
    return $self;
}

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

    #
    #   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);
        $opts->{$opt} = defined($3) ? $4 : 1;

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

    #
    #   Save the remainder as the filename
    #   It may not exist
    #
    $opts->{'file'} = $fspec;
    $opts->{'Mode'} = $mode;

#    DebugDumpData("File", $opts);

    #
    #   Dispatch to a suitable processing routine
    #
    if ( $mode )
    {
        if ( $mode->{'code'} )
        {

            my @result = ( $mode->{'code'}( $self, $opts ) );
print "-----Files found: $#result\n";            
            if ( ! $opts->{'allowmultiple'} )
            {
                Error ("Mutliple Files found: $self->{'uspec'}" )
                    if ( $#result > 1 );
            }
            return wantarray ? @result : $result[0];
        }
        DebugDumpData("File", $opts);
        Error ("Unknown search method: @_");
    }
    else
    {
        #
        #   No Mode specified
        #   Must be a local file
        #
        my $ufile = $opts->{'file'};
        return $ufile
            if ( -f $ufile );
        return undef;
    }
}

#-------------------------------------------------------------------------------
# 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
#                   $opts                   - Options Hash
#
# Returns         : 
#
sub searchLib
{
    my ($self, $opts) = @_;

    my $ufile = $opts->{'file'};
    my $ext =  $self->{so} ? '.' . $self->{a} : '';
    my @results;
    foreach my $dir ( @{ LibDirs($self) } )
    {
        foreach  ( glob ( "$dir/*") )
        {
            foreach my $type ( $self->{'type'}, '' )
            {
                push @results, $_  if ( $_ =~ "/$ufile$type$ext\$" );
            }
        }

#        foreach my $type ( $self->{'type'}, '' )
#        {
#            my $file = "$dir/$ufile" . $type . $ext;
#            push @results, $file
#                if ( -f $file );
#            }
    }
    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
#                   $opts                   - Options Hash
#
# Returns         : 
#
sub searchProg
{
    my ($self, $opts) = @_;

    my $ufile = $opts->{'file'} . $self->{exe};
    my @results;
    foreach my $dir ( @{ BinDirs($self) } )
    {
        foreach  ( glob ( "$dir/*") )
        {
            push @results, $_  if ( $_ =~ "/$ufile\$" );
        }
    }
    return @results;

#    my $ufile = $opts->{'file'} . $self->{exe};
#    foreach my $dir ( @{ BinDirs($self) } )
#    {
#        my $file = "$dir/$ufile";
#        return $file
#            if ( -f $file );
#    }
#    return undef;
}

#-------------------------------------------------------------------------------
# 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
#                   $opts                   - Options Hash
#
# Returns         : 
#
sub searchBin
{
    my ($self, $opts) = @_;

    my $ufile = $opts->{'file'};
    my @results;
    foreach my $dir ( @{ BinDirs($self) } )
    {
        foreach  ( glob ( "$dir/*") )
        {
            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
#                   $opts                   - Options Hash
#
# Returns         : 
#
sub searchDeb
{
    my ($self, $opts) = @_;

    foreach my $dir ( @{ BinDirs($self) } )
    {
        if ( my @files = glob ( "$dir/$opts->{file}_*.deb" ) )
        {
            return $files[0];
        }
    }
    return undef;
}

#-------------------------------------------------------------------------------
# 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
#                   $opts                   - Options Hash
#
# Returns         : 
#
sub searchDir
{
    my ($self, $opts) = @_;

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

#-------------------------------------------------------------------------------
# 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
#                   $opts                   - Options Hash
#
# Returns         : 
#
sub searchSimple
{
    my ($self, $opts) = @_;

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

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

#-------------------------------------------------------------------------------
# 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
#                   $opts                   - Options Hash
#
# Returns         : 
#
sub searchPkg
{
    my ($self, $opts) = @_;

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

#-------------------------------------------------------------------------------
# Function        : BinDirs
#
# Description     : Return an array of directories to search for Bin files
#                   Cache results for future use
#
#                   Bin dirs are used to hold:
#                       Programs
#                       Debian Packages
#                       File System Images
#
#                   The directory is named after a platform and will have
#                   a P or D suffix
#
#                   Template:       {BASE}/bin/{PLATFORM}{TYPE}
#                   Compatability:  {BASE}/bin.{PLATFORM}{TYPE}
#                                   {BASE}/bin/bin.{PLATFORM}{TYPE}
#
# Inputs          : $self                   - Instance Data
#
# Returns         : An Array
#
sub BinDirs
{
    my $self = shift;
    #
    #   Return cached results
    #
    unless ( $self->{'cache'}{'bin'} )
    {
        #
        #   Create an array of location to search
        #
        my @dirs;
        foreach my $base ( @{$self->{'BuildPaths'}} )
        {
            foreach my $type ( $self->{'type'}, '' )
            {
                foreach my $subdir ( @{$self->{'BuildParts'}} )
                {
                    my $dir = "$base/bin/$subdir$type";
#print "----Try : $dir\n";
                    push @dirs, $dir if ( -d $dir );
                }
            }
        }
        $self->{'cache'}{'bin'} = \@dirs;
    }
    return $self->{'cache'}{'bin'}
}

#-------------------------------------------------------------------------------
# Function        : LibDirs
#
# Description     : Return an array of directories to search for Lib 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)
#
#                   Template:       {BASE}/lib/{PLATFORM}
#                   Compatability:  {BASE}/lib/{PLATFORM}{TYPE}
#                                   {BASE}/lib.{PLATFORM}{TYPE}
#                                   {BASE}/lib/lib.{PLATFORM}{TYPE}
#
# Inputs          : $self                   - Instance Data
#
# Returns         : An Array
#
sub LibDirs
{
    my $self = shift;
    #
    #   Return cached results
    #
    unless ( $self->{'cache'}{'lib'} )
    {
        #
        #   Create an array of location to search
        #
        my @dirs;
        foreach my $base ( @{$self->{'BuildPaths'}} )
        {
            foreach my $type ( $self->{'type'}, '' )
            {
                foreach my $subdir ( @{$self->{'BuildParts'}})
                {
                    my $dir = "$base/lib/$subdir$type";
#print "----Try : $dir\n";
                    push @dirs, $dir if ( -d $dir );
                }
            }
        }
        $self->{'cache'}{'lib'} = \@dirs;
    }
    return $self->{'cache'}{'lib'}
}

#-------------------------------------------------------------------------------
# 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 ( $self->{'cache'}{'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;
            }

        }
        $self->{'cache'}{'pkg'} = \@dirs;
    }
    return $self->{'cache'}{'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 ( $self->{'cache'}{$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 );
        }
        $self->{'cache'}{$root} = \@dirs;
    }
    return $self->{'cache'}{$root}
}


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