File Coverage

lib/Petal/Hash/Var.pm

Criterion	Covered	Total	%
statement	62	64	96.8
branch	31	40	77.5
condition	7	13	53.8
subroutine	5	5	100.0
pod	0	1	0.0
total	105	123	85.3

# ------------------------------------------------------------------
# Petal::Hash::Var - Evaluates an expression and returns the result.
# ------------------------------------------------------------------
# Author: Jean-Michel Hiver
# This module is redistributed under the same license as Perl
# itself.
# ------------------------------------------------------------------
package Petal::Hash::Var;

use strict;
use warnings;

use Carp;
use Scalar::Util qw( blessed reftype );


our $STRING_RE_DOUBLE  = qr/(?
our $STRING_RE_SINGLE  = qr/(?
our $STRING_RE         = qr/(?:$STRING_RE_SINGLE|$STRING_RE_DOUBLE)/;
our $VARIABLE_RE       = qr/(?:--)?[A-Za-z\_][^ \t]*/;
our $PARAM_PREFIX_RE   = qr/^--/;
our $ESCAPED_CHAR_RE   = qr/(?sm:\\(.))/;
our $BEGIN_QUOTE_RE    = qr/^\"|\'/;
our $END_QUOTE_RE      = qr/\"|\'$/;
our $TOKEN_RE          = qr/(?:$STRING_RE|$VARIABLE_RE)/;
our $PATH_SEPARATOR_RE = qr/(?:\/|\.)/;
our $INTEGER_KEY_RE    = qr/^\d+$/;


sub process
{
    my $class    = shift;
    my $hash     = shift;
    my $argument = shift;

    my @tokens = $argument =~ /($TOKEN_RE)/gsm;
    my $path   = shift (@tokens) or confess "bad syntax for $class: $argument (\$path)";
    my @path   = split( /$PATH_SEPARATOR_RE/, $path );
    my @args   = @tokens;

    # replace variable names by their value
    for (my $i=0; $i < @args; $i++)
    {
        my $arg = $args[$i];
        if ($arg =~ /^$VARIABLE_RE$/)
        {
            $arg =~ s/$ESCAPED_CHAR_RE/$1/gsm;
            if ($arg =~ $PARAM_PREFIX_RE)
            {
                $arg =~ s/$PARAM_PREFIX_RE//;
                $args[$i] = $arg;
            }
            else
            {
                $args[$i] = $hash->fetch ($arg);
            }
        }
        else
        {
            $arg =~ s/$BEGIN_QUOTE_RE//;
            $arg =~ s/$END_QUOTE_RE//;
            $arg =~ s/$ESCAPED_CHAR_RE/$1/gsm;
            $args[$i] = $arg;
        }
    }

    my $current = $hash;
    my $current_path = '';
    while (@path)
    {
        my $next = shift (@path);
        $next = ($next =~ /:/) ? $hash->fetch ($next) : $next;

        my $has_path_tokens = scalar @path;
        my $has_args        = scalar @args;

        if (blessed $current)
        {
          ACCESS_OBJECT:
            goto ACCESS_HASH if ($current->isa('Petal::Hash'));

            if ($current->can ($next) or $current->can ('AUTOLOAD'))
            {
                if ($has_path_tokens) { $current = $current->$next ()      }
                else                  { $current = $current->$next (@args) }
            }
            else
            {
                goto ACCESS_HASH  if ((reftype($current) or '') eq 'HASH');
                goto ACCESS_ARRAY if ((reftype($current) or '') eq 'ARRAY');
                confess "Cannot invoke '$next' on '" . ref($current) .
                  "' object at '$current_path' - no such method (near $argument)";
            }
        }
        elsif (ref($current) eq 'HASH')
        {
          ACCESS_HASH:
          unless (ref($current->{$next}) eq 'CODE')
          {
            confess "Cannot access hash at '$current_path' with parameters (near $argument)"
                if ($has_args and not $has_path_tokens);
          }
            $current = $current->{$next};
        }
        elsif (ref($current) eq 'ARRAY')
        {
          ACCESS_ARRAY:
            # it might be an array, then the key has to be numerical...
            confess "Cannot access array at '$current_path' with non-integer index '$next' (near $argument)"
                unless ($next =~ /$INTEGER_KEY_RE/);

            confess "Cannot access array at '$current_path' with parameters (near $argument)"
                if ($has_args and not $has_path_tokens);

            $current = $current->[$next];
        }
        else
        {
            # ... or we cannot find the next value
            if ($Petal::ERROR_ON_UNDEF_VAR)
            {
                # let's croak and return
                my $warnstr = "Cannot find value for '$next' at '$current_path': $next cannot be retrieved\n";
                $warnstr   .= "(current value was ";
                $warnstr   .= (defined $current) ? "'$current'" : 'undef';
                $warnstr   .= ", near $argument)";
                confess $warnstr;
            }
            return '';
        }

        $current = (ref($current) eq 'CODE') ? $current->(@args) : $current;
        $current_path .= "/$next";
    }

    # return '' unless (defined $current);
    # $current = "$current" if (defined $current);
    return $$current if ref($current) eq 'SCALAR';
    return $current;
}


1;