File Coverage

blib/lib/Regexp/Match/List.pm

Criterion	Covered	Total	%
statement	18	76	23.6
branch	0	16	0.0
condition	0	11	0.0
subroutine	6	18	33.3
pod	1	7	14.2
total	25	128	19.5

package Regexp::Match::List;

#   $Id: List.pm,v 1.1.1.1.8.3 2004/04/29 01:45:31 dgrant Exp $

#   IDEA: allow match() to skip regexps below a certain hitrate.
#   IDEA: use qr// to precompile regexps


use strict;
use warnings;

use base qw( Class::Base );

use Data::Sorting qw( :basics :arrays );
use Data::Dumper;

use vars qw($VERSION %CONF);

$VERSION = 0.50;

%CONF =
#   CONFIGURATION --  This configuation is loaded into $self via load_args()
(
    #   INTERNAL DEFAULTS (can be touched externally)
    USESTUDY    => 1,   #   use "study STRING;" for regexp strings
    OPCHECK     => 50,  #   Num of match() calls before calling optimize()
    OPSKIP      => 0,   #   Skip optimize() ?
    OPWEIGHT    => 1,   #   Default regexp hit weight
    OPHITS      => 0,   #   Default regexp hits
    OPSORTCONF  =>      #   Data::Sorting Sort Rules. Used in optimize()
    [                   #   The hashlike syntax is to get around some issue
                        #   in Data::Sorting that wouldn't let me use a hashref
        -compare  => 'numeric',
        -order    => 'reverse',
        -sortkey  => sub { $_[0]->{'hits'} * $_[0]->{'weight'} }
    ],

    #   INTERNAL STRUCTURE (cannot be touched externally)
    '_RE'       => [],  #   Store regexps in arrayref. See add()
    '_COUNT'    =>      #   Number of times a function has been called
    {
        match       => 0,
        optimize    => 0
    },
);



sub match($$)
#   PUBLIC METHOD
#   Test a string for all available regular expressions.
#
{
    my $self = shift;
    my ($string) = @_;
    my ($RE, $test, @results);

    #   A possible regexp optimization. see % perldoc -f study
    study $string if ($self->{'USESTUDY'});

    REGEXP:
    for my $i (0..$#{ $self->{'_RE'} })
    #   Iterate through all regular expressions.
    #   This uses a for() b/c it allows for more control
    #   than Set::Array::foreach() (we can escape on a match)
    {
        $self->_increment();            #   $self->{'_COUNT'}{'match'}++
        $self->optimize();              #   which is used by optimize()

        $RE = $self->{'_RE'}->[$i];     #   The current regular expression

        #   Execute the regular expression in list context and
        #   store the results ($1 .. $n) in an array
        @results = ($string =~ $RE->{'test'});

        $self->debug("STRING:$string\n");
        $self->debug("TEST:$RE->{'test'}\n");
        $self->debug("RESULTS:", (scalar(@results)), '-', join(',', @results), "\n\n");

        if ($RE->callback(@results))
        #   A successful match may not be enough for a positive
        #   result depending on the outcome of the callback which
        #   is entirely out of Regexp::Match::List's control.
        #   When it is, we acknowledge and reward a successful
        #   regular expression, then bust out of this hellish loop.
        {
            $RE->count_hit();           #   $RE->{'hits'}++
            last REGEXP;                #   Bust out
        }
    }

    #print Dumper($RE, @results);

    return ($results[0])
        ? ($RE, @results)
        : ();
}

sub add(\%)
#   PUBLIC METHOD
#   Add a regular expression to the mix.
#    IN:    (scalar) regular expression w/o '/' (i.e. '^.+?\s$')
#           [(scalar) multiplier for hits, used by optimize() ]
#   OUT:    Whatever Set::Array::push() returns
{
    my $self = shift;
    my %re = @_;

    $self->check_re_conf(\%re);

    $re{'weight'}   ||= $self->{'OPWEIGHT'};
    $re{'hits'}     ||= $self->{'OPHITS'};

    push (@{ $self->{'_RE'} }, Regexp::Match::List::RE->create(%re));
}

sub check_re_conf(\%)
#   Determine whether the given hashref contains all the information
#   required to create a regexp entry in $self->{'RE'}
#   TODO: complete check_re_conf()
{
    my $self = shift;
    return 1;
}

sub optimize()
#   PUBLIC METHOD, USED INTERNALLY
#   Sort Set::Array object of regular expressions by # of times
#   match() is called. This will run only when match() has been called
#   a multiple of $self->{'OPCHECK'} times
{
    my $self = shift;
    my $cnt_match = $self->_count('match');

    #   We only optimize when...
    return if (
        #   we are told allowed to, and when...
        ($self->{'OPSKIP'} == 1) ||
        #   the iteration counter reaches a multiple of $self->{'OPCHECK'}
        (($cnt_match % $self->{'OPCHECK'}) > 1)
    );

    #   Count up a hit for this function only when we actually resort
    #   This information is only useful for reference
    $self->_increment();            #   $self->{'_COUNT'}{'optimize'}++

    $self->debug("optimize(): running at match() call #$cnt_match\n\n");

    #   Sort using Data::Sorting. $self->{'OPSORTCONF'} contains a
    #   sort rule configuration.
    sort_arrayref($self->{'_RE'}, @{ $self->{'OPSORTCONF'} });

}






#   EXTREMELY PRIVATE METHODS
#   Haha. Philstrdamous, I know you love this one.
#   Increments a counter by one. The particular counter is determined
#   by the calling function. i.e. $self->{'_COUNT'}{'optimize'}++
sub _increment() { $_[0]->{'_COUNT'}{ (split '::', (caller(1))[3])[3] }++ }
#   Returns the value of the counter for the given function
sub _count() { $_[0]->{'_COUNT'}{$_[1]} }






#   CONSTRUCTOR RELATED
sub init()
#   Rekindle all that we are
{
    my ($self, $config) = @_;           #   Get vars from Class::Base::new()
    $self->load_args($config);          #   Load config into $self
    $self->create_attributes();         #   Set our attributes and defaults
    return $self;
}

sub create_attributes()
#   Add internal attributes to $self (does not overwrite existing values)
#   AND apply default values to externally setable parameters
{
    my $self = shift;

    #   See %CONF declaration at the top of this file

    foreach my $a (keys %CONF)
    {
        $self->{$a} = $CONF{$a} unless (exists($self->{$a}));
    }

    return $self;
}

sub load_args($$)
#   Used by the constructor to load config into $self.
#   NOTE: _ is skipped
{
    my ($self, $args) = (shift, shift);

    for my $key (keys %{ $args })
    {
        #   Skip values that could overwrite internal attributes
        next if $key =~ /^\_/;

        (!exists($self->{$key}))
            ? $self->{$key} = $args->{$key}
            : ($self->debug("loadArgs: $key already exists in \$self"));
    }

    return $self;
}


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

#   TODO: move into separate module (Regexp::Match::List::RE?)
package Regexp::Match::List::RE;
#   A simple object to store a regular expression test and all its matter

sub create()
#   A constructor.
#   See add()
{
    my $class = shift;
    my %att = @_;
    my $self = {};

    bless \%att, $class;
}

#   Increment hit tally for this regular expression by user value or 1
#   See match()
sub count_hit() { shift->{'hits'} += shift || 1; }

sub callback()
#   Run this regular expression's callback if one exists.
#   By default we will return the result of the regexp test.
#    IN: (array) results ($1 .. $n) of this RE on the current string
#   OUT: (bool) success as determined by the callback
#
#   See match()
{
    my $self = shift;

    #   If there is no callback, return the test result
    return ($#_ >= 0) unless(exists($self->{'callback'}));

    #   Send the callback the test result as well as a reference to ourself
    return &{ $self->{'callback'} }($self, @_);
}


#   $Log: List.pm,v $
#   Revision 1.1.1.1.8.3  2004/04/29 01:45:31  dgrant
#   - Initial preparation for CPAN
#
#   Revision 1.1.1.1.8.2  2004/04/23 23:30:25  dgrant
#   - Added callback template to Regexp/Match/List.pm
#
#   Revision 1.1.1.1.8.1  2004/04/16 17:10:34  dgrant
#   - Merging libperl-016 changes into the libperl-1-current trunk
#
#   Revision 1.1.1.1.2.1.20.2  2004/04/08 18:23:56  dgrant
#   *** empty log message ***
#
#   Revision 1.1.1.1.2.1.20.1  2004/04/08 16:42:30  dgrant
#   - No significant change
#
#   Revision 1.1.1.1.2.1  2004/03/25 01:49:51  dgrant
#   - Inital import of List.pm
#   - Added cvs Id and Log variables
#

1;
__END__