File Coverage

blib/lib/String/Tools.pm

Criterion	Covered	Total	%
statement	80	89	89.8
branch	41	62	66.1
condition	21	33	63.6
subroutine	13	13	100.0
pod	10	10	100.0
total	165	207	79.7

use v5.12;

use warnings;

package String::Tools;
# ABSTRACT: Various tools for manipulating strings.
our $VERSION = '0.18.279'; # VERSION


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 ($_) = @_;

    if ( not defined() ) {
        return define();
    } elsif ( not( my $ref = ref() ) ) {
        return $_;
    } elsif ( $ref eq 'ARRAY' ) {
        return "@$_";
        #return join( $" // ' ', map stringify, @$_ );    # What about loops?
    } elsif ( $ref eq 'HASH' ) {
        return "@{[%$_]}";
        #return join( $" // ' ', map stringify, %$_ );    # What about loops?
    } elsif ( $ref eq 'REF' && ref($$_) ne 'REF' ) {
        return stringify($$_);
    } elsif ( $ref eq 'SCALAR' ) {
        return stringify($$_);
    }
    return "$_";
}


sub subst {
    my $str  = stringify( shift );
    @_ = ( $_ ) if defined($_) && ! @_;

    my %subst;
    if ( 1 == @_ ) {
        if ( not( my $ref = ref $_[0] ) ) { %subst = ( _ => +shift ) }
        elsif ( $ref eq 'ARRAY' )         { %subst = @{ +shift }     }
        elsif ( $ref eq 'HASH' )          { %subst = %{ +shift }     }
        else                              { %subst = ( _ => +shift ) }
    } else { %subst = @_ }

    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__