File Coverage

blib/lib/EO/Attributes.pm

Criterion	Covered	Total	%
statement	45	72	62.5
branch	0	4	0.0
condition			n/a
subroutine	14	19	73.6
pod	0	3	0.0
total	59	98	60.2

package EO::Attributes;

use strict;
use warnings;

use Attribute::Handlers;
use Scalar::Util qw(blessed);

our $VERSION = 0.96;

sub UNIVERSAL::Private : ATTR(CODE) {
  my ($package, $symbol, $referent, $attr, $data) = @_;
  no strict 'refs';
  no warnings 'redefine';
  my $thing = *{$symbol};
  my $meth  = substr($thing, rindex($thing,':')+1);
  *{$symbol} = sub {
    my $self = shift;
    my $class = ref($self);
    my ($callpkg, $callfile, $callline) = caller();
    if ($package ne $callpkg) {
      my $text = "Can't private method \"$meth\" from package $package";
      throw EO::Error::Method::Private
	text => $text,
	  file => $callfile;
    }
    $referent->( $self, @_ );
  };
}


sub UNIVERSAL::Abstract : ATTR(CODE) {
  my ($package, $symbol, $referent, $attr, $data) = @_;
  no strict 'refs';
  no warnings 'redefine';
  my $thing = *{$symbol};
  my $meth  = substr($thing, rindex($thing,':')+1);
  *{$symbol} = sub {
    my $self = shift;
    my $class = blessed($self) ? ref($self) : $self;
    my ($package, $filename, $line) = caller();
    my $text = "Can't call abstract method \"$meth\" on object of type \"$class\"";
    throw EO::Error::Method::Abstract
      text => $text,
      file => $filename;
  };
}

sub UNIVERSAL::Deprecated : ATTR(CODE) {
  my ($package, $symbol, $referent, $attr, $data) = @_;
  no strict 'refs';
  no warnings 'redefine';
  my $thing = *{$symbol};
  my $meth = substr($thing, rindex($thing,':')+1);
  *{$symbol} = sub {
    my ($pkg, $filename, $line) = caller();
    print STDERR "use of deprecated method $meth at $filename line $line\n";
    $referent->( @_ );
  }
}

#sub UNIVERSAL::private : ATTR(CODE) { UNIVERSAL::Private(@_) }
#sub UNIVERSAL::abstract : ATTR(CODE) { UNIVERSAL::Private(@_) }

1;

__END__