File Coverage

blib/lib/Attribute/Tie.pm

Criterion	Covered	Total	%
statement	44	44	100.0
branch	21	24	87.5
condition			n/a
subroutine	11	11	100.0
pod	1	4	25.0
total	77	83	92.7

package Attribute::Tie;
#
# $Id: Tie.pm,v 0.2 2009/02/08 09:00:12 dankogai Exp $
#
use 5.008001;
use strict;
use warnings;
use Attribute::Handlers;
our $VERSION = sprintf "%d.%02d", q$Revision: 0.2 $ =~ /(\d+)/g;

our %MOD2TIE;
our %SIGIL = qw/HASH % ARRAY @ SCALAR $/;
our $ERROR = \&error;

sub seterror {
    my $pkg = shift;
    $ERROR =
        ref $_[0] eq 'CODE' ? $_[0]
      : $_[0] ? \&error
      : sub { }
}

sub load {
    my ($mod2tie, $ref) = @_;
    return $MOD2TIE{$mod2tie} if $MOD2TIE{$mod2tie};
    {   # Maybe you don't need to load at all
	no strict 'refs';
	my $type =  ref $ref;
	return $MOD2TIE{$mod2tie} = $mod2tie
	    if defined &{$mod2tie . "::TIE$type" };
	return $MOD2TIE{$mod2tie} = 'Tie::'.$mod2tie
	    if defined &{'Tie::'. $mod2tie . "::TIE$type"};
    }
    # DB_File, et al.
    eval qq{ require $mod2tie };
    return $MOD2TIE{$mod2tie} = $mod2tie unless $@;

    # Anything else
    eval qq{ require Tie::$mod2tie };
    return $MOD2TIE{$mod2tie} = 'Tie::'.$mod2tie unless $@;

    # Report Failure and die
    my ( $pkg, $file, $line ) = caller(4);
    die "Neither $mod2tie nor Tie::$mod2tie is available",
      " at $file line $line\n";
}

sub error {
    my ( $ref, $mod2tie, @tiearg ) = @_;
    my ( $pkg, $file,    $line )   = caller(4);
    my $s = $SIGIL{ ref $ref };
    die "tie(", join( ", ", $s . ref $ref, qq('$mod2tie'), @tiearg ),
      ") failed : $! at $file line $line\n";
}

sub UNIVERSAL::Tie : ATTR {
    my ( $pkg, $sym, $ref, $attr, $data, $phase ) = @_;
    my @tiearg = ref $data ? @$data : ($data);
    my $mod2tie = Attribute::Tie::load(shift @tiearg, $ref);
    my $obj =
        ref $ref eq 'HASH'   ? tie %$ref, $mod2tie, @tiearg
      : ref $ref eq 'ARRAY'  ? tie @$ref, $mod2tie, @tiearg
      : ref $ref eq 'SCALAR' ? tie $$ref, $mod2tie, @tiearg
      :   die "cannot tie to data type: ", ref $ref;
    $Attribute::Tie::ERROR->( $ref, $mod2tie, @tiearg ) if !$obj;
}

1;
__END__