File Coverage

blib/lib/Attribute/Final.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	10	10	100.0
condition	3	3	100.0
subroutine	12	12	100.0
pod	0	3	0.0
total	76	79	96.2

package Attribute::Final;
use 5.006;
use strict;
use warnings;
our $VERSION = '1.3';
our %marked;
my @all_packages;
use B qw(svref_2object);

sub fill_packages {
    no strict 'refs';
    my $root = shift;
    my @subs = grep s/::$//, keys %{$root."::"};
    push @all_packages, $root;
    for (@subs) {
        next if $root eq "main" and $_ eq "main"; # Loop
        fill_packages($root."::".$_);
    }
}

sub check {
    no strict 'refs';
    fill_packages("main") unless @all_packages;
    for my $derived_pack (@all_packages) {
        next unless @{$derived_pack."::ISA"};
        for my $marked_pack (keys %marked) {
            next unless $derived_pack->isa($marked_pack);
            for my $meth (@{$marked{$marked_pack}}) {
                my $glob_ref = \*{$derived_pack."::".$meth};
                if (*{$glob_ref}{CODE}) {
                    my $name = $marked_pack."::".$meth;
                    my $b = svref_2object($glob_ref);
                    die "Cannot override final method $name at ".
                        $b->FILE. ", line ".$b->LINE."\n";
                }
            }
        }
    }
}

CHECK { Attribute::Final->check() }

package UNIVERSAL;
use Attribute::Handlers;
sub final :ATTR(CODE) {
    my ($pack, $ref) = @_;
    push @{$marked{$pack}}, *{$ref}{NAME};
}

# Preloaded methods go here.

1;
__END__