Subversion Repositories DevTools

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

# 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;