File Coverage

blib/lib/Tie/Redis/Attribute.pm

Criterion	Covered	Total	%
statement	30	67	44.7
branch	1	24	4.1
condition	0	16	0.0
subroutine	11	14	78.5
pod	1	1	100.0
total	43	122	35.2

package Tie::Redis::Attribute;
BEGIN {
  $Tie::Redis::Attribute::VERSION = '0.22_1';
}
# 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) {
      require Carp;
      local $Carp::CarpLevel = $c;
      Carp::croak "Can't automatically work out a name";
    }

    if($pkg eq 'main') {
      # DWIM..., hopefully not *too* magical
      ($pkg) = $0 =~ m{(?:^|/)([^/]+)$};
      $sub =~ s/^main(::|$)/${pkg}$1/;
    }
    $args{key} = "autoattr:${sub}::${name}";
  }

  if($type eq 'HASH') {
    tie %$ref, "Tie::Redis::" . ucfirst lc $type,
      redis => $class->server(%args), %args;
  } elsif($type eq 'ARRAY') {
    tie @$ref, "Tie::Redis::" . ucfirst lc $type,
      redis => $class->server(%args), %args;
  } else {
    die "Only hashes and arrays are supported";
  }
}

sub server {
  my($class, %args) = @_;
  state %server;

  $server{($args{host}||"") . ":" . ($args{port}||"")}
    ||= Tie::Redis->new(%args);
}

1;



=pod

=head1 NAME

Tie::Redis::Attribute - Variable attribute based interface to Tie::Redis

=head1 VERSION

version 0.22_1

=head1 SYNOPSIS

  use Tie::Redis::Attribute;

  my %hash : Redis; # %hash now magically resides in a redis instance

=head1 DESCRIPTION

This is an B module that implements attribute based tying for
Redis.

Currently tying of arrays or hashes is supported.

=head1 OPTIONS

Options may be specified using perl list syntax within the C
attribute.

However note that L cannot use lexical variables, so C
Redis(host => $host)> will unfortunately not work if C<$host> is lexical.

=over 4

=item * key

The key to use, if this isn't provided a key is invented based on the package
name and variable name. This means for some simple purposes you may not need to
specify a key.

For example:

  our @queue : Redis(key => "my-queue");

=back

Other options are as per L's constructor (prefix) and
L (host, port, encoding).

=head1 METHODS

=head2 server

You may subclass this and define a C method that returns an instance of
L. Due to the I nature of attributes it is recommended to
B define an C method in your subclass other than the one provided
by this class.

=head1 SEE ALSO

L, L, L.

=head1 AUTHOR

David Leadbeater

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011 by David Leadbeater.

This is free software; you can redistribute it and/or modify it under
the terms of the Beerware license.

=cut


__END__