File Coverage

blib/lib/String/Tools.pm

Criterion	Covered	Total	%
statement	73	79	92.4
branch	41	62	66.1
condition	21	33	63.6
subroutine	13	13	100.0
pod	10	10	100.0
total	158	197	80.2

use v5.12;

use warnings;

package String::Tools v0.19.045;
# ABSTRACT: Various tools for manipulating strings.


use Exporter 'import';

our @EXPORT    = qw();
our @EXPORT_OK = qw(
    define
    is_blank
    shrink
    stitch
    stitcher
    stringify
    subst
    subst_vars
    trim
    trim_lines
);

### Variables ###


our $BLANK  = '[[:cntrl:][:space:]]';


our $SUBST_VAR = qr/[[:alpha:]_]+\w*(?:[[:punct:]]\w+)*/;


our $THREAD = ' ';

### Functions ###

sub stringify(_);    # Forward declaration


sub define(_) { return $_[0] // !!undef }


sub is_blank(_) {
    local $_ = &stringify;
    return not( length() && !/\A$BLANK+\z/ );
}


sub shrink(_) {
    local $_ = trim(&stringify);
    s/$BLANK+/$THREAD/g;
    return $_;
}


sub stitch {
    my $str       = '';
    my $was_blank = 1;

    local $_;
    foreach my $s (map stringify, @_) {
        my $is_blank = is_blank($s);
        $str .= $THREAD unless ( $was_blank || $is_blank );
        $str .= $s;
        $was_blank = $is_blank;
    }

    return $str;
}


sub stitcher {
    local $THREAD = shift // $THREAD;
    return &stitch;
}


sub stringify(_) {
    local ($_) = @_;

    return not( defined() ) ? define() : do {
        my $ref = ref();
         !$ref                               ?            $_
        : $ref eq 'ARRAY'                    ?          "@$_"
        : $ref eq 'HASH'                     ?       "@{[%$_]}"
        : $ref eq 'REF' && ref($$_) ne 'REF' ? stringify($$_)
        : $ref eq 'SCALAR'                   ? stringify($$_)
        :                                                "$_"
        ;
    };
}


sub subst {
    my $str  = stringify( shift );
    @_ = ( $_ ) if defined($_) && ! @_;
    my %subst = 1 == @_ ? do {
            my $ref = ref( $_[0] );
              not($ref)       ? ( _ => +shift )
            : $ref eq 'ARRAY' ? @{ +shift }
            : $ref eq 'HASH'  ? %{ +shift }
            :                   ( _ => +shift );
        }
        : @_;

    if (%subst) {
        local $_;
        my $names = '(?:'
            . join( '|',
                map quotemeta,
                    sort { length($b) <=> length($a) || $a cmp $b }
                        grep { length() && /\A$SUBST_VAR\z/ }
                            keys %subst
            )
            . ')\b';
        $str =~ s[\$(?:\{\s*($names)\s*\}|($names))]
                 [ stringify( $subst{ $1 // $2 } ) ]eg;
    }

    return $str;
}


sub subst_vars(_) {
    local ($_) = &stringify;

    my @vars = /\$(\{\s*$SUBST_VAR\s*\}|$SUBST_VAR\b)/g;
    my %seen = ();
    return grep { !$seen{$_}++ }
        map { trim( $_, qr/\{\s*/, qr/\s*\}/ ) } @vars;
}


sub trim {
    local $_ = stringify( @_ ? shift : $_ );

    my ( $lead, $rear );
    my $count = scalar @_;
    if    ($count == 0) {}
    elsif ($count == 1) { $lead = shift; }
    else {
        # Could be:
        #   1. l => $value
        #   2. r => $value
        #   3. l => $value, r => $value
        #   or r => $value, l => $value
        #   4. $lead, $rear
        my %lr = @_;
        $lead = delete $lr{l} if exists $lr{l};
        $rear = delete $lr{r} if exists $lr{r};
        # At this point, there should be nothing in %lr,
        # so if there is, then this must be case 4.
        ( $lead, $rear ) = @_ if %lr;
    }

    $lead //= $BLANK . '+';
    s/\A$lead// if ( length $lead );

    $rear //= $lead;
    s/$rear\z// if ( length $rear );

    return $_;
}


sub trim_lines {
    local $_ = stringify( @_ ? shift : $_ );

    my ( $lead, $rear );
    my $count = scalar @_;
    if    ($count == 0) {}
    elsif ($count == 1) { $lead = shift; }
    else {
        # Could be:
        #   1. l => $value
        #   2. r => $value
        #   3. l => $value, r => $value
        #   or r => $value, l => $value
        #   4. $lead, $rear
        my %lr = @_;
        $lead = delete $lr{l} if exists $lr{l};
        $rear = delete $lr{r} if exists $lr{r};
        # At this point, there should be nothing in %lr,
        # so if there is, then this must be case 4.
        ( $lead, $rear ) = @_ if %lr;
    }

    $lead //= $BLANK . '+';
    s/^$lead//gm if ( length $lead );

    $rear //= $lead;
    s/$rear$//gm if ( length $rear );

    return $_;
}

1;

__END__