File Coverage

lib/Petal/Hash.pm

Criterion	Covered	Total	%
statement	84	89	94.3
branch	19	22	86.3
condition	9	15	60.0
subroutine	18	19	94.7
pod	0	5	0.0
total	130	150	86.6

package Petal::Hash;
use strict;
use warnings;
use Carp;

our $MODIFIERS = {};

# import all plugins once
foreach my $include_dir (@INC)
{
    my $dir = "$include_dir/Petal/Hash";
    if (-e $dir and -d $dir)
    {
	opendir DD, $dir or do {
	    warn "Cannot open directory $dir. Reason: $!";
	    next;
	};

	my @modules = map { s/\.pm$//; $_ }
	              grep /\.pm$/,
		      grep !/^\./,
		      readdir (DD);

	closedir DD;

	foreach my $module (@modules)
	{
		$module =~ /^(\w+)$/;
		$module = $1;
		eval "use Petal::Hash::$module";
	    $@ and warn "Cannot import module $module. Reason: $@";
	    $MODIFIERS->{lc ($module) . ':'} = "Petal::Hash::$module";
	}
    }
}


# set modifier
$MODIFIERS->{'set:'} = sub {
    my $hash  = shift;
    my $argument = shift;
    my @split = split /\s+/, $argument;
    my $set   = shift (@split) or confess "bad syntax for 'set:': $argument (\$set)";
    my $value = $hash->fetch (join ' ', @split);
    $hash->{$set} = $value;
    delete $hash->{__petal_hash_cache__}->{$set};
    return '';
};
$MODIFIERS->{'def:'}    = $MODIFIERS->{'set:'};
$MODIFIERS->{'define:'} = $MODIFIERS->{'set:'};


# true modifier
$MODIFIERS->{'true:'} = sub {
    my $hash = shift;
    my $variable = $hash->fetch (@_);
    return unless (defined $variable);

    (scalar @{$variable}) ? return 1 : return
        if (ref $variable eq 'ARRAY' or (ref $variable and $variable =~ /=ARRAY\(/));

    ($variable) ? return 1 : return;
};


# false modifier
$MODIFIERS->{'false:'} = sub {
    my $hash = shift;
    my $variable = join ' ', @_;
    return not $hash->fetch ("true:$variable");
};

$MODIFIERS->{'not:'} = $MODIFIERS->{'false:'};

# encode: modifier (deprecated stuff)
$MODIFIERS->{'encode:'} = sub {
    warn "Petal modifier encode: is deprecated";
    my $hash = shift;
    my $argument = shift;
    return $hash->fetch ($argument);
};
$MODIFIERS->{'xml:'}         = $MODIFIERS->{'encode:'};
$MODIFIERS->{'html:'}        = $MODIFIERS->{'encode:'};
$MODIFIERS->{'encode_html:'} = $MODIFIERS->{'encode:'};


# Instanciates a new Petal::Hash object which should
# be tied to a hash.
sub new
{
    my $thing = shift;
    my $self  = (ref $thing) ?
        bless { %{$thing} }, ref $thing :
	bless { @_ }, $thing;

    $self->{__petal_hash_cache__}  = {};
    return $self;
}


# Gets a value...
sub get
{
    my $self   = shift;
    my $key    = shift;
    my $fresh  = $key =~ s/^\s*fresh\s+//;
    delete $self->{__petal_hash_cache__}->{$key} if ($fresh);
    exists $self->{__petal_hash_cache__}->{$key} and return $self->{__petal_hash_cache__}->{$key};

    my $res = undef;
    if ($Petal::HTML_ERRORS)
    {
        $res = eval { $self->__FETCH ($key) };
        $@ and return "[ Cannot fetch $key.  ]";
    }
    else
    {
        $res = $self->__FETCH ($key);
    }

    $self->{__petal_hash_cache__}->{$key} = $res;
    return $res;
}


sub get_encoded
{
    my $self = shift;
    my $key  = shift;
    my $res  = $self->get ($key);
    return unless (defined $res);

    my $no_encode = $key =~ s/^\s*structure\s+//;
    unless ($no_encode and $no_encode)
    {
        $res =~ s/\&/\&/g;
        $res =~ s/\
        $res =~ s/\"/\"/g;
    }

    return $res;
}


sub delete_cached
{
    my $self  = shift;
    my $regex = shift;
    for (keys %{$self->{__petal_hash_cache__}})
    {
	/$regex/ and delete $self->{__petal_hash_cache__}->{$_};
    }
}


sub __FETCH
{
    my $self = shift;
    my $key  = shift;
    my $no_encode = $key =~ s/^\s*structure\s+//;
    if (defined $no_encode and $no_encode)
    {
	return $self->fetch ($key);
    }
    else
    {
        # can anyone explain why keys beginning with 'text' are not allowed???
	$key =~ s/^\s*text\s*//;
	return $self->fetch ($key);
    }
}


# this method fetches a Petal expression and returns it
# without XML encoding. FETCH is basically a wrapper around
# fetch() which looks for the special keyword 'structure'.
sub fetch
{
    my $self = shift;
    my $key  = shift;

    my $mod  = $self->_fetch_mod ($key);
    $key =~ s/^\Q$mod\E//;
    $key =~ s/^\s+//;

    my $module = $MODIFIERS->{$mod} || confess "$mod is not a known modifier";
    (defined $module and ref $module and ref $module eq 'CODE') and return $module->($self, $key);
    $module->process ($self, $key);
}


sub _fetch_mod
{
    my $self  = shift;
    my $key   = shift;
    my ($mod) = $key =~ /^([A-Za-z0-9_-]+?\:).*/;
    defined $mod || return 'var:';
    return $mod;
}


1;


__END__