libpetal-perl 2.23-1 / usr / share / perl5 / Petal / Hash / Var.pm

# ------------------------------------------------------------------
# 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;