File Coverage

blib/lib/String/Bash.pm

Criterion	Covered	Total	%
statement	170	172	98.8
branch	70	86	81.4
condition	22	29	75.8
subroutine	18	18	100.0
pod	0	1	0.0
total	280	306	91.5

use strict;
use warnings;
package String::Bash;
BEGIN {
  $String::Bash::AUTHORITY = 'cpan:AJGB';
}
BEGIN {
  $String::Bash::VERSION = '1.110960';
}
#ABSTRACT: Parameter expansion in strings

use Sub::Exporter -setup => {
    exports => [qw( bash )],
};

use Regexp::Common qw( balanced );
use PadWalker qw( peek_my peek_our );
use Scalar::Util qw( blessed );



sub bash($@) {
    my $format = shift;

    my $lookup;
    my $setter;

    if ( defined $_[0] ) {
        if ( blessed $_[0] ) {
            my $obj = $_[0];
            $lookup = sub { my $var = shift; return $obj->$var; };
            $setter = sub { my $var = shift; $obj->$var(@_); };
        } else {
            if ( @_ == 1 && ref $_[0] eq 'HASH' ) {
                my $href = $_[0];
                $lookup = sub { return $href->{ $_[0] }; };
                $setter = sub { $href->{ $_[0] } = $_[1]; };
            } else {
                my %vars = @_;
                $lookup = sub { return $vars{ $_[0] }; };
                $setter = sub { $vars{ $_[0] } = $_[1]; };
            }
        }
    } else {

        my $allmyvars = peek_my(1);
        my $allourvars = peek_our(1);

        $lookup = sub {
            my $var = shift;
            $var = "\$$var";
            my $val = exists $allmyvars->{$var}
                ? $allmyvars->{$var} : $allourvars->{$var};

            return unless ref $val eq 'SCALAR';

            return ${ $val };
        };
        $setter = sub {
            my $var = shift;
            my $val = shift;
            $var = "\$$var";

            if ( exists $allmyvars->{$var} ) {
                ${ $allmyvars->{$var} } = $val;
            } elsif ( exists $allourvars->{$var} ) {
                ${ $allourvars->{$var} } = $val;
            }
        };
    };

    my $parser; $parser = sub {
        my $format = shift;

        return $format unless index($format, '%{') >= 0;

        my @ph = $format =~ /$RE{balanced}{-begin=>'%{'}{-end=>'}'}/gs;

        for my $e ( @ph ) {
            my $p = substr( $e, 2, -1);
            my $rep;
            if ( substr($p,0,1) eq '#' ) {
                my $name = substr($p, 1);
                my $val = $lookup->($name) || '';

                $rep = length($val);
            } elsif ( $p =~ /\A(\w+)(?:([:#%\/\^,])(.*))?\z/) {
                my ($name, $op, $reminder) = ($1, $2, $3);
                my $val = $lookup->($name);

                FINDREP: {
                    if ( ! $op ) { # %{param}
                        $rep = $val || '';
                        last FINDREP;
                    }
                    # expand reminder
                    $reminder = $parser->($reminder)
                        if index($reminder, '%{') >= 0;

                    if ( $op eq ':' ) {
                        my $control = substr($reminder, 0, 1);
                        if ( $reminder =~ /^\d+/ ) {
                            if ( $val ) {
                                my ($offset, $limit) = split(':', $reminder, 2);
                                if ( $limit ) {
                                    $rep = substr($val, $offset, $limit);
                                } else {
                                    $rep = substr($val, $offset);
                                };

                                last FINDREP;
                            };
                        };

                        if ( $control eq '+' ) {
                            if ( defined $val ) {
                                $rep = substr($reminder, 1);
                            } else {
                                $rep = '';
                            };
                            last FINDREP;
                        };


                        if ( defined $val ) {
                            $rep = $val || '';
                            last FINDREP;
                        } else {
                            if ( $control eq '-' ) {
                                $rep = substr($reminder, 1);
                            } elsif ( $control eq '=' ) {
                                $rep = substr($reminder, 1);
                                $setter->( $name, $rep );
                            }
                        };
                    } elsif ( $op eq '#' ) {
                        if ( $val ) {
                            my $control = substr($reminder, 0, 1);
                            my $qr = "^";

                            if ( $control eq '#' ) { # %{param##qr}
                                $reminder = substr( $reminder, 1);
                                $reminder =~ s/\*/\.*/g;
                                $reminder =~ s/\?/\./g;
                            } else {
                                $reminder =~ s/\?/\./g;
                                $reminder =~ s/\*/\.*?/g;
                            }

                            $qr .= $reminder;
                            ($rep = $val) =~ s/$qr//;
                        }
                    } elsif ( $op eq '%' ) {
                        if ( $val ) {
                            my $control = substr($reminder, 0, 1);
                            my $qr;
                            my $replacement = '';

                            if ( $control eq '%' ) { # %{param%%qr}
                                $qr = substr( $reminder, 1);
                                $qr =~ s/\*/\.*/g;
                            } else {
                                $replacement = substr($reminder, 0, index($reminder, '*'));
                                ($qr = $reminder) =~ s/\*/\.*?/g;
                            }
                            $qr =~ s/\?/\./g;

                            $qr = "$qr\$";
                            ($rep = $val) =~ s/$qr/$replacement/;
                        }
                    } elsif ( $op eq '/' ) {
                        if ( $val ) {
                            my $control = substr($reminder, 0, 1);
                            my ($search, $replacement);
                            if ( $control eq '/' ) { # %{param//search/replacement}
                                ($search, $replacement) = split('/', substr($reminder, 1) );
                                $search =~ s/\*/\.*?/g;
                                $search =~ s/\?/\./g;
                                $replacement ||= '';

                                ($rep = $val) =~ s/$search/$replacement/g;
                            } elsif ( $control eq '#' ) { # %{param/#search/replacement}
                                ($search, $replacement) = split('/', substr($reminder, 1) );
                                $search =~ s/\*/\.*?/g;
                                $search =~ s/\?/\./g;
                                $replacement ||= '';

                                ($rep = $val) =~ s/^$search/$replacement/;
                            } elsif ( $control eq '%' ) { # %{param/%search/replacement}
                                ($search, $replacement) = split('/', substr($reminder, 1) );
                                $search =~ s/\*/\.*?/g;
                                $search =~ s/\?/\./g;
                                $replacement ||= '';

                                ($rep = $val) =~ s/$search$/$replacement/;
                            } else {
                                ($search, $replacement) = split('/', $reminder);
                                $search =~ s/\*/\.*?/g;
                                $search =~ s/\?/\./g;
                                $replacement ||= '';

                                ($rep = $val) =~ s/$search/$replacement/;
                            }
                        }
                    } elsif ( $op eq '^' ) {
                        if ( $val ) {
                            my $control = substr($reminder, 0, 1);

                            if ( $control eq '^' ) { # %{param^^}
                                if ( $reminder eq '^' || $reminder eq '^?' ) {
                                    $rep = uc $val;
                                } else {
                                    my $matching = substr($reminder, 1);
                                    ($rep = $val) =~ s/($matching)/\u$1/g;
                                }
                            } else {
                                if ( length $reminder && $reminder ne '?' ) {
                                    ($rep = $val) =~ s/^($reminder)/\u$1/;
                                } else {
                                    $rep = ucfirst $val;
                                }
                            }
                        }
                    } elsif ( $op eq ',' ) {
                        if ( $val ) {
                            my $control = substr($reminder, 0, 1);

                            if ( $control eq ',' ) { # %{param,,}
                                if ( $reminder eq ',' || $reminder eq ',?' ) {
                                    $rep = lc $val;
                                } else {
                                    my $matching = substr($reminder, 1);
                                    ($rep = $val) =~ s/($matching)/\l$1/g;
                                }
                            } else {
                                if ( length $reminder && $reminder ne '?' ) {
                                    ($rep = $val) =~ s/^($reminder)/\l$1/;
                                } else {
                                    $rep = lcfirst $val;
                                }
                            }
                        }
                    };
                };
            };

            $rep = '' unless defined $rep;
            $format =~ s/\Q$e\E/$rep/g;
        };

        return $format;
    };

    my $result = $parser->( $format );

    return $result;
}


1;

__END__