File Coverage

blib/lib/String/Interpolate/Shell.pm

Criterion	Covered	Total	%
statement	55	61	90.1
branch	34	46	73.9
condition	5	8	62.5
subroutine	10	10	100.0
pod	1	1	100.0
total	105	126	83.3

# --8<--8<--8<--8<--
#
# Copyright (C) 2011 Smithsonian Astrophysical Observatory
#
# This file is part of String-Interpolate-Shell
#
# String-Interpolate-Shell is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
# -->8-->8-->8-->8--

package String::Interpolate::Shell;

use strict;
use warnings;

use Text::Balanced qw[ extract_bracketed extract_multiple extract_quotelike];
use Params::Check qw[ check ];
use Carp;

use base 'Exporter';

our @EXPORT_OK = qw[ strinterp ];

our $VERSION = 0.01;

sub _extract {

    extract_multiple( $_[0],
		      [
		       qr/\s+/,
		       qr/\\(\\)/,
		       qr/\\(\$)/,
		       { V => qr/\$(\w+)/ },
		       { B => sub { (extract_bracketed( $_[0], '{}', qr/\$/ ))[0] } },
		      ] );
}

sub _handle_undef {

    my ( $var, $q, $attr, $rep ) = @_;

    ## no critic(ProhibitAccessOfPrivateData)

    return $var->{$q} if defined $var->{$q};

    carp( sprintf( $attr->{undef_message}, $rep) )
      if $attr->{undef_verbosity} eq 'warn';

    croak( sprintf( $attr->{undef_message}, $rep) )
      if $attr->{undef_verbosity} eq 'fatal';

    return $rep if $attr->{undef_value} eq 'ignore';
}

sub strinterp{

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

    ## no critic(ProhibitAccessOfPrivateData)
    $attr = check( {
		    undef_value => { allow => [ qw[ ignore remove ] ],
				     default => 'ignore' },
		    undef_verbosity => { allow => [ qw[ silent warn fatal ] ],
					 default => 'silent' },
		    undef_message => { default => "undefined variable: %s\n" },
		    }, $attr || {} )
      or croak( "error parsing arguments: ", Params::Check::last_error() );

    my @matches;

    for my $matchstr ( _extract($text ) ) {

	my $ref = ref $matchstr;

	if ( 'B' eq $ref ) {

	    # remove enclosing brackets
	    my $match = substr( $$matchstr, 1,-1 );

	    # see if there's a 'shell' modifier expression
	    my ( $ind, $q, $modf, $rest ) = $match =~ /^(!)?(\w+)(:[-?=+~:])?(.*)/;

	    # if there's no modifier but there is trailing cruft, it's an error
	    die( "unrecognizeable variable name: \${$match}\n")
		if ! defined $modf && $rest ne '';

	    # if indirect flag is set, expand variable
	    if ( defined $ind ) {

		if ( defined $var->{$q} ) {
		    $q = $var->{$q};
		}
		else
		{
		    push @matches, _handle_undef( $attr, '$' . $$matchstr );
		    next;
		}
	    }


	    if ( ! defined $modf ) {

		push @matches, _handle_undef( $var, $q, $attr, '$' . $$matchstr );
	    }

	    elsif ( ':?' eq $modf ) {

		local $attr->{undef_verbosity} = 'fatal';
		local $attr->{undef_message} = $rest;

		push @matches, _handle_undef( $var, $q, $attr, '$' . $$matchstr );

	    }
	    elsif ( ':-' eq $modf ) {

		push @matches, defined $var->{$q} ? $var->{$q} : strinterp( $rest, $var, $attr );

	    }

	    elsif ( ':=' eq $modf ) {


		$var->{$q} = strinterp( $rest, $var, $attr )
		  unless defined $var->{$q};
		push @matches, $var->{$q};

	    }

	    elsif ( ':+' eq $modf ) {

		push @matches, strinterp( $rest, $var, $attr )
		  if defined $var->{$q};

	    }

	    elsif ( '::' eq $modf ) {

		push @matches, sprintf( $rest,  _handle_undef( $var, $q, $attr, '$' . $$matchstr ) );

	    }

	    elsif ( ':~' eq $modf ) {

		my ( $expr, $xtra, $op ) = (extract_quotelike( $rest ))[0,1,3];
		die( "unable to parse variable substitution command: $rest\n" )
		    if $xtra !~ /^\s*$/ or $op !~ /^(s|tr|y)$/;

		my $t = $var->{$q};
		## no critic(ProhibitStringyEval)
		eval "\$t =~ $expr";
		die $@ if $@;

		push @matches, $t;

	    }

	    else { die( "internal error" ) }

	}
	elsif ( 'V' eq $ref ) {

	    my $q = $$matchstr;

	    push @matches, _handle_undef( $var, $q, $attr, "\$$q" );

	}

	elsif ( $ref ) {

	    push @matches, $$matchstr;

	}
	else {

	    push @matches, $matchstr;

	}


    }

    return join('', @matches);

}

1;

__END__