File Coverage

blib/lib/Class/Accessor/Installer.pm

Criterion	Covered	Total	%
statement	29	43	67.4
branch	4	16	25.0
condition	1	6	16.6
subroutine	7	8	87.5
pod	2	2	100.0
total	43	75	57.3

use 5.006;
use warnings;
use strict;

package Class::Accessor::Installer;
our $VERSION = '1.100880';

# ABSTRACT: Install an accessor subroutine
use Sub::Name;
use UNIVERSAL::require;

sub install_accessor {
    my ($self, %args) = @_;
    my ($package, $name, $code) = @args{qw(package name code)};
    unless (defined $package) {
        $package = ref $self || $self;
    }
    $name = [$name] unless ref $name eq 'ARRAY';
    my @caller;
    if ($::PTAGS) {
        my $level = 1;
        do { @caller = caller($level++) }
          while $caller[0] =~ /^Class(::\w+)*::Accessor::/o;
    }
    for my $sub (@$name) {
        no strict 'refs';
        $::PTAGS && $::PTAGS->add_tag($sub, $caller[1], $caller[2]);
        *{"${package}::${sub}"} = subname "${package}::${sub}" => $code;
    }
}

sub document_accessor {
    my ($self, %args) = @_;

    # Don't use() it - this should still work if we don't have
    # Sub::Documentation.
    Sub::Documentation->require;
    return if $@;
    my $package = delete $args{package};
    unless (defined $package) {
        $package = ref $self || $self;
    }
    my $name = delete $args{name};
    $name = [$name] unless ref $name eq 'ARRAY';
    my $belongs_to = delete $args{belongs_to};
    while (my ($type, $documentation) = each %args) {
        Sub::Documentation::add_documentation(
            package       => $package,
            name          => $name,
            glob_type     => 'CODE',
            type          => $type,
            documentation => $documentation,
            ($belongs_to ? (belongs_to => $belongs_to) : ()),
        );
    }
}
1;


__END__