File Coverage

blib/lib/Config/apiLayers.pm

Criterion	Covered	Total	%
statement	173	234	73.9
branch	54	102	52.9
condition	35	58	60.3
subroutine	19	25	76.0
pod	7	7	100.0
total	288	426	67.6

package Config::apiLayers;

use strict;
use warnings;
use Symbol qw{ qualify_to_ref };

BEGIN {
    use vars    qw($VERSION $LASTMOD $DEBUG $CXLCFG $CXLDATA);
    $VERSION    = '0.11';
    $LASTMOD    = 20160329;
    $DEBUG      = 0;
    $CXLCFG     = '_cxl_cfg';
    $CXLDATA    = '_cxl_data';
}

sub _api_factory ($;$) {
    my $self        = shift;
    my $apiname     = shift;
    my $validator   = shift || undef;

    my $f_validator = sub ($;$) {
        my $self        = shift;
        my $name        = shift;
        my $validator   = shift;
        my $value       = shift;
        if (!defined $validator) {
            return $value;
        }
        elsif (ref $validator eq "CODE") {
            return $validator->($self,$name,$value);
        }
        elsif (!ref $validator) {
            return $value if $value =~ /$validator/;
            return undef;
        }
    };

    # The method for setting/getting the attribute's value
    warn "Creating Getter/Setter for $apiname called.\n" if $self->{'DEBUG'};

    return sub {
        my $name    = $apiname;
        warn "Getter/Setter for $name called.\n" if $self->{'DEBUG'};
        my $self    = shift;
        my $value   = shift || undef;

        if (defined $value) {

            if (my $valid = $f_validator->($self,$name,$validator,$value)) {
                #return $self->config({ 'data' => { $name => $valid } });
                $self->config({ 'data' => { $name => $valid } });
                return 1;
            } else {
                return undef;
            }

        } else {

    # In the future, we'll do more here
    my $paramedic = sub {
        my $value = shift;
        if (ref $value eq "CODE") {
            return $value->($self);
        } else {
            return $value;
        }
    };

    foreach my $layer (reverse @{$self->{$CXLDATA}}) {
        if (exists $layer->{$name}) {
            return $paramedic->($layer->{$name});
        }
    }

    return undef;

        }
    };
}

sub _api_define ($;$) {
    my $self        = shift;
    my $apiname     = shift;
    my $function    = shift || return undef;

    # Qualifying symbols

    # This does not work in Perl 5.12 and lower
    #my $ref = *{ Symbol::qualify_to_ref( $apiname ) };
    #*{ $ref } = $function;

    # This is verified to work in at least Perl 5.10.1 through 5.16.3
    #*{ Symbol::qualify_to_ref( $apiname ) } = $function;
    my $ref = Symbol::qualify_to_ref( $apiname );
    *{ $ref } = $function;

    return 1;
}

sub _api_undefine ($) {
    my $self         = shift;
    my $apiname      = shift;
    my $ref = *{ Symbol::qualify_to_ref( $apiname ) };
    *{ $ref } = undef;
}


# @attributes = [ a, b, c ];
# @attributes = [ { a => v1, b => v2, c => v3 } ]
# @attributes = [ { name => 'length', validator => \&func, getoptlong => 'length|l:i', description => 'long description' } ]
# @autoproto = 1|0 ; default is 1
sub new (;$) {
    my $pkg     = shift;
    my $args    = shift;
    my $class   = ref($pkg) || $pkg;
    my $self    = bless {},$class;

    my $autoproto = $args->{'autoproto'} || 1;

    my $attr_add = sub {
        my $attr_name   = shift;
        my $validator   = shift || undef;
        my $getoptlong  = shift || undef;
        my $description = shift || undef;
        push (@{$self->{$CXLCFG}->{'attributes'}}, $attr_name);
        $self->{$CXLCFG}->{'validators'}->{$attr_name}  = $validator if defined $validator;
        $self->{$CXLCFG}->{'getoptlong'}->{$attr_name}  = $getoptlong if defined $getoptlong;
        $self->{$CXLCFG}->{'description'}->{$attr_name} = $description if defined $description;
        my $attr_func   = $self->_api_factory($attr_name,$validator);
        warn "ERROR in creating function for $attr_name\n" if !defined $attr_func;
        $self->{$CXLCFG}->{'api'}->{$attr_name} = $attr_func;
        if ($autoproto == 1) {
            $self->_api_define($attr_name,$attr_func);
        }
    };
    my $attr_add_hash = sub {
        my $attr_hash = shift;
        if (exists $attr_hash->{'name'}) {
            my $name = $attr_hash->{'name'};
            my $validator = $attr_hash->{'validator'} || undef;
            my $getoptlong = $attr_hash->{'getoptlong'} || undef;
            my $description = $attr_hash->{'description'} || undef;
            $attr_add->($name, $validator, $getoptlong, $description);
        } else {
            foreach my $attr (keys %{$attr_hash}) {
                $attr_add->($attr, $attr_hash->{$attr});
            }
        }
    };
    if ((exists $args->{'attributes'}) && (ref $args->{'attributes'} eq "ARRAY")) {
        foreach my $attr (@{$args->{'attributes'}}) {
            if (ref $attr eq "HASH") {
                $attr_add_hash->($attr);
            } else {
                $attr_add->($attr);
            }
        }
    } elsif ((exists $args->{'attributes'}) && (ref $args->{'attributes'} eq "HASH")) {
        foreach my $attr_name (keys %{$args->{'attributes'}}) {
            $attr_add_hash->($attr_name);
        }
    }

    return $self;
}


# Set or retrieve a configuration layer, without validation.
# Set with @index and @data, or jusr @data for the last existing index
# Retrieve with only @index, or without index retrieve the last existing index
# @data
# @index
sub config ($) {
    my $self        = shift;
    my $args        = shift || {};
    my $lastLayer   = ref $self->{$CXLDATA} eq "ARRAY" ? (scalar @{$self->{$CXLDATA}} - 1) : 0;
    my $layer_idx   = exists $args->{'index'} ? $args->{'index'} : $lastLayer;
    if (! exists $args->{'data'}) {
        if (defined $self->{$CXLDATA}->[$layer_idx]) {
            return $self->{$CXLDATA}->[$layer_idx];
        } else {
            return undef;
        }
    }
    my $config      = $args->{'data'};
    my $attrs       = $self->{$CXLCFG}->{'attributes'};
    foreach my $key (keys %{$config}) {
        next unless grep {/^$key$/} @{$attrs};
        $self->{$CXLDATA}->[$layer_idx]->{$key} = $config->{$key};
    }
}

# Import the data, performing validation as available
# @data - the data to import
sub importdata ($) {
    my $self        = shift;
    my $args        = shift;
    my $attrs       = $self->{$CXLCFG}->{'attributes'};
    my $errors      = 0;
    if (exists $args->{'data'}) {
        foreach my $key (keys %{$args->{'data'}}) {
            next unless grep {/^$key$/} @{$attrs};
            unless ($self->apicall($key,$args->{'data'}->{$key})) {
                $errors++;
            }
        }
    }
    return 0 if $errors >= 1;
    return 1;
}

# Export the data
# @cfg - getoptlong|descriptions
# @data - undef|layerNumber|[startingLayer,endingLayer]
sub exportdata ($) {
    my $self        = shift;
    my $args        = shift;
    my $attrs       = $self->{$CXLCFG}->{'attributes'};
    if ((exists $args->{'cfg'}) && ($args->{'cfg'} eq "getoptlong")) {
        my $getoptlong  = [];
        foreach my $attr_name (@{$attrs}) {
            next unless defined $self->{$CXLCFG}->{'getoptlong'}->{$attr_name};
            push (@{$getoptlong}, $self->{$CXLCFG}->{'getoptlong'}->{$attr_name});
        }
        return $getoptlong;
    } elsif ((exists $args->{'cfg'}) && ($args->{'cfg'} eq "descriptions")) {
        my $description = [];
        foreach my $attr_name (@{$attrs}) {
            next unless defined $self->{$CXLCFG}->{'description'}->{$attr_name};
            push (@{$description}, $attr_name);
            push (@{$description}, $self->{$CXLCFG}->{'description'}->{$attr_name});
        }
        return $description;
    } elsif (exists $args->{'data'}) {
        my $firstLayer  = 0;
        my $lastLayer   = (scalar @{$self->{$CXLDATA}} - 1);
        if (    (defined $args->{'data'})
             && (!ref $args->{'data'})
             && ($args->{'data'} >= $firstLayer)
             && ($args->{'data'} <= $lastLayer)) {
            return $self->{$CXLDATA}->[$args->{'data'}];
        } elsif (ref $args->{'data'} eq "ARRAY") {
            $firstLayer = shift @{$args->{'data'}} || $firstLayer;
            $lastLayer  = pop @{$args->{'data'}} || $lastLayer;
        }
        my $export = {};
        foreach my $key (@{$attrs}) {
            for ($firstLayer..$lastLayer) {
                my $layer_idx = $_;
                next unless exists $self->{$CXLDATA}->[$layer_idx]->{$key};
                $export->{$key} = $self->{$CXLDATA}->[$layer_idx]->{$key};
            }
        }
        return $export if keys %{$export};
        return undef;
    }
}


# Add layers up to the given index, with or without data.
# Add a layer with @index and @data, or just @index, or add one more layer without @index
# Add more than one layer by providing the appropriate @index layer number.
# The @data is only set into the last layer.
# @index
# @data
sub add_layer($) {
    my $self        = shift;
    my $args        = shift || {};
    if (ref $self->{$CXLDATA} ne "ARRAY") {
        $self->{$CXLDATA} = [];
    }
    my $nextLayer   = scalar @{$self->{$CXLDATA}};
    my $layerNumber = exists $args->{'index'} ? $args->{'index'} : $nextLayer;

    for ($nextLayer..$layerNumber) {
        push( @{$self->{$CXLDATA}}, {} );
    }

    if (exists $args->{'data'}) {
        $self->config({ data => $args->{'data'} , index => $layerNumber });
    }

    return (scalar @{$self->{$CXLDATA}} - 1);
}

sub apican(;$) {
    my $self         = shift;
    my $attr_name    = shift || undef;
    if (defined $attr_name) {
        return $self->{$CXLCFG}->{'api'}->{$attr_name} if exists $self->{$CXLCFG}->{'api'}->{$attr_name};
        return undef;
    } else {
        return wantarray ? @{$self->{$CXLCFG}->{'attributes'}} : $self->{$CXLCFG}->{'attributes'};
    }
}

sub apicall(;$){
    my $self         = shift;
    my $attr_name    = shift || return undef;
    if (defined $attr_name) {
        my $subref = $self->apican($attr_name);
        unshift(@_,$self);
        #goto &$subref if defined $subref;
        $subref->(@_) if defined $subref;
    }
}


#
# Non-Object helper functions
# To be used inside the api functions
#

sub _mendPath(@) {
    my @path = @_;
    my $path;
    foreach my $p (@path) {
        next unless defined $p;
        if ($path =~ /.+\/$/) {
            chop($path);
        }
        while ($p =~ /.+\/\/$/) {
            chop($p);
        }
        if (!defined $path) {
            $path = $p;
        } else {
            $path = ($path.'/'.$p);
        }
    }
    return $path;
}

# _mendLastRootPath
# Given an array of items that may define one or more paths from root '/'
# return the last grouping of items that define one path from root
# ex: _mendLastRootPath(qw( /path to file /next path to dir))
# returns: '/next/path/to/dir'
# This is handy when the users input for a parameter can either be a full path
# from root, or a subpath of another parameter.
# In this case, this would be the resulting example:
#   # when $homedir = /home
#   # and $userhomedir = ( jsmith | /home/jsmith )
#   my $path = mendlastrootpath( $homedir, $userhomedir);
#   # $path eq '/home/jsmith'
sub _mendLastRootPath (@) {
    my $self    = shift;
    my @items   = @_;
    my @rootitems;
    foreach my $item (@items) {
        if ($item =~ /^\//) {
            @rootitems = ();
            push (@rootitems,$item);
        } else {
            push (@rootitems,$item);
        }
    }
    return $self->mendPath(@rootitems);
}

sub _dirFileSplit($) {
    my $path = shift;
    if (-d $path) {
        return ($path,undef);
    }
    my ($baseDir,$fileName) = $path =~ /^(.*\/)([^\/]*)$/;
    return @{[$baseDir,$fileName]};
}

sub _dirBase($) {
    my $path = shift;
    my ($baseDir,$fileName) = _DirFileSplit($path);
    $baseDir = './' unless defined $baseDir;
    return $baseDir;
}

sub _fileName($) {
    my $path = shift;
    my ($baseDir,$fileName) = _DirFileSplit($path);
    return $fileName;
}

1;
__END__