File Coverage

blib/lib/Dancer/Config/Object.pm

Criterion	Covered	Total	%
statement	57	58	98.2
branch	12	16	75.0
condition			n/a
subroutine	13	13	100.0
pod	0	1	0.0
total	82	88	93.1

package Dancer::Config::Object;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: Access the config via methods instead of hashrefs
$Dancer::Config::Object::VERSION = '1.3521';
use strict;
use warnings;

use base 'Exporter';
use Carp 'croak';
use Dancer::Exception qw(:all);
use Scalar::Util 'blessed';

register_exception('BadConfigMethod',
    message_pattern =>
      qq{Can't locate config attribute "%s".\nAvailable attributes: %s});

our @EXPORT_OK = qw(hashref_to_object);

{
    my $index = 1;

    sub hashref_to_object {
        my ($hashref) = @_;
        my $class = __PACKAGE__;
        my $target = "${class}::__ANON__$index";
        $index++;
        if ('HASH' ne ref $hashref) {
            if ( blessed $hashref ) {
                # we have already converted this to an object. This can happen
                # in cases where Dancer::Config->load is called more than
                # once.
                return $hashref;
            }
            else {
                # should never happen
                raise 'Core::Config' => "Argument to $class must be a hashref";
            }
        }
        my $object = bless $hashref => $target;
        _add_methods($object);

        return $object;
    }
}


sub _add_methods {
    my ($object) = @_;
    my $target = ref $object;

    foreach my $key ( keys %$object ) {
        my $value = $object->{$key};
        if ( 'HASH' eq ref $value ) {
            $value = hashref_to_object($value);
        }
        elsif ( 'ARRAY' eq ref $value ) {
            foreach (@$value) {
                $_ = 'HASH' eq ref($_) ? hashref_to_object($_) : $_;
            }
        }

        # match a (more or less) valid identifier
        next unless $key =~ qr/^[[:alpha:]_][[:word:]]*$/;
        my $method = "${target}::$key";
        no strict 'refs';
        *$method = sub {$value};
    }
    _setup_bad_method_trap($target);
}

# AUTOLOAD will only be called if a non-existent method is called. It's used
# to generate the list of available methods. It's slow, but we're going to
# die. Who wants to die quickly?
sub _setup_bad_method_trap {
    my ($target) = @_;
    no strict;    ## no critic (ProhibitNoStrict)
    *{"${target}::AUTOLOAD"} = sub {
        $AUTOLOAD =~ /.*::(.*)$/;

        # should never happen
        my $bad_method = $1    ## no critic (ProhibitCaptureWithoutTest)
          or croak "Could not determine method called via $AUTOLOAD";
        return if 'DESTROY' eq $bad_method;
        my $symbol_table = "${target}::";

        # In these fake classes, we only have methods
        my $methods =
          join ', ' => grep { !/^(?:AUTOLOAD|DESTROY|$bad_method)$/ }
          sort keys %$symbol_table;
        raise BadConfigMethod => $bad_method, $methods;
    };
}

1;

__END__