File Coverage

blib/lib/Cache/Keys/DSL.pm

Criterion	Covered	Total	%
statement	80	81	98.7
branch	8	8	100.0
condition	1	2	50.0
subroutine	17	18	94.4
pod			n/a
total	106	109	97.2

package Cache::Keys::DSL;
use 5.008001;
use strict;
use warnings;

our $VERSION = "0.01";

use Exporter 5.57 ();

sub import {
    my ($class, %args) = @_;
    my $caller = caller;

    my $base_version = $args{base_version};

    my %export;
    $export{key}    = _key($base_version);
    $export{keygen} = _keygen($base_version);
    for my $name (keys %export) {
        my $code = $export{$name};

        no strict qw/refs/;
        *{"${caller}::${name}"} = $code;
    }

    no strict qw/refs/;
    no warnings qw/once/;
    *{"${caller}::with_version"} = \&_with_version;
    @{"${caller}::EXPORT_OK"}    = ();
    %{"${caller}::EXPORT_TAGS"}  = (all => \@{"${caller}::EXPORT_OK"});
    @{"${caller}::import"}       = Exporter->can('import');
}

sub _with_version($$) {## no critic
    my $name    = shift;
    my $version = shift;
    return [$name, $version];
}

sub _key {
    my $base_version = shift;
    return sub ($) { ## no critic
        my $name = shift;

        my @versions;
        ($name, @versions) = @$name  if ref $name eq 'ARRAY';
        unshift @versions => $base_version if defined $base_version;

        my $caller  = caller;
        my $subname = "key_for_$name";
        my $value   = join '_', $name, @versions;
        my $code    = sub () { $value }; ## no critic
        {
            no strict 'refs'; ## no critic
            *{"${caller}::${subname}"}  = $code;
            push @{"${caller}::EXPORT_OK"} => $subname;
        }
    };
}

sub _keygen {
    my $base_version = shift;
    return sub ($;&) { ## no critic
        my ($name, $generator) = @_;
        $generator ||= sub { @_ };

        my @versions;
        ($name, @versions) = @$name  if ref $name eq 'ARRAY';
        unshift @versions => $base_version if defined $base_version;

        my $caller  = caller;
        my $subname = "gen_key_for_$name";
        my $code    = sub { join '_', $name, @versions, $generator->(@_) };
        {
            no strict 'refs'; ## no critic
            *{"${caller}::${subname}"}  = $code;
            push @{"${caller}::EXPORT_OK"} => $subname;
        }
    };
}

1;
__END__