File Coverage

blib/lib/Config/PlConfig/DotScheme.pm

Criterion	Covered	Total	%
statement	24	78	30.7
branch	0	10	0.0
condition	0	6	0.0
subroutine	8	15	53.3
pod	0	7	0.0
total	32	116	27.5

# $Id$
# $Source$
# $Author$
# $HeadURL$
# $Revision$
# $Date$
package Config::PlConfig::DotScheme;

use warnings;
use strict;
use 5.006001;
use version; our $VERSION = qv('0.1_02');
{

    use Carp;
    use Class::Dot qw(-new property isa_String isa_Object);
    use Params::Util qw(_CODELIKE);
    use English qw( -no_match_vars );

    property plconfig => isa_Object('Config::PlConfig');
    property dumper   => isa_String('JSON');

    my $GLOBAL_AUTOSAVE = 0;

    my %DUMPER = (
        'YAML' => sub {
            require YAML::Syck;
            return YAML::Syck::Dump(@_);
        },
        'XML' => sub {
            require XML::Simple;
            return XML::Simple::XMLout(@_);
        },
        'JSON' => sub {
            require JSON::Syck;
            return JSON::Syck::Dump(@_);
        },
    );

    sub write_key {
        my ( $self, $key, $setvalue ) = @_;
        my $plconfig = $self->plconfig;
        my $config   = $plconfig->config;
        return if !$key || !$setvalue;

        my $statement = $self->dotscheme_to_perlvar($key);

        # Try to check if the string evals,
        # if it does it's a valid perl statement,
        # everything else is quoted with power-quotes (')
        eval $setvalue; ## no critic
        if ($EVAL_ERROR) {
            $setvalue = qq{'$setvalue'};
        }

        # try the statement with a temp variable first.
        # so we're sure it doesn't fuck up something.
        $self->eval_string(qq{
                my \$tmpvar = $setvalue;
        });

        # then try the real operation
        $self->eval_string(qq{
                $statement = $setvalue;
        });

        $plconfig->save;

        return 1;
    }

    sub read_keys {
        my ($self, $key) = @_;
        my $plconfig = $self->plconfig;
        my $config   = $plconfig->config;

        if ( defined $key ) {
            print "KEY HOOPA\n";
            my $statement = $self->dotscheme_to_perlvar($key);
            my $value;
            eval qq{ \$value = $statement }; ## no critic
            print "-----\n", qq{ \$value = $statement }, "\n----\n";

            return $self->dump_structure( { $key => $value } );
        }

        return $self->dump_structure($config);

    }

    sub rename_key {
        my ( $self, $domain, $key_from, $key_to ) = @_;
        my $plconfig = $self->plconfig;
        my $config   = $plconfig->config;
        return if !$key_from || !$key_to;

        my $from_stmt = $self->dotscheme_to_perlvar($key_from);
        my $to_stmt   = $self->dotscheme_to_perlvar($key_to);

        $self->eval_string(
          qq{ my \$tmp = $from_stmt; $to_stmt = \$tmp; delete $from_stmt}
        );

        $plconfig->save;

        return 1;
    }

    sub delete_key {
        my ( $self, $domain, $key ) = @_;
        my $plconfig = $self->plconfig;
        my $config   = $plconfig->config;
        return if !$key;

        my $key_stmt = $self->dotscheme_to_perlvar($key);

        $self->eval_string(qq{ delete $key_stmt });

        $plconfig->save;

        return 1;
    }

    sub eval_string {
        my ($self, $perl_code) = @_;
        my $plconfig = $self->plconfig;
        my $config   = $plconfig->config;
        eval $perl_code;    ## no critic
        return $EVAL_ERROR;
    }

    sub dump_structure {
        my ($self, $data_ref) = @_;
        my $curdumper         = $self->dumper;

        return $DUMPER{$curdumper}->($data_ref);
    }

    sub dotscheme_to_perlvar {
        my ( $self, $key ) = @_;

        my @keys = split m/\.|\-\>/xms, $key;
        my $statement = q{$} . 'config->';
        $statement .= join q{}, map {"{'$_'}"} @keys;

        return $statement;
    }

}

1;    # Magic true value required at end of module
__END__