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;