RedC object class, v0.12

#!/usr/bin/perl
package RedC;
use strict;
#use warnings;
use utf8;
binmode $_=>':utf8' for *STDOUT,*STDERR;
use 5.16.1;

use Redis::Fast;
use CBOR::XS;
use Data::Dumper;
use Carp qw(confess);
use Exporter qw(import);
our @EXPORT_OK=qw(get_redc_by);

my %conoByName;
my %redisCanDoThis;
my $redTestObj=Redis::Fast->new('reconnect'=>3,'every'=>100_000);
my $cbor=CBOR::XS->new;

sub new {
    my ($class,$coName,$conIndex)=@_;
    $conIndex=0 unless defined $conIndex and $conIndex!~/[^\d]/;
    my %props=('name'=>$coName,'index'=>$conIndex);
    confess "$coName already used as Redis connector name" if $conoByName{$coName};
    if ($conIndex) {
        my $nDB=__databases($redTestObj);
        confess sprintf('Redis database index #%s is out of configured bounds (min=0, max=%d)',$conIndex,$nDB-1)
            if $conIndex>=$nDB;
    }
    my $redC=Redis::Fast->new(
        'reconnect'=>3,
        'every'=>100_000,
        $conIndex
            ? ('on_connect'=>sub {
                    $_[0]->select($conIndex);
              })
            : ()
    );

    my %props=('name'=>$coName,'index'=>$conIndex,'redc'=>\$redC);

    my $cono=bless sub {
        state $selfMethods={
            'me'    =>  sub {
                return \%props
            },
            'select'    =>  sub {
                confess 'Redis method "select" is prohibited for '.__PACKAGE__.' objects'
            },
            'write' =>  sub {
                my $cb=pop(@_) if ref $_[$#_] eq 'CODE';
                return unless @_;
                my $method=(@_>2?'m':'').'set';
                $redC->$method(
                    (map {
                        my ($k,$v)=(shift,shift);
                        $k=>ref($v)
                            ? $CBOR::XS::MAGIC.$cbor->encode($v)
                            : do { utf8::encode($v) if utf8::is_utf8($v); $v }
                    } 1..+(scalar(@_)>>1)),
                    $cb?($cb):()
                );
            },
            'read'  =>  sub {
                my $flRetHashRef=ref($_[0]) eq 'HASH'?do { shift; 1 }:undef;
                my $cb=pop(@_) if ref $_[$#_] eq 'CODE';
                return unless @_;
                my $method=($#_?'m':'').'get';
                my @k=@_;
                my $retv;
                $redC->$method(@k, sub {
                    if ( defined $_[1] ) {
                        if ($cb) {
                            $cb->(@_)
                        } else {
                            confess 'Redis error: '.$_[1]
                        }
                    }

                    $retv=[ map {
                        ( defined($_) and length($_)>3 and substr($_,0,3) eq $CBOR::XS::MAGIC )
                            ? $cbor->decode($_)
                            : do { utf8::decode($_); $_ }
                    } ref($_[0]) eq 'ARRAY'?@{$_[0]}:($_[0]) ];
                    $retv={(map {$k[$_]=>$retv->[$_]} 0..$#k)} if $flRetHashRef;
                    $cb->( $retv ) if $cb;
                });
                return 1 if $cb;
                $redC->wait_all_responses;
                return $retv;
            },
            'databases' =>  sub {
                __databases($redC);
            },
        };
        return unless my $method=shift;
        return if ref $method;
        return $selfMethods->{$_[0]} if $method eq 'hasMethod';
        if (my $hndl=$selfMethods->{$method}) {
            return $hndl->(@_)
        }
        $redC->$method(@_)
    }, (ref $class || $class);

    $conoByName{$coName}={'name'=>$coName,'index'=>$conIndex,'cono'=>$cono};
    return $cono;
}

sub __databases {
    my $r=shift;
    return unless ref($r)=~m/^Redis(?:::Fast)?$/;
    open my $fh, '<', $r->info->{'config_file'};
    ((local $/=<$fh>)=~m/(?:^|\n)\s*databases\s+(\d+)\s*(?:$|\n)/sm)[0];
}

sub get_redc_by {
    shift if ref $_[0] eq __PACKAGE__;
    my $byWhat=shift;
    return if ref $byWhat or !defined($byWhat);
    given ($byWhat) {
        return $conoByName{$byWhat}
            when 'name';
        return [grep {$_->{'index'}==$byWhat} values %conoByName]
            when 'index';
        default {
            confess 'No such connector object attribute: '.$byWhat
        }
    }
}

sub AUTOLOAD {
    our $AUTOLOAD;
    my $slf=shift;
    return unless my ($method)=$AUTOLOAD=~/::(\w+)$/;
    unless ($slf->('hasMethod', $method)) {
        unless ($redisCanDoThis{$method}) {
            eval { $redTestObj->$method() };
            confess 'Redis cant do <<'.$method.'>>' if $@ and index($@,'unknown command')>=0;
            $redisCanDoThis{$method}=1
        }
        my $redC=$slf->('me'){'redc'};
        no strict 'refs';
        *{$AUTOLOAD}=sub { ${$redC}->$method(@_) };
    } else {
        no strict 'refs';
        *{$AUTOLOAD}=sub { $slf->($method, @_) };
    }
    goto &{$AUTOLOAD};
}

sub DESTROY {
    my $iam=$_[0]->('me');
    delete $conoByName{$iam->{'name'}};
    undef ${$iam->{'redc'}};
}

1;