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


line stmt bran cond sub pod time code
1             # ------------------------------------------------------------------
2             # Petal::Hash::Var - Evaluates an expression and returns the result.
3             # ------------------------------------------------------------------
4             # Author: Jean-Michel Hiver
5             # This module is redistributed under the same license as Perl
6             # itself.
7             # ------------------------------------------------------------------
8             package Petal::Hash::Var;
9              
10 77     77   494 use strict;
  77         145  
  77         2172  
11 77     77   375 use warnings;
  77         117  
  77         2220  
12              
13 77     77   399 use Carp;
  77         172  
  77         4608  
14 77     77   503 use Scalar::Util qw( blessed reftype );
  77         149  
  77         83076  
15              
16              
17             our $STRING_RE_DOUBLE = qr/(?
18             our $STRING_RE_SINGLE = qr/(?
19             our $STRING_RE = qr/(?:$STRING_RE_SINGLE|$STRING_RE_DOUBLE)/;
20             our $VARIABLE_RE = qr/(?:--)?[A-Za-z\_][^ \t]*/;
21             our $PARAM_PREFIX_RE = qr/^--/;
22             our $ESCAPED_CHAR_RE = qr/(?sm:\\(.))/;
23             our $BEGIN_QUOTE_RE = qr/^\"|\'/;
24             our $END_QUOTE_RE = qr/\"|\'$/;
25             our $TOKEN_RE = qr/(?:$STRING_RE|$VARIABLE_RE)/;
26             our $PATH_SEPARATOR_RE = qr/(?:\/|\.)/;
27             our $INTEGER_KEY_RE = qr/^\d+$/;
28              
29              
30             sub process
31             {
32 652     652 0 887 my $class = shift;
33 652         710 my $hash = shift;
34 652         690 my $argument = shift;
35              
36 652         5661 my @tokens = $argument =~ /($TOKEN_RE)/gsm;
37 652 50       1687 my $path = shift (@tokens) or confess "bad syntax for $class: $argument (\$path)";
38 652         3005 my @path = split( /$PATH_SEPARATOR_RE/, $path );
39 652         1037 my @args = @tokens;
40              
41             # replace variable names by their value
42 652         1530 for (my $i=0; $i < @args; $i++)
43             {
44 53         87 my $arg = $args[$i];
45 53 100       438 if ($arg =~ /^$VARIABLE_RE$/)
46             {
47 31         93 $arg =~ s/$ESCAPED_CHAR_RE/$1/gsm;
48 31 100       89 if ($arg =~ $PARAM_PREFIX_RE)
49             {
50 8         34 $arg =~ s/$PARAM_PREFIX_RE//;
51 8         29 $args[$i] = $arg;
52             }
53             else
54             {
55 23         75 $args[$i] = $hash->fetch ($arg);
56             }
57             }
58             else
59             {
60 22         100 $arg =~ s/$BEGIN_QUOTE_RE//;
61 22         108 $arg =~ s/$END_QUOTE_RE//;
62 22         56 $arg =~ s/$ESCAPED_CHAR_RE/$1/gsm;
63 22         66 $args[$i] = $arg;
64             }
65             }
66              
67 652         844 my $current = $hash;
68 652         817 my $current_path = '';
69 652         1138 while (@path)
70             {
71 789         1019 my $next = shift (@path);
72 789 100       1552 $next = ($next =~ /:/) ? $hash->fetch ($next) : $next;
73              
74 789         1098 my $has_path_tokens = scalar @path;
75 789         851 my $has_args = scalar @args;
76              
77 789 100       2236 if (blessed $current)
    100          
    50          
78             {
79 726 100       4681 ACCESS_OBJECT:
80             goto ACCESS_HASH if ($current->isa('Petal::Hash'));
81              
82 74 100 66     339 if ($current->can ($next) or $current->can ('AUTOLOAD'))
83             {
84 58 100       97 if ($has_path_tokens) { $current = $current->$next () }
  8         25  
85 50         155 else { $current = $current->$next (@args) }
86             }
87             else
88             {
89 16 100 50     114 goto ACCESS_HASH if ((reftype($current) or '') eq 'HASH');
90 1 50 50     20 goto ACCESS_ARRAY if ((reftype($current) or '') eq 'ARRAY');
91 0         0 confess "Cannot invoke '$next' on '" . ref($current) .
92             "' object at '$current_path' - no such method (near $argument)";
93             }
94             }
95             elsif (ref($current) eq 'HASH')
96             {
97             ACCESS_HASH:
98 722 100       1909 unless (ref($current->{$next}) eq 'CODE')
99             {
100 721 50 66     1541 confess "Cannot access hash at '$current_path' with parameters (near $argument)"
101             if ($has_args and not $has_path_tokens);
102             }
103 722         994 $current = $current->{$next};
104             }
105             elsif (ref($current) eq 'ARRAY')
106             {
107 1 50       7 ACCESS_ARRAY:
108             # it might be an array, then the key has to be numerical...
109             confess "Cannot access array at '$current_path' with non-integer index '$next' (near $argument)"
110             unless ($next =~ /$INTEGER_KEY_RE/);
111              
112 1 50 33     4 confess "Cannot access array at '$current_path' with parameters (near $argument)"
113             if ($has_args and not $has_path_tokens);
114              
115 1         4 $current = $current->[$next];
116             }
117             else
118             {
119             # ... or we cannot find the next value
120 8 50       30 if ($Petal::ERROR_ON_UNDEF_VAR)
121             {
122             # let's croak and return
123 8         33 my $warnstr = "Cannot find value for '$next' at '$current_path': $next cannot be retrieved\n";
124 8         19 $warnstr .= "(current value was ";
125 8 50       27 $warnstr .= (defined $current) ? "'$current'" : 'undef';
126 8         21 $warnstr .= ", near $argument)";
127 8         1717 confess $warnstr;
128             }
129 0         0 return '';
130             }
131              
132 781 100       19665 $current = (ref($current) eq 'CODE') ? $current->(@args) : $current;
133 781         2068 $current_path .= "/$next";
134             }
135              
136             # return '' unless (defined $current);
137             # $current = "$current" if (defined $current);
138 644 50       1096 return $$current if ref($current) eq 'SCALAR';
139 644         2080 return $current;
140             }
141              
142              
143             1;
144              
145              
146              
147              
148              
149              
150              
151              
152              
153