| File: | lib/MooX/Const.pm |
| Coverage: | 96.0% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package MooX::Const; | ||||||
| 2 | |||||||
| 3 | # ABSTRACT: Syntactic sugar for constant and write-once Moo attributes | ||||||
| 4 | |||||||
| 5 | 2 2 2 | 409 17 6 | use utf8; | ||||
| 6 | 2 2 | 42 5 | use v5.8; | ||||
| 7 | |||||||
| 8 | 2 2 2 | 6 2 57 | use Carp qw( croak ); | ||||
| 9 | 2 2 2 | 6 2 11 | use Moo (); | ||||
| 10 | 2 2 2 | 306 8109 51 | use Moo::Role (); | ||||
| 11 | 2 2 2 | 314 481 146 | use Safe::Isa qw( $_isa ); | ||||
| 12 | 2 2 2 | 279 81960 19 | use Types::Const qw( Const ); | ||||
| 13 | 2 2 2 | 605 4 9 | use Types::Standard qw( Value Object Ref ); | ||||
| 14 | |||||||
| 15 | 2 2 2 | 1304 2 9 | use namespace::autoclean; | ||||
| 16 | |||||||
| 17 | our $VERSION = 'v0.2.1'; | ||||||
| 18 | |||||||
| 19 - 21 | =for Pod::Coverage VERSION =cut | ||||||
| 22 | |||||||
| 23 | sub VERSION { # for older Perls | ||||||
| 24 | 1 | 0 | 137 | require version; | |||
| 25 | 1 | 931 | return version->parse($VERSION); | ||||
| 26 | } | ||||||
| 27 | |||||||
| 28 - 75 | =head1 SYNOPSIS
use Moo;
use MooX::Const;
use Types::Standard -types;
has thing => (
is => 'const',
isa => ArrayRef[HashRef],
);
=head1 DESCRIPTION
This is syntactic sugar for using L<Types::Const> with L<Moo>. The
SYNOPSIS above is equivalent to:
use Types::Const -types;
has thing => (
is => 'ro',
isa => Const[ArrayRef[HashRef]],
coerce => 1,
);
It modifies the C<has> function to support "const" attributes. These
are read-only ("ro") attributes for references, where the underlying
data structure has been set as read-only.
This will return an error if there is no "isa", the "isa" is not a
L<Type::Tiny> type, if it is not a reference, or if it is blessed
object.
Simple value types such as C<Int> or C<Str> are silently converted to
read-only attributes.
As of v0.2.0, it also supports write-once ("wo") attributes for
references:
has setting => (
is => 'wo',
isa => HashRef,
);
This allows you to set the attribute I<once>. The value is coerced
into a constant, and cannot be changed again.
=cut | ||||||
| 76 | |||||||
| 77 | sub import { | ||||||
| 78 | 2 | 2 | my $class = shift; | ||||
| 79 | |||||||
| 80 | 2 | 4 | my $target = caller; | ||||
| 81 | |||||||
| 82 | 2 | 36 | my $installer = | ||||
| 83 | $target->isa("Moo::Object") | ||||||
| 84 | ? \&Moo::_install_tracked | ||||||
| 85 | : \&Moo::Role::_install_tracked; | ||||||
| 86 | |||||||
| 87 | 2 | 24 | if ( my $has = $target->can('has') ) { | ||||
| 88 | my $new_has = sub { | ||||||
| 89 | 12 | 3203 | $has->( _process_has(@_) ); | ||||
| 90 | 2 | 5 | }; | ||||
| 91 | 2 | 7 | $installer->( $target, "has", $new_has ); | ||||
| 92 | } | ||||||
| 93 | |||||||
| 94 | } | ||||||
| 95 | |||||||
| 96 | sub _process_has { | ||||||
| 97 | 12 | 32 | my ( $name, %opts ) = @_; | ||||
| 98 | |||||||
| 99 | 12 | 16 | my $is = $opts{is}; | ||||
| 100 | |||||||
| 101 | 12 | 71 | if ($is && $is =~ /^(?:const|wo)$/ ) { | ||||
| 102 | |||||||
| 103 | 11 | 65 | if ( my $isa = $opts{isa} ) { | ||||
| 104 | |||||||
| 105 | 10 | 51 | unless ( $isa->$_isa('Type::Tiny') ) { | ||||
| 106 | 1 | 17 | croak "isa must be a Type::Tiny type"; | ||||
| 107 | } | ||||||
| 108 | |||||||
| 109 | 9 | 171 | if ($isa->is_a_type_of(Value)) { | ||||
| 110 | |||||||
| 111 | 2 | 666 | if ($is eq 'wo') { | ||||
| 112 | |||||||
| 113 | 1 | 7 | croak "write-once attributes are not supported for Value types"; | ||||
| 114 | |||||||
| 115 | } | ||||||
| 116 | else { | ||||||
| 117 | |||||||
| 118 | 1 | 1 | $opts{is} = 'ro'; | ||||
| 119 | |||||||
| 120 | } | ||||||
| 121 | |||||||
| 122 | } | ||||||
| 123 | else { | ||||||
| 124 | |||||||
| 125 | 7 | 3583 | unless ( $isa->is_a_type_of(Ref) ) { | ||||
| 126 | 1 | 303 | croak "isa must be a type of Types::Standard::Ref"; | ||||
| 127 | } | ||||||
| 128 | |||||||
| 129 | 6 | 1054 | if ( $isa->is_a_type_of(Object) ) { | ||||
| 130 | 2 | 390 | croak "isa cannot be a type of Types::Standard::Object"; | ||||
| 131 | } | ||||||
| 132 | |||||||
| 133 | 4 | 1803 | $opts{isa} = Const[$isa]; | ||||
| 134 | 4 | 1689 | $opts{coerce} = $opts{isa}->coercion; | ||||
| 135 | |||||||
| 136 | 4 | 25 | if ($opts{trigger} && ($is ne 'wo')) { | ||||
| 137 | 1 | 6 | croak "triggers are not applicable to const attributes"; | ||||
| 138 | } | ||||||
| 139 | |||||||
| 140 | 3 | 9 | $opts{is} = $is eq 'wo' ? 'rw' : 'ro'; | ||||
| 141 | |||||||
| 142 | } | ||||||
| 143 | |||||||
| 144 | } | ||||||
| 145 | else { | ||||||
| 146 | |||||||
| 147 | 1 | 11 | croak "Missing isa for a const attribute"; | ||||
| 148 | |||||||
| 149 | } | ||||||
| 150 | |||||||
| 151 | } | ||||||
| 152 | |||||||
| 153 | 5 | 20 | return ( $name, %opts ); | ||||
| 154 | } | ||||||
| 155 | |||||||
| 156 - 176 | =head1 ROADMAP Support for Perl versions earlier than 5.10 will be removed sometime in 2019. =head1 SEE ALSO L<Moo> L<Types::Const> L<Type::Tiny> =encoding utf8 =head1 append:AUTHOR This module was inspired by suggestions from Kang-min Liu ååº·æ° <gugod@gugod.org> in a L<blog post|http://blogs.perl.org/users/robert_rothenberg/2018/11/typeconst-released.html>. =cut | ||||||
| 177 | |||||||
| 178 | 1; | ||||||