File Coverage

blib/lib/Regexp/RegGrp.pm

Criterion	Covered	Total	%
statement	145	164	88.4
branch	31	44	70.4
condition	10	14	71.4
subroutine	21	21	100.0
pod	1	12	8.3
total	208	255	81.5

package Regexp::RegGrp;

use 5.008009;
use warnings;
use strict;
use Carp;
use Regexp::RegGrp::Data;

BEGIN {
    if ( $] < 5.010000 ) {
        require re;
        re->import( 'eval' );
    }
}

use constant {
    ESCAPE_BRACKETS => qr~(?<])~,
    ESCAPE_CHARS    => qr~\\.~,
    BRACKETS        => qr~\(~,
    BACK_REF        => qr~(?:\\g?(\d\d*)|\\g\{(\d+)\})~
};

# =========================================================================== #

our $VERSION = '1.002001';

sub new {
    my ( $class, $in_ref )  = @_;
    my $self                = {};

    bless( $self, $class );

    if ( ref( $in_ref ) ne 'HASH' ) {
        carp( 'First argument must be a hashref!' );
        return;
    }

    unless ( exists( $in_ref->{reggrp} ) ) {
            carp( 'Key "reggrp" does not exist in input hashref!' );
            return;
    }

    if ( ref( $in_ref->{reggrp} ) ne 'ARRAY' ) {
        carp( 'Value for key "reggrp" must be an arrayref!' );
        return;
    }

    if (
        ref( $in_ref->{restore_pattern} ) and
        ref( $in_ref->{restore_pattern} ) ne 'Regexp'
    ) {
        carp( 'Value for key "restore_pattern" must be a scalar or regexp!' );
        return;
    }

    my $no = 0;

    map {
        $no++;

        my $reggrp_data = Regexp::RegGrp::Data->new(
            {
                regexp          => $_->{regexp},
                replacement     => $_->{replacement},
                store           => $_->{store},
                modifier        => $_->{modifier},
                restore_pattern => $in_ref->{restore_pattern}
            }
        );

        unless ( $reggrp_data ) {
            carp( 'RegGrp No ' . $no . ' in arrayref is malformed!' );
            return;
        }

        $self->reggrp_add( $reggrp_data );
    } @{$in_ref->{reggrp}};

    my $restore_pattern         = $in_ref->{restore_pattern} || qr~\x01(\d+)\x01~;
    $self->{_restore_pattern}   = qr/$restore_pattern/;

    my $offset  = 1;
    my $midx    = 0;

    # In perl versions < 5.10 hash %+ doesn't exist, so we have to initialize it
    $self->{_re_str} = ( ( $] < 5.010000 ) ? '(?{ %+ = (); })' : '' ) . join(
        '|',
        map {
            my $re = $_->regexp();
            # Count backref brackets
            $re =~ s/${\(ESCAPE_CHARS)}//g;
            $re =~ s/${\(ESCAPE_BRACKETS)}//g;
            my @nparen = $re =~ /${\(BRACKETS)}/g;

            $re = $_->regexp();

            my $backref_pattern = '\\g{%d}';

            if ( $] < 5.010000 ) {
                $backref_pattern = '\\%d';
            }

            $re =~ s/${\(BACK_REF)}/sprintf( $backref_pattern, $offset + ( $1 || $2 ) )/eg;

            my $ret;

            if ( $] < 5.010000 ) {
                # In perl versions < 5.10 we need to fill %+ hash manually
                # perl 5.8 doesn't reset the %+ hash correctly if there are zero-length submatches
                # so this is also done here
                $ret = '(' . $re . ')' . '(?{ %+ = ( \'_' . $midx++ . '\' => $^N ); })';
            }
            else {
                $ret = '(?\'_' . $midx++ . '\'' . $re . ')';
            }

            $offset += scalar( @nparen ) + 1;

            $ret;

        } $self->reggrp_array()
    );

    return $self;
}

# re_str methods

sub re_str {
    my $self = shift;

    return $self->{_re_str};
}

# /re_str methods

# restore_pattern methods

sub restore_pattern {
    my $self = shift;

    return $self->{_restore_pattern};
}

# /restore_pattern methods

# store_data methods

sub store_data_add {
    my ( $self, $data ) = @_;

    push( @{$self->{_store_data}}, $data );
}

sub store_data_by_idx {
    my ( $self, $idx ) = @_;

    return $self->{_store_data}->[$idx];
}

sub store_data_count {
    my $self = shift;

    return scalar( @{$self->{_store_data} || []} );
}

sub flush_stored {
    my $self = shift;

    $self->{_store_data} = [];
}

# /store_data methods

# reggrp methods

sub reggrp_add {
    my ( $self, $reggrp ) = @_;

    push( @{$self->{_reggrp}}, $reggrp );
}

sub reggrp_array {
    my $self = shift;

    return @{$self->{_reggrp}};
}

sub reggrp_by_idx {
    my ( $self, $idx ) = @_;

    return $self->{_reggrp}->[$idx];
}

# /reggrp methods

sub exec {
    my ( $self, $input, $opts ) = @_;

    if ( ref( $input ) ne 'SCALAR' ) {
        carp( 'First argument in Regexp::RegGrp->exec must be a scalarref!' );
        return undef;
    }

    $opts ||= {};

    if ( ref( $opts ) ne 'HASH' ) {
        carp( 'Second argument in Regexp::RegGrp->exec must be a hashref!' );
        return undef;
    }

    my $to_process  = \'';
    my $cont        = 'void';

    if ( defined( wantarray ) ) {
        my $tmp_input = ${$input};

        $to_process = \$tmp_input;
        $cont       = 'scalar';
    }
    else {
        $to_process = $input;
    }

    ${$to_process} =~ s/${\$self->re_str()}/$self->_process( { match_hash => \%+, opts => $opts } )/eg;

    # Return a scalar if requested by context
    return ${$to_process} if ( $cont eq 'scalar' );
}

sub _process {
    my ( $self, $in_ref ) = @_;

    my %match_hash  = %{$in_ref->{match_hash}};
    my $opts        = $in_ref->{opts};

    my $match_key   = ( keys( %match_hash ) )[0];
    my ( $midx )    = $match_key =~ /^_(\d+)$/;
    my $match       = $match_hash{$match_key};

    my $reggrp = $self->reggrp_by_idx( $midx );

    my @submatches = $match =~ $reggrp->regexp();
    map { $_ .= ''; } @submatches;

    my $ret = $match;

    my $replacement = $reggrp->replacement();

    if (
        defined( $replacement ) and
        not ref( $replacement )
    ) {
        $ret = $replacement;
    }
    elsif ( ref( $replacement ) eq 'CODE' ) {
        $ret = $replacement->(
            {
                match       => $match,
                submatches  => \@submatches,
                opts        => $opts,
                store_index => $self->store_data_count()
            }
        );
    }

    my $store = $reggrp->store();

    if ( $store ) {
        my $tmp_match = $match;
        if ( not ref( $store ) ) {
            $tmp_match = $store;
        }
        elsif ( ref( $store ) eq 'CODE' ) {
            $tmp_match = $store->(
                {
                    match       => $match,
                    submatches  => \@submatches,
                    opts        => $opts
                }
            );
        }

        $self->store_data_add( $tmp_match );
    }

    return $ret;
};

sub restore_stored {
    my ( $self, $input ) = @_;

    if ( ref( $input ) ne 'SCALAR' ) {
        carp( 'First argument in Regexp::RegGrp->restore must be a scalarref!' );
        return undef;
    }

    my $to_process  = \'';
    my $cont        = 'void';

    if ( defined( wantarray ) ) {
        my $tmp_input = ${$input};

        $to_process = \$tmp_input;
        $cont       = 'scalar';
    }
    else {
        $to_process = $input;
    }

    # Here is a while loop, because there could be recursive replacements
    while ( ${$to_process} =~ /${\$self->restore_pattern()}/ ) {
        ${$to_process} =~ s/${\$self->restore_pattern()}/$self->store_data_by_idx( $1 )/egsm;
    }

    $self->flush_stored();

    # Return a scalar if requested by context
    return ${$to_process} if ( $cont eq 'scalar' );
}

1;

__END__