package Regexp::NamedCaptures;

=head1 NAME

Regexp::NamedCaptures - Saves capture results to your own variables

=head1 SYNOPSIS

 use Regexp::NamedCaptures;
 
 /(?<\$bar>...)/
 # is the same as
 if ( /(...)/ ) {
     $bar = $1;
 }

=head1 DESCRIPTION

This experimental module implements named captures. When your regular
expression captures something, you can have it automatically copied
out to the right location. This is an improvement over normal perl
because now you don't have to deal with positional captures. When your
expression is complex and there are multiple, perhaps nested captures,
it really helps to not have to track what number you're supposed to
find your data in.

=head1 FUNCTIONS

=over 4

=item $regexp = convert( $regexp )

This function does all the work of converting a regular expression
containing named capture expressions into an expression that can be
used by perl. You only need this if you're going to be creating
regular expressions at runtime.

 $re = Regexp::NamedCapture::convert '(?<$var>...)'
 $re = qr/$re/

=back

=head1 BUGS

Regexp::NamedCaptures uses the (?{...}) expression. This is documented
as being experimental.

=head1 AUTHOR

Joshua ben Jore <jjore@cpan.org>

=head1 SEE ALSO

I got my inspiration for this from Jeffrey E. F. Friedl's description
of named captures in .Net in his book Mastering Regular
Expressions.

=cut

use strict;
use warnings;
use Text::Balanced 'extract_bracketed';

sub convert {
    my $in = shift;
    my $out = '';
    
    my ( $package, $filename, $line ) = caller;
    
    my $context = "(#\Q$filename\E:\Q$line\E";
    
    while ( length $in ) {
        # Seek $in forward until the ( is found.
        if ( $in =~ /\(/ ) {
            $out .= substr $in, 0, $-[0], '';
            my ( $expression, $rest ) = extract_bracketed( $in, '()' )
+;
            $in = $rest;
            
            if ( '(?<' eq substr $expression, 0, 3 ) {
                # Look for the (?<NAME> pattern and zap it away.
                $expression = substr $expression, 2;
                
                # Split the <NAME> part from the EXPR part of
                # (?<NAME>EXPR)
                my $name;
                ( $name, $expression ) = extract_bracketed( $expressio
+n, '<>' );
                
                # Zap the <> on <NAME>
                substr $name, 0, 1, '';
                substr $name, -1, 1, '';
                
                # Unescape stuff in $name
                $name =~ s/\\(.)/$1/gs;
        
                # Zap the ) on EXPR)
                substr $expression, -1, 1, '';
                
                # Rewrite the expression so its a plain capture
                # followed by a code block whi
                $out .= "(?#\QNamed capture to $name from $filename at
+ line $line\E)"
                  . "($expression)"
                    . "(?{$name=\$^N})"
                      . "(?#\Q$name\E END)";
            }
        }
        else {
            $out .= $in;
            $in = '';
        }
    }
    
    return $out;
}

# Overload magic follows
use overload( '.' => \ &_concat,
              '""' => \ &_finalize );

sub import {
    # Constants are overloaded so their fragments are passed to
    # _postpone().
    overload::constant qr => \ &_postpone;
}

sub _postpone {
    # _postpone returns an object.
    my $re = shift;
    bless \ $re, __PACKAGE__;
}

sub _concat {
    # _concat happens anytime something is interpolated. It
    # re-postpones things until later.
    my ( $a, $b, $inverted ) = @_;
    ($a,$b)=($b,$a) if $inverted;
    $a = $$a if ref $a eq __PACKAGE__;
    $b = $$b if ref $b eq __PACKAGE__;
    
    my $re = "$a$b";
    bless \ $re, __PACKAGE__;
}

sub _finalize {
    # _finalize happens when the regex is due to be compiled. Here, I
    # just rethrow the regex to the user-accessible function
    # convert(). Because convert() does some caller magic, I want to
    # remove myself from the call stack.
    
    @_ = ${$_[0]};
    goto &convert;
}

1;
[download]