File Coverage

blib/lib/Regexp/MatchContext.pm

Criterion	Covered	Total	%
statement	55	98	56.1
branch	6	20	30.0
condition	2	3	66.6
subroutine	14	22	63.6
pod			n/a
total	77	143	53.8

package Regexp::MatchContext;

use version; $VERSION = qv('0.0.2');

use warnings;
# use strict;
use Carp;

my $matchcontents;
$matchcontents = qr{ (?:
                        (?> [^()]* )
                        (?>
                            [(] (?{$matchcontents}) [)]
                        )*
                     )*
                 }x;

sub import {
    use overload;

    my $vars  = grep {/\A (?: -vars | -all ) \z/x} @_;
    my $subs  = !$vars || grep {/\A (?: -subs | -all ) \z/x} @_;

    overload::constant
        qr => sub {
            my ($raw) = @_;
            $raw =~ s{ \(\?
                       <
                         ([^\W\d]\w*)
                       >
                       ($matchcontents)
                       \)
                     }
                     { push @vars, "undef\$$1;"; "($2)(?{eval'\$$1=\$^N'})" }gex
                and $raw =~ s/$/|(??{@vars'(?!)'})/;
            $raw =~ s/\(\?p\)/(?{\$Regexp::MatchContext::target_ref=\\\$_})/g
                or $raw =~ s/\A/(?{\$Regexp::MatchContext::target_ref=undef})/;
            return $raw;
        };

    my $caller = caller;
    no warnings 'once';
    for my $name (qw(PREMATCH MATCH POSTMATCH)) {
        tie ${$name}, "Regexp::MatchContext::$name";
        if ($vars) {
            *{$caller.'::'.$name} = \${$name};
        }
        if ($subs) {
            *{$caller.'::'.$name} = sub :lvalue { ${$name} };
        }
    }
}

sub _cant_assign {
    my ($varname) = @_;
    require Carp;
    @CARP_NOT = qw(
        Regexp::MatchContext::PREMATCH
        Regexp::MatchContext::MATCH
        Regexp::MatchContext::POSTMATCH
    );
    Carp::croak
        "Can't assign to $varname because the preceding match didn't set it.\n",
        "(Did you forget to include a (?p) in your regex?)\n",
        "Died";
}

package Regexp::MatchContext::PREMATCH;
use Tie::Scalar;
use base 'Tie::StdScalar';

sub FETCH {
    return undef unless defined ${$Regexp::MatchContext::target_ref};
    return substr ${$Regexp::MatchContext::target_ref}, 0, $-[0];
}

sub STORE {
    my ($self, $newval) = @_;
    Regexp::MatchContext::_cant_assign('$PREMATCH')
        unless defined ${$Regexp::MatchContext::target_ref};
    my $oldlen = length substr ${$Regexp::MatchContext::target_ref}, 0, $-[0], $newval;
    my $delta = length($newval) - $oldlen;
    *- = [map { $_ + $delta } @-];
    *+ = [map { $_ + $delta } @+];
}



package Regexp::MatchContext::MATCH;
use Tie::Scalar;
use base 'Tie::StdScalar';

sub FETCH {
    return undef unless defined ${$Regexp::MatchContext::target_ref};
    return substr ${$Regexp::MatchContext::target_ref}, $-[0], $+[0]-$-[0];
}

sub STORE {
    my ($self, $newval) = @_;
    Regexp::MatchContext::_cant_assign('$MATCH')
        unless defined ${$Regexp::MatchContext::target_ref};
    my $oldlen = length substr ${$Regexp::MatchContext::target_ref}, $-[0], $+[0]-$-[0], $newval;
    my $delta = length($newval) - $oldlen;
    *- = [$-[0] ];
    *+ = [$+[0] + $delta];
}



package Regexp::MatchContext::POSTMATCH;
use Tie::Scalar;
use base 'Tie::StdScalar';

sub FETCH {
    return undef unless defined ${$Regexp::MatchContext::target_ref};
    return substr ${$Regexp::MatchContext::target_ref}, $+[0];
}

sub STORE {
    my ($self, $newval) = @_;
    Regexp::MatchContext::_cant_assign('$POSTMATCH')
        unless defined ${$Regexp::MatchContext::target_ref};
    substr(${$Regexp::MatchContext::target_ref}, $+[0]) = $newval;
}


1; # Magic true value required at end of module
__END__