File Coverage

blib/lib/Attribute/TieClasses.pm

Criterion	Covered	Total	%
statement	229	461	49.6
branch	9	130	6.9
condition	1	3	33.3
subroutine	76	134	56.7
pod	5	62	8.0
total	320	790	40.5

use 5.008;
use warnings;
use strict;

package Attribute::TieClasses;
BEGIN {
  $Attribute::TieClasses::VERSION = '1.101700';
}

# ABSTRACT: Attribute wrappers for CPAN Tie classes
use Attribute::Handlers;
no warnings 'redefine';

# Define for each attribute which class to use for which type of
# attribute. I.e., one attribute can cause the referent to be tied
# to different classes depending on whether the referent is a scalar,
# an array etc.
# Each hash value can be a string or a reference to an array of strings.
our %tieclass = (
    __TEST => [
        qw/ SCALAR=Tie::Scalar::Test ARRAY=Tie::Array::Test
          HASH=Tie::Hash::Test /
    ],    # used for test.pl; ignore
    Alias        => 'HASH=Tie::AliasHash',
    Cache        => 'HASH=Tie::Cache',
    CharArray    => 'ARRAY=Tie::CharArray',
    Counter      => 'SCALAR=Tie::Counter',
    Cycle        => 'SCALAR=Tie::Cycle',
    DBI          => 'HASH=Tie::DBI',
    Decay        => 'SCALAR=Tie::Scalar::Decay',
    Defaults     => 'HASH=Tie::HashDefaults',
    Dict         => 'HASH=Tie::TieDict',
    Dir          => 'HASH=Tie::Dir',
    DirHandle    => 'HASH=Tie::DirHandle',
    Discovery    => 'HASH=Tie::Discovery',
    Dx           => 'HASH=Tie::DxHash',
    Encrypted    => 'HASH=Tie::EncryptedHash',
    FileLRU      => 'HASH=Tie::FileLRUCache',
    FlipFlop     => 'SCALAR=Tie::FlipFlop',
    IPAddrKeyed  => 'HASH=Tie::NetAddr::IP',
    Insensitive  => 'HASH=Tie::CPHash',
    Ix           => 'HASH=Tie::IxHash',
    LDAP         => 'HASH=Tie::LDAP',
    LRU          => 'HASH=Tie::Cache::LRU',
    ListKeyed    => 'HASH=Tie::ListKeyedHash',
    Math         => 'HASH=Tie::Math',
    Mmap         => 'ARRAY=Tie::MmapArray',
    NumRange     => 'SCALAR=Tie::NumRange',
    NumRangeWrap => 'SCALAR=Tie::NumRangeWrap=Tie::NumRange',
    Offset       => 'ARRAY=Tie::OffsetArray',
    Ordered      => 'HASH=Tie::LLHash',
    PackedInt    => 'ARRAY=Tie::IntegerArray',
    PerFH        => 'SCALAR=Tie::PerFH',
    Persistent   => 'HASH=Tie::Persistent',
    RDBM         => 'HASH=Tie::RDBM',
    Range        => 'HASH=Tie::RangeHash',
    Rank         => 'HASH=Tie::Hash::Rank',
    Ref          => 'HASH=Tie::RefHash',
    Regexp       => 'HASH=Tie::RegexpHash',
    Secure       => 'HASH=Tie::SecureHash',
    Sentient     => 'HASH=Tie::SentientHash',
    Shadow       => 'HASH=Tie::ShadowHash',
    Sort         => 'HASH=Tie::SortHash',
    Strict       => 'HASH=Tie::StrictHash',
    Substr       => 'HASH=Tie::SubstrHash',
    TextDir      => 'HASH=Tie::TextDir',
    Timeout      => 'SCALAR=Tie::Scalar::Timeout',
    Toggle       => 'SCALAR=Tie::Toggle',
    Transact     => 'HASH=Tie::TransactHash',
    TwoLevel     => 'HASH=Tie::TwoLevelHash',
    Vec          => 'ARRAY=Tie::VecArray',
    WarnGlobal   => 'SCALAR=Tie::WarnGlobal::Scalar',
);

# Define synonyms for each attribute. Each synonym creates another handler,
# so use them sparingly.
# Each hash value can be a string or a reference to an array of strings.
our %synonyms = (
    Alias  => 'Aliased',
    Range  => 'RangeKeyed',
    Rank   => 'Ranked',
    Regexp => 'RegexpKeyed',
    Shadow => 'Shadowed',
    Sort   => 'Sorted',
    Substr => 'Fixed',
    Vec    => 'Vector',
);

# create a handler sub for each attribute definition and each synonym of same
for my $attr (keys %tieclass) {
    my $attrdef = $tieclass{$attr};
    $attrdef = [$attrdef] unless ref $attrdef eq 'ARRAY';
    for my $def (@$attrdef) {
        my ($reftype, $tieclass, $filename) = split /=/, $def;
        $filename ||= $tieclass;
        my $syns = defined $synonyms{$attr} ? $synonyms{$attr} : [];
        $syns = [$syns] unless ref $syns eq 'ARRAY';
        make_handler($_, $reftype, $tieclass, $filename) for $attr, @$syns;
    }
}

# generate and eval the handler code
sub make_handler {
    my ($attr, $reftype, $tieclass, $filename) = @_;
    $filename ||= $tieclass;    # might be several classes in one file
    my $code = qq!
        sub UNIVERSAL::$attr : ATTR($reftype) {
        my (\$ref, \$data) = \@_[2,4];
        \$data = [ \$data ] unless ref \$data eq 'ARRAY';
        eval "use $filename; 1";
    !;
    if    ($reftype eq 'SCALAR') { $code .= make_tie_scalar($tieclass) }
    elsif ($reftype eq 'ARRAY')  { $code .= make_tie_array($tieclass) }
    elsif ($reftype eq 'HASH')   { $code .= make_tie_hash($tieclass) }
    elsif ($reftype eq 'VAR')    { $code .= make_tie_var($tieclass) }
    else                         { die "unknown attribute type $reftype" }
    $code .= "\n} 1\n";
    eval $code or die "Internal error: $@";
}

# subs to generate the variant parts of the attr handler code
sub make_tie_scalar { "tie \$\$ref, '$_[0]', \@\$data\n" }
sub make_tie_array  { "tie \@\$ref, '$_[0]', \@\$data\n" }
sub make_tie_hash   { "tie \%\$ref, '$_[0]', \@\$data\n" }

sub make_tie_var {
    my $tieclass = shift;
    return qq{
        my \$type = ref \$ref;
         (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',\@\$data
        :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',\@\$data
        :(\$type eq 'HASH')  ? tie \%\$ref,'$tieclass',\@\$data
        : die "Internal error: can't autotie \$type"
    }
}
1;


__END__