File Coverage

blib/lib/Attribute/Overload.pm

Criterion	Covered	Total	%
statement	37	38	97.3
branch	7	14	50.0
condition	1	3	33.3
subroutine	8	8	100.0
pod	0	1	0.0
total	53	64	82.8

use 5.008;
use warnings;
use strict;

package Attribute::Overload;
our $VERSION = '1.100710';
# ABSTRACT: Attribute that makes overloading easier

use Attribute::Handlers;

# RAWDATA to get '""' as such;
# CODE would interpret it as empty string and return nothing
sub UNIVERSAL::Overload : ATTR(CODE,RAWDATA) {
    my ($pkg, $symbol, $data) = @_[ 0, 1, 4 ];
    our %overload;
    for (ref $data eq 'ARRAY' ? @$data : $data) {
        die "Too late to overload constant $_ in CHECK for $symbol\n"
          if /^(integer|float|binary|qr?)$/;
        s!\"\"!""!g;
        $overload{$pkg}{$_} = *{$symbol}{NAME};
    }
}

sub INIT {

    # only eval here, because multiple overloaded subs must only
    # trigger one 'use overload' statement
    our %overload;
    my $code;
    while (my ($pkg, $pkgdef) = each %overload) {
        my (@code, @constcode);
        while (my ($op, $sub) = each %$pkgdef) {
            if ($op =~ /^(integer|float|binary|qr?)$/) {
                push @constcode => "$op => \\&$sub";
            } else {
                push @code => "'$op' => \\&$sub";
            }
        }
        next unless @code || @constcode;    # huh? no defs?
        $code .= "package $pkg;\n";
        $code .= "use overload\n" . join(",\n" => @code) . ";\n"
          if @code;

        # Note: the following doesn't do anything, since import()
        # is called at BEGIN via use(), but attributes are only
        # evaluated during CHECK. So it's commented out for now.
        # $code .= "BEGIN { sub import { overload::constant (\n" .
        #     join(",\n" => @constcode) . ")}};\n" if @constcode;
    }

    eval $code if $code;
    die $@ if $@;
}
1;


__END__