File Coverage

lib/Class/Dot/Policy.pm

Criterion	Covered	Total	%
statement	144	155	92.9
branch	36	40	90.0
condition	10	12	83.3
subroutine	28	31	90.3
pod	10	12	83.3
total	228	250	91.2

# $Id$
# $Source: /opt/CVS/Getopt-LL/lib/Class/Dot.pm,v $
# $Author$
# $HeadURL$
# $Revision$
# $Date$
package Class::Dot::Policy;

use strict;
use warnings;
use version qw(qv);
use 5.006000;

our $VERSION   = qv('2.0.0_15');
our $AUTHORITY = 'cpan:ASKSH';

# Set to true if Class::Dot::XS loads OK.
use vars qw($XSokay); ## no critic

use Carp                qw(carp croak confess);
use Scalar::Util        qw(blessed);
use Class::Plugin::Util qw(require_class);
use English             qw(-no_match_vars);
use Params::Util        qw(_HASHLIKE);

use Class::Dot::Typemap            qw(:std);

# The global registry.
use Class::Dot::Registry;
our $REGISTRY = Class::Dot::Registry->new();

use Class::Dot::Meta::Method     qw(
    install_sub_from_class
    install_sub_from_coderef
);
use Class::Dot::Meta::Type       qw(
    _NEWSCHOOL_TYPE _OLDSCHOOL_TYPE
);

use Class::Dot::Devel::Sub::Name qw(subname);

# Try to load the Class::Dot::XS speed-up module.
{
    no warnings 'all'; ## no critic
    $Class::Dot::XS::MAGIC_COOKIE = q{Knock. Knock. It's Class::Dot.};
    if (require_class('Class::Dot::XS')) {
        Class::Dot::XS->import();
    }
}

my @STD_EXPORT = qw(
    property after_property_set after_property_get
    extends composite composites has
);
my @ALWAYS_EXPORT_TO_POLICIES = (@STD_EXPORT, qw(
    properties_for_class
    finalize_class
));

push @STD_EXPORT, @Class::Dot::Typemap::STD_TYPES;

my %EXPORT_CLASS = (
    ':std'  => [@STD_EXPORT],
    ':new'  => [@STD_EXPORT, qw(-new)],
    ':fast' => [@STD_EXPORT, qw(-new -optimized)],
);

# The list of allowed option tags.
my %ALLOWED_CLASS_OPTIONS = map { $_ => 1 } qw(
    -new
    -rebuild
    -getter_prefix
    -setter_prefix
    -accessor_type
    -metaclass
    -constrained
    -chained
    -optimized
    -override
    -delegator
);

my %DEFAULT_OPTIONS = (
    '-getter_prefix' => q{},
    '-setter_prefix' => 'set_',
    '-metaclass'     => 'Class::Dot::Meta::Class',
    '-override'      => undef,
);

my @DELEGATOR_APPENDS_EXPORTS = qw(
    delegates to using
);

sub import {
    my ($this_class) = @_;
    my $caller_class = caller 0;

    for my $sub_name (@ALWAYS_EXPORT_TO_POLICIES) {
        install_sub_from_class(
            ($this_class, $sub_name) => $caller_class
        );
    };

    return;
}

sub _create_policy {
    my ($this_class, $push_policy_ref, @args) = @_;

    my %mapped_args = map { $_ => 1 } @args;
    for my $push_policy (@{ $push_policy_ref }) {
        $mapped_args{$push_policy} = 1;
    }
    @args = keys %mapped_args;

    if ($mapped_args{-delegator}) {
        push @args, @DELEGATOR_APPENDS_EXPORTS;
    }

    return @args;
}

sub _dotify_class {
    my ($this_class, $caller_class, @args) = @_;

    my $export_class;
    my @subs;
    for my $arg (@args) {
        if ($arg =~ m/^:/xms) {
            croak(   'Only one export class can be used. '
                    ."(Used already: [$export_class] now: [$arg])")
                if $export_class;

            $export_class = $arg;
        }
        else {
            push @subs, $arg;
        }
    }

    my @subs_to_export
        = $export_class && $EXPORT_CLASS{$export_class}
        ? (@{ $EXPORT_CLASS{$export_class} }, @subs)
        : @subs;

    my $options = $REGISTRY->get_options_for(
        $caller_class, \%DEFAULT_OPTIONS
    );
    for my $sub_to_export (@subs_to_export) {
        if ($sub_to_export =~ m/^-/xms) {
            my $option = $sub_to_export;
            my $value = 1;
            # Can set values on the use-line with '=' assignment.
            if ($option =~ m/=/xms) {
                ($option, $value) = split m/=/xms, $option, 2;
            }
            croak __PACKAGE__.": Unknown class option: [$option]"
                if not exists $ALLOWED_CLASS_OPTIONS{$option};
            $options->{$option} = $value;
        }
        else {
            install_sub_from_class($this_class,
                $sub_to_export => $caller_class
            );
        }
    }

    # ### Register the class.
    $REGISTRY->register_class($caller_class);

    # ### Initialize metaclass for this class.
    if (! $options->{'-new'}) {
        $options->{'-no_constructor'} = 1;
    }

    my $metaclass = $REGISTRY->init_metaclass_for(
        $caller_class, $options->{'-metaclass'}, $options
    );

    return;
}

sub finalize_class {
    my ($opt_class) = @_;
    my $class = $opt_class ? $opt_class
        : caller 0;
    my $metaclass = $REGISTRY->get_metaclass_for($class);

    my $isa_cache =
        $metaclass->property->traverse_isa_for_property($class);

    return $REGISTRY->finalize_class($class, $isa_cache);
}

sub properties_for_class {
    my ($self, $class) = @_;
    my $metaclass = $REGISTRY->get_metaclass_for($class);

    return $metaclass->property->properties_for_class($class);
}

sub has ($;%) { ## no critic
    my ($property, @args) = @_;
    my $caller_class = caller 0;
    my $metaclass    = $REGISTRY->get_metaclass_for($caller_class);

    confess 'Property needs name'
        if not defined $property;

    my $isa;

    # Decide what kind of args this is.
    # If it's a newschool type or it's only one arg it is
    # taken as the property's type.
    if (_NEWSCHOOL_TYPE($args[0]) || scalar @args == 1) {
        $isa = shift @args;
    }

    my %options;
    if (not scalar @args % 2) { # is even number.
        %options = @args;
    }
    elsif (_HASHLIKE($args[-1])) {
        %options    = %{$args[-1]};
    }

    if (defined $options{isa}) {
        $isa        = $options{isa};
        my $default = $options{default};

        # Type names containing '::', means that we should composite the class
        # with the class of that name. (see design/keywords.pm)
        if (defined $isa && $isa =~ m{::}xms) {
            # Class names that does not really have '::' in their name
            # will have '::' tacked on the end, so remove it.
            $isa =~ s{::$}{}xms;
            return $metaclass->composites($property, $isa);
        }

        if ($isa) {
            my $type_init = Class::Dot::Typemap->get_type($isa);
            confess "Unknown type constraint: $isa" if not $type_init;
            $isa = defined $default ? $type_init->($default) : $type_init->();
        }
    }

    # Privacy is either 'privacy' or 'is'. It's the same thing, for now.
    $options{privacy} ||= $options{is};

    # Get privacy option
    if ($property =~ s/^-//xms) {
        $options{privacy}  = 'ro';
    }
    if ($property =~ s/^!//xms) {
        $options{privacy}  = 'xx';
    }


    return $metaclass->property->define_property(
        $property, $isa => $caller_class, {
            %options,
        }
    );
}

sub property (@) { ## no critic
    goto &has;
}

sub extends (@;) { ## no critic
    my (@superclasses) = @_;
    my $inheritor      = caller 0;
    my $meta_class     = $REGISTRY->get_metaclass_for($inheritor);

    return $meta_class->superclasses_for(
        $inheritor => @superclasses
    );
}

sub composites (@;) { ## no critic
    my ($attribute_name, $composite_class) = @_;
    my $caller_class   = caller 0;
    my $metaclass      = $REGISTRY->get_metaclass_for($caller_class);

    return $metaclass->composites($attribute_name, $composite_class);
};

sub composite (@;) { ## no critic
    goto &composites;
}

sub after_property_get (@&) { ## no critic
    my ($property, $func_ref) = @_;
    my $caller_class = caller;

    my $class_meta  = $REGISTRY->get_meta_for($caller_class);
    my $getter_name = $class_meta->{$property}->getter_name();
    install_sub_from_coderef($func_ref => $caller_class, $getter_name);

    return;
}

sub after_property_set (@&) { ## no critic
    my ($property, $func_ref) = @_;
    my $caller_class = caller;

    my $class_meta  = $REGISTRY->get_meta_for($caller_class);
    my $setter_name = $class_meta->{$property}->setter_name();
    install_sub_from_coderef($func_ref => $caller_class, $setter_name);

    return;
}

# syntactic sugar.
sub to (@;)     { @_ }
sub using (@;)  { @_ }

sub delegates ($) {
    my ($to, $using) = @_;
    my $class = caller 0;

    my @mods;
    for my $alternative (@{ $using }) {
        push @mods, modules_matching($_);
    }

    $class->dot::meta::is_delegator($using, @mods);

    return;
}

1;

__END__