view release on metacpan or  search on metacpan

lib/Tie/Redis/Attribute.pm  view on Meta::CPAN

package Tie::Redis::Attribute;
{
  $Tie::Redis::Attribute::VERSION = '0.26';
}
# ABSTRACT: Variable attribute based interface to Tie::Redis

use 5.010001; # >= 5.10.1
use strict;
use warnings;

use Attribute::Handlers;
use Tie::Redis;
use PadWalker qw(var_name);

no warnings 'redefine';

sub import {
  my($class) = @_;
  my $pkg = caller;
  eval qq{
    sub ${pkg}::Redis :ATTR(VAR) {
      unshift \@_, \$class;
      goto &_do_tie;
    }
    1
  } or die;
}

sub _do_tie {
  my($class, $ref, $data) = @_[0, 3, 5];
  return if tied $ref; # Already applied

  if($data && !ref $data) {
    # Attribute::Handlers couldn't make into perl, warn rather than do
    # something surprising.
    require Carp;
    Carp::croak "Invalid attribute";
  }

  my $type = ref $ref;
  my %args = ref $data ? @$data : ();

  if(!exists $args{key}) {
    my $sigil = {
      ARRAY => '@',
      HASH  => '%'
    }->{$type};

    # Find where we were actually called from, ignoring attributes and
    # Attribute::Handlers.
    my $c = 1;
    $c++ while((caller $c)[3] =~ /^(?:attributes|Attribute::Handlers)::/);

    # The first part of the key is either the name of the subroutine if this is
    # within sub scope else the package name.
    my $pkg = (caller $c+1)[0];
    my $sub = (caller $c+1)[3] || $pkg;

    # Now we want a unique name for it
    my $name = var_name($c, $ref);

    if(!$name) {
      # Maybe package variable?
      no strict 'refs';
      for my $glob(values %{"${pkg}::"}) {
        next unless ref \$glob eq 'GLOB';
        if(*$glob{$type} && *$glob{$type} == $ref) {
          $name = $sigil . ($glob =~ /::([^:]+)$/)[0];
        }
      }
    }

    if(!$name) {