/usr/share/perl5/Petal/Hash/Var.pm is in libpetal-perl 2.20-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | # ------------------------------------------------------------------
# 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;
|