File Coverage

blib/lib/YASF.pm

Criterion	Covered	Total	%
statement	151	152	99.3
branch	76	78	97.4
condition	6	6	100.0
subroutine	28	28	100.0
pod	4	4	100.0
total	265	268	98.8

###############################################################################
#
# This file copyright © 2016 by Randy J. Ray, all rights reserved
#
# See "LICENSE AND COPYRIGHT" in the POD for terms.
#
###############################################################################
#
#   Description:    A string-formatter inspired by Python's format()
#
#   Functions:      YASF
#                   new
#                   bind
#                   format
#
#   Libraries:      None (only core)
#
#   Global Consts:  @EXPORT_OK
#                   %NOT_ACCEPTABLE_REF
#
#   Environment:    None
#
###############################################################################

package YASF;

use 5.008;
use strict;
use warnings;
use overload fallback => 0,
    'eq'  => \&_eq,
    'ne'  => \&_ne,
    'lt'  => \&_lt,
    'le'  => \&_le,
    'gt'  => \&_gt,
    'ge'  => \&_ge,
    'cmp' => \&_cmp,
    q{.}  => \&_dot,
    q{.=} => \&_dotequal,
    q{""} => \&_stringify,
    q{%}  => \&_interpolate;

use Carp qw(carp croak);
use Exporter qw(import);

our $VERSION = '0.005'; # VERSION

BEGIN {
    no strict 'refs'; ## no critic (ProhibitNoStrict)

    for my $method (qw(template bindings on_undef)) {
        *{$method} = sub { shift->{$method} }
    }
}

my %NOT_ACCEPTABLE_REF = (
    SCALAR  => 1,
    CODE    => 1,
    REF     => 1,
    GLOB    => 1,
    LVALUE  => 1,
    FORMAT  => 1,
    IO      => 1,
    VSTRING => 1,
    Regexp  => 1,
);

my %VALID_ON_UNDEF = (
    die    => 1,
    warn   => 1,
    token  => 1,
    ignore => 1,
);

our @EXPORT_OK = qw(YASF);

###############################################################################
#
#   Sub Name:       YASF
#
#   Description:    Shortcut to calling YASF->new($str) with no other args.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $template in      scalar    String template for formatter
#
#   Returns:        Success:    new object
#                   Failure:    dies
#
###############################################################################
## no critic(ProhibitSubroutinePrototypes)
sub YASF ($) { return YASF->new(shift); }

###############################################################################
#
#   Sub Name:       new
#
#   Description:    Class constructor. Creates the basic object and
#                   pre-compiles the template into the form that the formatter
#                   uses.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Name of class
#                   $template in      scalar    String template for formatter
#                   @args     in      scalar    Everything else (see code)
#
#   Returns:        Success:    new object
#                   Failure:    dies
#
###############################################################################
sub new {
    my ($class, $template, @args) = @_;

    croak 'new requires string template argument' if (! defined $template);

    my $args = @args == 1 ? $args[0] : { @args };
    my $self = bless {
        template => $template,
        bindings => undef,
        on_undef => 'warn',
    }, $class;

    $self->_compile;
    if ($args->{bindings}) {
        $self->bind($args->{bindings});
    }
    if ($args->{on_undef}) {
        croak "new: Invalid value for 'on_undef' ($args->{on_undef})"
            if (! $VALID_ON_UNDEF{$args->{on_undef}});
        $self->{on_undef} = $args->{on_undef};
    }

    return $self;
}

###############################################################################
#
#   Sub Name:       bind
#
#   Description:    Add or change object-level bindings
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $bindings in      ref       New bindings
#
#   Globals:        %NOT_ACCEPTABLE_REF
#
#   Returns:        Success:    $self
#                   Failure:    dies
#
###############################################################################
sub bind { ## no critic(ProhibitBuiltinHomonyms)
    my ($self, $bindings) = @_;

    if ((@_ == 2) && (! defined $bindings)) {
        # The means of unbinding is to call $obj->bind(undef):
        undef $self->{bindings};
    } else {
        croak 'bind: New bindings must be provided as a parameter'
            if (! $bindings);

        my $type = ref $bindings;
        if (! $type) {
            croak 'New bindings must be a reference (HASH, ARRAY or object)';
        } elsif ($NOT_ACCEPTABLE_REF{$type}) {
            croak "New bindings reference type ($type) not usable";
        }

        $self->{bindings} = $bindings;
    }

    return $self;
}

###############################################################################
#
#   Sub Name:       format
#
#   Description:    Front-end to the recursive _format routine, which does the
#                   bulk of the parsing/interpolation of the object's template
#                   against the given bindings.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $bindings in      ref       Optional, bindings to use in
#                                                 interpolation. Defaults to
#                                                 object-level bindings.
#
#   Returns:        Success:    string
#                   Failure:    dies
#
###############################################################################
sub format { ## no critic(ProhibitBuiltinHomonyms)
    my ($self, $bindings) = @_;

    $bindings ||= $self->bindings;
    croak 'format: Bindings are required if object has no internal bindings'
        if (! $bindings);

    my $value = join q{} =>
        map { ref() ? $self->_format($bindings, @{$_}) : $_ }
        @{$self->{_compiled}};

    return $value;
}

# Private functions that support the public API:

# Compile the template into a tree structure that can be easily traversed for
# formatting.
sub _compile {
    my $self = shift;

    my @tokens = $self->_tokenize;

    my @stack = ([]);
    my $level = 0;
    my @opens = ();

    while (my ($type, $value) = splice @tokens, 0, 2) {
        if ($type eq 'STRING') {
            push @{$stack[$level]}, $value;
        } elsif ($type eq 'OPEN') {
            push @stack, [];
            $level++;
            push @opens, $value;
        } else {
            # Must be 'CLOSE'.
            if ($level) {
                my $subtree = pop @stack;
                $level--;
                push @{$stack[$level]}, $subtree;
                pop @opens;
            } else {
                croak "Unmatched closing brace at position $value";
            }
        }
    }

    if ($level) {
        croak sprintf '%d unmatched opening brace%s, last at position %d',
            $level, $level == 1 ? q{} : 's', pop @opens;
    }

    $self->{_compiled} = $stack[0];
    return $self;
}

# Tokenize the object's template into a sequence of (type, value) pairs that
# identify the opening and closing braces, and ordinary strings.
sub _tokenize {
    my $self = shift;

    my (@list, $base, $pos, $len);
    my $str = $self->template;

    $base = 0;
    while ($str =~ /(?
        $pos = pos $str;
        if ($len = $pos - $base) {
            (my $piece = substr $str, $base, $len) =~ s/\\([{}])/$1/g;
            push @list, 'STRING', $piece;
        }
        push @list, ('{' eq substr $str, $pos, 1) ? 'OPEN' : 'CLOSE';
        push @list, $pos;
        $base = $pos + 1;
    }

    if (length($str) > $base) {
        (my $piece = substr $str, $base) =~ s/\\([{}])/$1/g;
        push @list, 'STRING', $piece;
    }

    return @list;
}

# Does the hard and recursive part of the actual formatting. Not actually that
# hard, but a little recursive.
sub _format {
    my ($self, $bindings, @elements) = @_;

    # Slight duplication of code from format() here, but it saves having to
    # keep track of depth and do a conditional on every return.
    my $expr = join q{} =>
        map { ref() ? $self->_format($bindings, @{$_}) : $_ } @elements;

    return $self->_expr_to_value($bindings, $expr);
}

# Converts an expression like "a.b.c" into a value from the bindings
sub _expr_to_value {
    my ($self, $bindings, $string) = @_;

    my ($expr, $format) = split /:/ => $string, 2;
    # For now, $format is ignored
    my @hier = split /[.]/ => $expr;
    my $node = $bindings;

    for my $key (@hier) {
        if ($key =~ /^\d+$/) {
            if (ref $node eq 'ARRAY') {
                $node = $node->[$key];
            } else {
                croak "Key-type mismatch (key $key) in $expr, node is not " .
                    'an ARRAY ref';
            }
        } else {
            if (ref $node eq 'HASH') {
                $node = $node->{$key};
            } elsif (ref $node eq 'ARRAY') {
                croak "Key-type mismatch (key $key) in $expr, node is an " .
                    'ARRAY ref when expecting HASH or object';
            } elsif (ref $node) {
                $node = $node->$key();
            } else {
                croak "Key-type mismatch (key $key) in $expr, node is not " .
                    'a HASH ref or object';
            }
        }
    }

    # Because all the key-substitution has been done before this sub is called,
    # it's probably a bad thing if $node is a ref. It's gonna get stringified
    # as a ref, which is probably not what the caller intended.
    if (ref $node) {
        carp "Format expression $expr yielded a reference value rather than " .
            'a scalar';
    }
    # If $node is undef, react accordingly based on the "on_undef" property.
    if (! defined $node) {
        # We validated this value in new(), so no need to do so here.
        my $what_to_do = $self->on_undef;
        if ($what_to_do eq 'ignore') {
            $node = q{};
        } elsif ($what_to_do eq 'warn') {
            carp "No binding for reference to '$expr'";
            $node = q{};
        } elsif ($what_to_do eq 'die') {
            croak "No binding for reference to '$expr'";
        } else {
            # Leave the token unchanged
            $node = "{$expr}";
        }
    }

    return $node;
}

# Actual operator-overload functions:

# Handle the object stringification (the "" operator)
sub _stringify {
    my $self = shift;
    my $bindings = $self->bindings;

    return $bindings ? $self->format($bindings) : $self->template;
}

# Handle the % interpolation operator
sub _interpolate {
    my ($self, $bindings, $swap) = @_;

    if ($swap) {
        my $class = ref $self;
        croak "$class object must come first in % interpolation";
    }

    return $self->format($bindings);
}

# Handle the 'cmp' operator
sub _cmp {
    my ($self, $other, $swap) = @_;

    return $swap ?
        ($other cmp $self->_stringify) : ($self->_stringify cmp $other);
}

# Handle the 'eq' operator
sub _eq {
    my ($self, $other, $swap) = @_;

    return $self->_stringify eq $other;
}

# Handle the 'ne' operator
sub _ne {
    my ($self, $other, $swap) = @_;

    return $self->_stringify ne $other;
}

# Handle the 'lt' operator
sub _lt {
    my ($self, $other, $swap) = @_;

    return $swap ?
        ($other lt $self->_stringify) : ($self->_stringify lt $other);
}

# Handle the 'le' operator
sub _le {
    my ($self, $other, $swap) = @_;

    return $swap ?
        ($other le $self->_stringify) : ($self->_stringify le $other);
}

# Handle the 'gt' operator
sub _gt {
    my ($self, $other, $swap) = @_;

    return $swap ?
        ($other gt $self->_stringify) : ($self->_stringify gt $other);
}

# Handle the 'ge' operator
sub _ge {
    my ($self, $other, $swap) = @_;

    return $swap ?
        ($other ge $self->_stringify) : ($self->_stringify ge $other);
}

# Handle the '.' operator
sub _dot {
    my ($self, $other, $swap) = @_;

    return $swap ?
        $other . $self->_stringify : $self->_stringify . $other;
}

# Handle the '.=' operator
sub _dotequal {
    my ($self, $other, $swap) = @_;

    if (! $swap) {
        my $class = ref $self;
        croak "$class object cannot be on the left of .=";
    }

    return $other . $self->_stringify;
}

1;

__END__