1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
# ------------------------------------------------------------------
# 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 UNIVERSAL qw( isa );
use Scalar::Util qw( blessed );
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 (isa ($current, '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 (isa ($current, 'HASH'));
goto ACCESS_ARRAY if (isa ($current, 'ARRAY'));
confess "Cannot invoke '$next' on '" . ref($current) .
"' object at '$current_path' - no such method (near $argument)";
}
}
elsif (isa ($current, 'HASH'))
{
ACCESS_HASH:
unless (isa $current->{$next}, 'CODE')
{
confess "Cannot access hash at '$current_path' with parameters (near $argument)"
if ($has_args and not $has_path_tokens);
}
$current = $current->{$next};
}
elsif (isa ($current, '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 = (isa ($current, 'CODE')) ? $current->(@args) : $current;
$current_path .= "/$next";
}
# return '' unless (defined $current);
# $current = "$current" if (defined $current);
return $$current if isa($current, 'SCALAR');
return $current;
}
1;
|
