File Coverage: lib/MooX/Const.pm

# File Coverage

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 |  |  | 2 |  | 409 17 6 | use utf8;
6 | 2 2 |  |  | 2 |  | 42 5 | use v5.8;
7 |
8 | 2 2 2 |  |  | 2 |  | 6 2 57 | use Carp qw( croak );
9 | 2 2 2 |  |  | 2 |  | 6 2 11 | use Moo ();
10 | 2 2 2 |  |  | 2 |  | 306 8109 51 | use Moo::Role ();
11 | 2 2 2 |  |  | 2 |  | 314 481 146 | use Safe::Isa qw( $_isa );
12 | 2 2 2 |  |  | 2 |  | 279 81960 19 | use Types::Const qw( Const );
13 | 2 2 2 |  |  | 2 |  | 605 4 9 | use Types::Standard qw( Value Object Ref );
14 |
15 | 2 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 |  |  | 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 |  | 2 | my $class = shift;
79 |
80 | 2 |  |  |  |  | 4 | my $target = caller;
81 |
82 | 2 | 50 |  |  |  | 36 | my $installer =
83 |  |  |  |  |  |  | $target->isa("Moo::Object")
84 |  |  |  |  |  |  | ? \&Moo::_install_tracked
85 |  |  |  |  |  |  | : \&Moo::Role::_install_tracked;
86 |
87 | 2 | 50 |  |  |  | 24 | if ( my $has = $target->can('has') ) {
88 |  |  |  |  |  |  | my $new_has = sub {
89 | 12 |  |  | 12 8 |  | 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 |  |  | 12 |  | 32 | my ( $name, %opts ) = @_;
98 |
99 | 12 |  |  |  |  | 16 | my $is = $opts{is};
100 |
101 | 12 | 100 | 67 |  |  | 71 | if ($is && $is =~ /^(?:const|wo)$/ ) {
102 |
103 | 11 | 100 |  |  |  | 65 | if ( my $isa = $opts{isa} ) {
104 |
105 | 10 | 100 |  |  |  | 51 | unless ( $isa->$_isa('Type::Tiny') ) {
106 | 1 |  |  |  |  | 17 | croak "isa must be a Type::Tiny type";
107 |  |  |  |  |  |  | }
108 |
109 | 9 | 100 |  |  |  | 171 | if ($isa->is_a_type_of(Value)) {
110 |
111 | 2 | 100 |  |  |  | 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 | 100 |  |  |  | 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 | 100 |  |  |  | 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 | 100 | 100 |  |  | 25 | if ($opts{trigger} && ($is ne 'wo')) {
137 | 1 |  |  |  |  | 6 | croak "triggers are not applicable to const attributes";
138 |  |  |  |  |  |  | }
139 |
140 | 3 | 100 |  |  |  | 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;