Subversion Repositories DevTools

Rev

Blame | Last modification | View Log | RSS feed 

########################################################################
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
#
# Module name   : JatsIgnore.pm
# Module type   : JATS Utility
# Compiler(s)   : Perl
# Environment(s): jats
#
# Description   : 
#
# Usage         : See POD at the end of this file
#
#......................................................................#

require 5.008_002;
use strict;
use warnings;

package JatsIgnore;

use JatsError;
use FileUtils;

our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
use Exporter;

$VERSION = 1.00;
@ISA = qw(Exporter);

# Symbols to autoexport (:DEFAULT tag)
@EXPORT = qw(
                Test
                ReadFilters
            );

my  @Filters;                   # List of filters
my  $baseUp;                    # Adjust base directory
my  $baseDir;                   # Base directory    

#-------------------------------------------------------------------------------
# Function        : INIT 
#
# Description     : Called during startup
#                   Init file utils 
#
sub INIT
{
    InitFileUtils();
}


#-------------------------------------------------------------------------------
# Function        : Test 
#
# Description     : Test a .jatsignore file
#
# Inputs          : 
#
# Returns         : 
#
sub Test
{
    my $error = ErrorReConfig( 'name'    =>'IGNORE' );
    Message("Testing file");
}

#-------------------------------------------------------------------------------
# Function        : ReadFilters 
#
# Description     : Read a file of filter specifications
#                   Create a list of RE's for later use 
#
# Inputs          : $file           - Source file
#
# Returns         : 
#
sub ReadFilters
{
    my $error = ErrorReConfig( 'name'    =>'IGNORE' );
    my ($file) = @_;
    open (my $fh, '<', $file) || Error ("Cannot open filter spec: $file. $!");
    while (<$fh>)
    {
        #
        #   Strip white space
        #   Ignore comment lines
        #
        $_ =~ s~\s+$~~;
        $_ =~ s~^\s+~~;
        next unless $_;
        next if m~^#~;

        #
        #   Extract Meta Data
        #
        if (m~\[\s*(.*)\s*\]~)
        {
            my $metaCmd = $1;
            $metaCmd =~ s~\s+~ ~g;
            Verbose("Meta: $metaCmd");
            if ($metaCmd =~ m~ROOT UP (\d+)~)
            {
                Verbose("Root Directory. Up $1 from here");
                $baseUp = $1;
                next;
            }
            ReportError("Uknown MetaData: $_");
            next;
        }

        my $data = convertToRe($_);
        if ($data->{error})
        {
            ReportError ("Invalid Filter: $_", "Converted to:" . $data->{filter}, $data->{error});
        }
        else
        {
            push (@Filters, $data);
        }
    }
    ErrorDoExit();
    DebugDumpData("Filters", \@Filters) if IsVerbose(3);
}

#-------------------------------------------------------------------------------
# Function        : AddFilter 
#
# Description     : Add one or more filters to the internal filter list
#
# Inputs          : Array of filters
#
# Returns         : 
#
sub AddFilter
{
    my $error = ErrorReConfig( 'name'    =>'IGNORE' );
    foreach (@_)
    {
        my $data = convertToRe($_);
        if ($data->{error})
        {
            ReportError ("Invalid Filter: $_", "Converted to:" . $data->{filter}, $data->{error});
        }
        else
        {
            push (@Filters, $data);
        }
    }
    ErrorDoExit();
    DebugDumpData("Filters", \@Filters) if IsVerbose(3);
}

#-------------------------------------------------------------------------------
# Function        : TestFilters 
#
# Description     : Test the filters against a file of values
#
# Inputs          : $file       - File to process
#
# Returns         : 
#
sub TestFilters
{
    my $error = ErrorReConfig( 'name'    =>'IGNORE' );
    my ($file) = @_;
    open (my $fh, '<', $file) || Error ("Cannot open test file: $file. $!");
    while (<$fh>)
    {
        #
        #   Strip white space
        #   Ignore comment lines
        #
        $_ =~ s~\s+$~~;
        $_ =~ s~^\s+~~;
        next unless $_;
        next if m~^#~;

        my $line = $_;
        print("Testing: $line\n");

        foreach my $filter (@Filters)
        {
            my $rv = $line =~ $filter->{regex};
            printf("%1.1s :: %1.1s :: %s, %s\n", $rv, ($filter->{mode} || ''), $filter->{raw}, $filter->{filter});
        }
        
    }
}

#-------------------------------------------------------------------------------
# Function        : FilterPath 
#
# Description     : Examine the provided path and determine if it should be filtered
#
# Inputs          : $path       - Path to process
#
# Returns         : 0: Keep, D: Delete, P: Prune
#
sub FilterPath
{
    my $error = ErrorReConfig( 'name'    =>'IGNORE' );
    my ($path) = @_;

    study $path;
    foreach my $filter (@Filters)
    {
        if ($path=~ $filter->{regex} )
        {
            return $filter->{mode} || 'D';
        }
    }
    return 0;
}

#-------------------------------------------------------------------------------
# Function        : ScanDir 
#
# Description     : Scan a directory
#
# Inputs          : $SrcDir           - Start of path to scan
#                   $callback         - Expect a code Ref
#                                       Called with:
#                                           Code: P, D, 0
#                                           AbsPath:
#
#
# Returns         : 
#
sub ScanDir
{
    my ($SrcDir, $callback) = @_;

    $SrcDir = AbsPath($SrcDir);
    Verbose("ScanDir: $SrcDir");

    #
    #   Sanity check callback
    #
    Error("ScanDir, not provided with a code reference")
        if ($callback && ref($callback) ne 'CODE' );

    #
    #   Create a list of subdirs to scan
    #       Elements do not contain the SrcDir
    #       Elements have a '/' suffix - simplify joining
    #
    my @dirs = '';

    #
    #   Process all directories in the list
    #   Pop them off so we do a depth first search
    #
    while ( @dirs )
    {
        my $root = pop( @dirs );

        my $dir = $SrcDir . '/' . $root;
        unless (opendir DIR, $dir )
        {
            ::Warning ("File Find. Can't opendir($dir): $!\n");
            next;
        }
        my @filenames = readdir DIR;
        closedir(DIR);

        foreach my $file ( @filenames )
        {
            #
            #   Ignore filesystem house keeping directories
            #
            next if ( $file eq '.' || $file eq '..' );

            #
            #   Determine the type of element
            #       1)Link
            #           - Link to a File
            #           - Link to a directory
            #       2)File
            #       3)Directory
            #
            my $filename = $dir . $file;
            my $relname = $root . $file;
            my $type;
            my $rv;

            #
            #   Stat the file
            #   Use speed trick. (-f _) will use into from last stat/lstat
            #
            stat ( $filename );
            if ( -f _ )
            {
                $rv = FilterPath ($relname);
                $type = 'f';
            }
            elsif ( -d _ )
            {
                #
                #   Add to the list of future dirs to process
                #   Place on end to ensure depth first
                #   Algorithm requires dirname has a trailing /
                #
                $rv = FilterPath ($relname . '/');
                push @dirs, $relname . '/' unless $rv eq 'P';
                $type = 'd';
            }
            else
            {
                ::Verbose ("Find File: Unknown type skipped: $filename");
                next;
            }

            #
            #   Have a valid element to process
            #   Setup parameters for later users
            #
            #print("Examine $rv : $relname\n");
            #print("Exlude: $filename\n") if $rv;
            $callback->($rv, $filename) if $callback && $rv;
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : TestFile 
#
# Description     : Test against file data
#                   Each line has 3 comma sep values
#                   result, filter, path
#
# Inputs          : $file       - File to process
#
# Returns         : 
#
sub TestFile
{
    my $error = ErrorReConfig( 'name'    =>'IGNORE' );
    my ($file) = @_;
    open (my $fh, '<', $file) || Error ("Cannot open test file: $file. $!");
    while (<$fh>)
    {
        #
        #   Strip white space
        #   Ignore comment lines
        #
        $_ =~ s~\s+$~~;
        $_ =~ s~^\s+~~;
        next unless $_;
        next if m~^#~;

        my $line = $_;
        #print("Testing: $line\n");

        my ($rv, $re, $path) = split(/\s*,\s*/, $line);
        TestRe($., $rv, $re, $path);
    }
}


#-------------------------------------------------------------------------------
# Function        : TestRe 
#
# Description     : Test an RE against a line
#                   Test utility - should do the same job as the main filtering
#                   Will display stuff
#
# Inputs          : result          - expected result (P:Prune, D:Delete, X:Bad Filter, 0:No Match
#                   re              - Re to test against 
#                   path            - Patch to test
#
# Returns         : result
#
sub TestRe
{
    my ($lineNo, $result, $re, $line) = @_;
    my $error = ErrorReConfig( 'name'    =>'IGNORE' );
    
    my $rv = 'X';
    my $filter = convertToRe($re);
    if ($filter->{regex})
    {
        if ($line =~ $filter->{regex}) {
            $rv = $filter->{mode} || 'D'; 
        } else {
            $rv = 0;
        }
    }

    #
    #   Report results
    #
    printf "%3.3s : %1.1s, %20.20s, %30.30s, %s\n",
            $lineNo, $result, $re, $line, ($rv eq $result) ? 'Good' : ('----Error: Got ' . $rv . ' : ' . $filter->{filter});
    return $rv;
}


#-------------------------------------------------------------------------------
# Function        : convertToRe 
#
# Description     : Convert a filter to an RE
#
# Inputs          : Filter expression
#
# Returns         : Data item filled in
#
sub convertToRe
{
    my ($_) = @_;
    my $data;
    my $filter;

    $data->{raw} = $_;
    if (m~^\+(.*)~)
    {
        #   Process Regexps
        #   If end in / - then its a pruning match
        $filter = $1;
        if ($filter =~ m~(.*)/$~)
        {
            $data->{mode} = 'P' ;
            $filter = $1 . '(/|$)';
        }
    }
    else
    {
        #
        #   Process non-regexps
        #   If end in ** - then its a pruning match
        #
        $filter = $_;
        $data->{mode} = 'P' if ($filter =~ m~\*{2}$~);
        $filter = glob2pat ($filter);
    }
    #
    #   Ensure we have a sane Regular expression
    #   If not, then clean up the reported error before giving to the user
    #   Use delayed error reporting
    #
    $data->{filter} = $filter;
    $data->{regex} = eval { qr/$filter/i };
    if ($@)
    {
        my $etext = $@;
        $etext =~ s~/ at .*~~;
        $data->{error} = $etext;
        $data->{regex} = undef
    }
    else
    {
        Verbose2 ("FilterLine: '$_' -> $filter");
    }

    return $data;
}

#-------------------------------------------------------------------------------
# Function        : glob2pat
#
# Description     : Convert shell wildcard characters into their equivalent
#                   regular expression; all other characters are quoted to
#                   render them literals.
#
#                   Treat '**' as match anything
#                   Treat '*' as match within a filename
#
# Inputs          : Shell style wildcard pattern
#
# Returns         : Perl RE
#
sub glob2pat
{
    my $globstr = shift;
    $globstr =~ s~^/~~;
    $globstr =~ s~\*{2,}~$;~g;
    my %patmap = (
        '*' => '[^/]+',
        '?' => '.',
        '[' => '[',
        ']' => ']',
        '-' => '-',
        "$;" => "$;"
    );
    $globstr =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
    $globstr =~ s~$;~.*~g;
    $globstr = '(/|^)' . $globstr;
    $globstr .= '$' unless $globstr =~ m~/$~;
    return  $globstr;
}

1;