Synopsis
package Wrapper;
$VERSION = 1.10;
use strict;
use warnings;
use Data::Dumper;
use Match;
sub new
{
my ($class, $pattern) = @_;
eval
{ bless
{
_regex => qr/$pattern/,
_pattern => $pattern
} , ref($class) || $class;
}
}
sub get_pattern{ return $_[0]->{_pattern} };
sub get_regex { return $_[0]->{_regex} };
sub match
{
my ($self, $str) = @_;
my @subpatterns = ($self->get_pattern =~ /$str/) or return;
# arguments 2 - 5 = 'pre', 'match', 'post', 'result'
# (see Match->new() method)
return Match->new(@subpatterns,$`,$&,$',$str);
}
sub substitute
{
my ($self, $str, $subs) = @_;
my $pattern = $self->get_pattern();
$pattern =~ s/$str/$subs/ or return;
# arguments 1 - 4 = 'pre', 'match', 'post', 'result'
# (see Match->new() method)
return Match->new($`,$&,$',$pattern);
}
sub substitute_all
{
my ($self, $str, $subs) = @_;
my $pattern = $self->get_pattern();
$str =~ s/$pattern/$subs/g or return;
# arguments 1 - 4 = 'pre', 'match', 'post', 'result'
# (see Match->new() method)
return Match->new($`,$&,$',$str);
}
package Match;
$VERSION = 1.10;
use strict;
use warnings;
use vars '$AUTOLOAD', '$DESTROY';
sub new {
my $class = shift;
my ($pre, $match, $post, $result) = splice @_, -4;
bless {
_pre => $pre,
_match => $match,
_post => $post,
_result => $result,
_subpatterns => [@_]
}, ref($class) || $class;
sub _accessible() { exists $_[0]->{$1} }
}
sub AUTOLOAD
{
no strict "refs";
my ($self) = @_;
# was it a 'get()' call? is the attribute accessible?
if ($AUTOLOAD =~ /.*::get(_\w+)/ and $self->_accessible($1) )
{
# get locally scoped, scalar copy ($attr_name) of $1
my $attr_name = $1;
# can't use '$self' in 'sub' return call, since
# it's outside the scope of subsequent 'get' calls;
# the first 'get' call would work as expected, but
# subsequent 'get' calls use the changed symbol table's
# anonymous sub-routine
#
# cram the anonymous sub-routine into the symbol
# table, use it after the first call to a 'get_xxx()' method
*$AUTOLOAD = sub { return $_[0]->{$attr_name} };
return $self->{$attr_name};
}
return "Match::AUTOLOAD : Not a 'get' call or attribute doesn't exist.";
}
sub DESTROY {}
sub from
{
my ($self) = @_;
# example of Perl 'memoization'...
# cramming a new value into $self,
# on the fly and as it is requested.
$self->{_from} = length($_[0]->{_pre})
unless defined $self->{_from};
return $self->{_from};
}
sub to
{
my ($self) = @_;
# example of Perl 'memoization'...
# cramming a new value into $self,
# on the fly and as it is requested.
$self->{_to} = $self->from + length($self->{_match}) - 1
unless defined $self->{_to};
return $self->{_to};
}
sub subpatterns
{
my ($self, $index) = @_;
return $self->{_subpatterns}[$index] if defined $index;
return @{$self->{_subpatterns}};
}
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#!/usr/bin/perl
use strict;
use warnings;
use Wrapper;
use Data::Dumper;
my $original = "cie";
my $regex = Wrapper->new($original)
or die("Error creating Wrapper object!");
print "'regex' object :\n";
print Dumper($regex);
print Dumper($regex->get_regex());
print "---------------------------\n";
print "regex->match (full):\n";
print Dumper($regex->match("cie")->get_match);
print "regex->match('cie')->from:\n";
print $regex->match("cie")->from()."\n";
print "regex->match('cie')->to:\n";
print $regex->match("cie")->to()."\n";
print "---------------------------\n";
print "regex->match (partial):\n";
print Dumper($regex->match("ci")->get_match);
print "---------------------------\n";
print "regex->match('ci')->from:\n";
print $regex->match("ci")->from()."\n";
print "regex->match('ci')->to:\n";
print $regex->match("ci")->to()."\n";
print "regex->match('ci')->subpatterns(): \n";
print Dumper($regex->match("ci")->subpatterns(0));
print "---------------------------\n";
print "regex->match (no match):\n";
defined ($regex->match("xyz")) ? () : goto SKIP;
print Dumper($regex->match("xyz")->get_match);
print "regex->match('xyz')->from:\n";
print $regex->match("xyz")->from()."\n";
print "regex->match('xyz')->to:\n";
print $regex->match("xyz")->to()."\n";
print "---------------------------\n";
SKIP:
print "no match\n";
print "---------------------------\n";
print "regex->substitute: (match)\n";
print "regex->substitute() result = ";
print $regex->substitute("ci","m")->get_result()."\n";
print "---------------------------\n";
print "regex->substitute (no match):\n";
defined ($regex->substitute("ty","w")) ? () : goto SKIPPED;
print "---------------------------\n";
SKIPPED:
print "no match for substitution\n";
print "---------------------------\n";
print "regex->substitute (match):\n";
print "regex->substitute() _result = ";
print $regex->substitute("ci","x")->get_result()."\n";
print "---------------------------\n";
print "new_regex->substitute_all():\n";
my $last = "I batted 4 for 4!";
my $new_regex = Wrapper->new("4")
or die("Error creating Wrapper object!");
print "new_regex->substitute_all() _result = ";
print $new_regex->substitute_all($last,"four")->get_result()."\n";
print "---------------------------\n";
print "regex->substitute_all() (attribute doesn't exist):\n";
print "new_regex->substitute_all() _hemans = ";
print $new_regex->substitute_all($last,"four")->get_hemans()."\n";
Description
Just running this by everyone and wondering what is thought...
It's a small, 2-file collection OO wrapper providing Perl Regex functionality. Matching, substitution, to/from matching index info, etc. are available.
Regex::Wrapper and Regex::Wrapper::Match are the package names.
The code in the 'Synopsis' section closest to the bottom is some 'driver' code that exercises the packages.
Thanks to anyone who takes the time to check this out.
Comments
Secondly, there are a TON of existing regex modules. It looks like yours might just be an OO wrapper to avoid dealing directly with regexes. Have you looked at any of the existing modules to see if something like this already exists?
Please sign up to post a review.