File Coverage

blib/lib/Data/Object/Role/Syntax.pm

Criterion	Covered	Total	%
statement	51	74	68.9
branch	10	28	35.7
condition	13	17	76.4
subroutine	30	32	93.7
pod	23	23	100.0
total	127	174	72.9

# ABSTRACT: Role Declaration DSL for Perl 5
package Data::Object::Role::Syntax;

use 5.010;
use strict;
use warnings;
use parent 'Exporter';

use Sub::Quote;

our $VERSION = '0.42'; # VERSION

our @EXPORT = qw(
    alt
    builder
    clearer
    coerce
    def
    default
    defaulter
    handles
    init_arg
    is
    isa
    lazy
    opt
    optional
    predicate
    reader
    req
    required
    ro
    rw
    trigger
    weak_ref
    writer
);

sub import {
    my $class  = $_[0];
    my $target = caller;

    if (my $orig = $target->can('has')) {

        no strict 'refs';
        no warnings 'redefine';

        my $has = *{"${target}::has"} = sub {
            my ($name, @props) = @_;

            return $orig->($name, @props)
                if @props % 2 != 0;

            my $alt = $name =~ s/^\+//;

            my %codes = (
                builder   => 'build',
                clearer   => 'clear',
                predicate => 'has',
                reader    => 'get',
                trigger   => 'trigger',
                writer    => 'set',
            );

            my %props = @props;
            for my $code (sort keys %codes) {
                if ($props{$code} and $props{$code} eq "1") {
                    my $id = $codes{$code};
                    $props{$code} = "_${id}_${name}";
                    $props{$code} =~ s/_${id}__/_${id}_/;
                }
            }

            if (my $method = delete $props{defaulter}) {
                if ($method eq "1") {
                    $method = "_default_${name}";
                    $method =~ s/_default__/_default_/;
                }
                my $routine = q{ $target->$method(@_) };
                $props{default} = Sub::Quote::quote_sub($routine, {
                    '$target' => \$target,
                    '$method' => \$method,
                });
            }

            return $orig->($alt ? "+$name" : $name, %props);
        };

    }

    return $class->export_to_level(1, @_);
}

sub alt ($@) {
    my ($name, @props) = @_;
    if (my $has = caller->can('has')) {
        my @name = ref $name ? @$name : $name;
        @_ = ((map "+$_", @name), @props) and goto $has;
    }
}

sub builder (;$) {
    return builder => $_[0] // 1;
}

sub clearer (;$) {
    return clearer => $_[0] // 1;
}

sub coerce () {
    return coerce => 1;
}

sub def ($$@) {
    my ($name, $code, @props) = @_;
    @_ = ($name, 'default', $code, @props) and goto &alt;
}

sub default ($) {
    return default => $_[0];
}

sub defaulter (;$) {
    return defaulter => $_[0] // 1;
}

sub handles ($) {
    return handles => $_[0];
}

sub init_arg ($) {
    return init_arg => $_[0];
}

sub is (@) {
    return (@_);
}

sub isa ($) {
    return isa => $_[0];
}

sub lazy () {
    return lazy => 1;
}

sub opt ($;$@) {
    my ($name, $type, @props) = @_;
    my @req = (required => 0);
    @_ = ($name, ref($type) ? isa($type) : (), @props, @req)
        and goto &alt;
}

sub optional (@) {
    return required => 0, @_;
}

sub predicate (;$) {
    return predicate => $_[0] // 1;
}

sub reader (;$) {
    return reader => $_[0] // 1;
}

sub req ($;$@) {
    my ($name, $type, @props) = @_;
    my @req = (required => 1);
    @_ = ($name, ref($type) ? isa($type) : (), @props, @req)
        and goto &alt;
}

sub required (@) {
    return required => 1, @_;
}

sub ro () {
    return is => 'ro';
}

sub rw () {
    return is => 'rw';
}

sub trigger (;$) {
    return trigger => $_[0] // 1;
}

sub weak_ref () {
    return weak_ref => 1;
}

sub writer (;$) {
    return writer => $_[0] // 1;
}

1;

__END__