File Coverage

blib/lib/String/Interpolate/RE.pm

Criterion	Covered	Total	%
statement	60	60	100.0
branch	44	44	100.0
condition	22	24	91.6
subroutine	9	9	100.0
pod			n/a
total	135	137	98.5

package String::Interpolate::RE;

# ABSTRACT: interpolate variables into strings using regular expressions

use v5.10;

use strict;
use warnings;

use Exporter::Shiny qw[ strinterp ];

our $VERSION = '0.12';

my %Opt = (
    variable_re        => qr/\w+/,
    raiseundef         => !!0,
    emptyundef         => !!0,
    useenv             => !!1,
    format             => !!0,
    recurse            => !!0,
    recurse_limit      => 0,
    recurse_fail_limit => 100,
    fallback           => undef,
);
my %Defaults = map { $_ => $Opt{$_} } grep { defined $Opt{$_} } keys %Opt;


*strinterp = _mk_strinterp( \%Defaults );

sub _croak {
    require Carp;
    goto &Carp::croak;
}

sub _generate_strinterp {

    my ( undef, undef, $args ) = @_;

    return \&strinterp
      if !defined $args || !defined $args->{opts};

    my %opt = %Defaults;
    $opt{ lc $_ } = $args->{opts}{$_} foreach keys %{ $args->{opts} };
    if ( my @bad = grep !exists $Opt{$_}, keys %opt ) {
        _croak( 'unrecognized option(s): ' . join( ', ', @bad ) );
    }

    _croak( q{'fallback' option must be a coderef} )
      if exists $opt{fallback} && ref( $opt{fallback} ) ne 'CODE';

    return _mk_strinterp( \%opt );
}

sub _mk_strinterp {

    my $default_opt = shift;

    return sub {

        my ( $text, $var, $opts ) = @_;

        $var = {} unless defined $var;

        my %opt = %$default_opt;

        if ( defined $opts ) {
            $opt{ lc $_ } = $opts->{$_} foreach keys %$opts;
            if ( my @bad = grep !exists $Opt{$_}, keys %opt ) {
                _croak( 'unrecognized option(s): ' . join( ', ', @bad ) );
            }
            _croak( q{'fallback' option must be a coderef} )
              if exists $opt{fallback} && ref( $opt{fallback} ) ne 'CODE';
        }

        my $fmt = $opt{format} ? ':([^}]+)' : '()';

        $opt{track} = {};
        $opt{loop}  = 0;
        $opt{fmt}   = $fmt;

        _strinterp( $text, $var, \%opt );

        return $text;
    };
}

sub _strinterp {

    my $var = $_[1];
    my $opt = $_[2];
    my $fmt = $opt->{fmt};
    my $re  = $opt->{variable_re};

    # The following code pulls things out of the hash to reduce the
    # number of hash lookups in the code in the RE.  Unfortunately, iqt
    # doesn't seem to make much of a difference, but it does clean
    # that code up a bit.

    my ( $useenv, $raiseundef, $recurse, $fallback, $emptyundef, $track,
        $recurse_limit, $recurse_fail_limit )
      = @{$opt}{
        qw( useenv raiseundef recurse fallback emptyundef track
          recurse_limit recurse_fail_limit
        ) };

    my $rloop   = \( $opt->{loop} );
    my $is_code = 'CODE' eq ref $var;

    $_[0] =~ s{
               \$                    # find a literal dollar sign
              (                      # followed by either
               [{] ($re)(?:$fmt)? [}]  #  a variable name in curly brackets ($2)
                                     #  and an optional sprintf format
               |                     # or
                (\w+)                #   a bareword ($3)
              )
            }{
                my $t = defined $4 ? $4 : $2;

                my $user_value
                  = $is_code          ? $var->( $t )
                  : exists $var->{$t} ? $var->{$t}
                  : $fallback         ? $fallback->( $t )
                  :                     undef;

                #<<<
                my $v =
                  # user provided?
                  defined $user_value          ? $user_value

                  # maybe in the environment
                  : $useenv && exists $ENV{$t} ? $ENV{$t}

                  # undefined: throw an error  ?
                  : $raiseundef                ? _croak( "undefined variable: $t\n" )

                  # undefined
                  : undef;
                #>>>

                if ( $recurse && defined $v ) {

                  RECURSE:
                    {
                        _croak( "circular interpolation loop detected with repeated interpolation of <\$$t>\n" )
                          if $track->{$t}++;

                        my $loop = ++$$rloop;

                        last RECURSE if $recurse_limit && $loop > $recurse_limit;

                        _croak( "recursion fail-safe limit ($recurse_fail_limit) reached at interpolation of <\$$t>\n" )
                          if $recurse_fail_limit && $loop > $recurse_fail_limit;

                        _strinterp( $v, $_[1], $_[2] );
                    }

                    delete $track->{$t};
                    --$$rloop;
                }

                # if not defined:
                #   if emptyundef, replace with an empty string
                #   otherwise,     just put it back into the string
                !defined $v
                  ? ( $emptyundef ? '' : '$' . $1 )

                  # no format? return as is
                  : !defined $3 || $3 eq '' ? $v

                  # format it
                  : sprintf( $3, $v )

                  ;
        }egx;
}

1;

#
# This file is part of String-Interpolate-RE
#
# This software is Copyright (c) 2017 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__