File Coverage

File:lib/MooX/Const.pm
Coverage:96.0%

linestmtbrancondsubpodtimecode
1package 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
17our $VERSION = 'v0.2.1';
18
19 - 21
=for Pod::Coverage VERSION

=cut
22
23sub 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
77sub 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
96sub _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
1781;