File Coverage

blib/lib/MooseX/SetOnce.pm
Criterion Covered Total %
statement 15 15 100.0
branch 2 2 100.0
condition n/a
subroutine 6 6 100.0
pod n/a
total 23 23 100.0


line stmt bran cond sub pod time code
1 2     2   206758 use strict;
  2         12  
  2         92  
2 2     2   13 use warnings;
  2         3  
  2         126  
3             package MooseX::SetOnce 0.202;
4             # ABSTRACT: write-once, read-many attributes for Moose
5              
6             #pod =head1 SYNOPSIS
7             #pod
8             #pod Add the "SetOnce" trait to attributes:
9             #pod
10             #pod package Class;
11             #pod use Moose;
12             #pod use MooseX::SetOnce;
13             #pod
14             #pod has some_attr => (
15             #pod is => 'rw',
16             #pod traits => [ qw(SetOnce) ],
17             #pod );
18             #pod
19             #pod ...and then you can only set them once:
20             #pod
21             #pod my $object = Class->new;
22             #pod
23             #pod $object->some_attr(10); # works fine
24             #pod $object->some_attr(20); # throws an exception: it's already set!
25             #pod
26             #pod =head1 DESCRIPTION
27             #pod
28             #pod The 'SetOnce' attribute lets your class have attributes that are not lazy and
29             #pod not set, but that cannot be altered once set.
30             #pod
31             #pod The logic is very simple: if you try to alter the value of an attribute with
32             #pod the SetOnce trait, either by accessor or writer, and the attribute has a value,
33             #pod it will throw an exception.
34             #pod
35             #pod If the attribute has a clearer, you may clear the attribute and set it again.
36             #pod
37             #pod =cut
38              
39             package MooseX::SetOnce::Attribute 0.202;
40 2     2   876 use Moose::Role 0.90;
  2         348169  
  2         12  
41              
42             before set_value => sub { $_[0]->_ensure_unset($_[1]) };
43              
44             around _inline_set_value => sub {
45             my $orig = shift;
46             my $self = shift;
47             my ($instance) = @_;
48              
49             my @source = $self->$orig(@_);
50              
51             return (
52             'Class::MOP::class_of(' . $instance . ')->find_attribute_by_name(',
53             '\'' . quotemeta($self->name) . '\'',
54             ')->_ensure_unset(' . $instance . ');',
55             @source,
56             );
57             } if $Moose::VERSION >= 1.9900;
58              
59             sub _ensure_unset {
60 34     34   58043 my ($self, $instance) = @_;
61 34 100       116 Carp::confess("cannot change value of SetOnce attribute " . $self->name)
62             if $self->has_value($instance);
63             }
64              
65             around accessor_metaclass => sub {
66             my ($orig, $self, @rest) = @_;
67              
68             return Moose::Meta::Class->create_anon_class(
69             superclasses => [ $self->$orig(@_) ],
70             roles => [ 'MooseX::SetOnce::Accessor' ],
71             cache => 1
72             )->name
73             } if $Moose::VERSION < 1.9900;
74              
75             package MooseX::SetOnce::Accessor 0.202;
76 2     2   12000 use Moose::Role 0.90;
  2         29  
  2         12  
77              
78             around _inline_store => sub {
79             my ($orig, $self, $instance, $value) = @_;
80              
81             my $code = $self->$orig($instance, $value);
82             $code = sprintf qq[%s->meta->find_attribute_by_name("%s")->_ensure_unset(%s);\n%s],
83             $instance,
84             quotemeta($self->associated_attribute->name),
85             $instance,
86             $code;
87              
88             return $code;
89             };
90              
91             package Moose::Meta::Attribute::Custom::Trait::SetOnce 0.202;
92 2     2   1198 sub register_implementation { 'MooseX::SetOnce::Attribute' }
93              
94             1;
95              
96             __END__
97              
98             =pod
99              
100             =encoding UTF-8
101              
102             =head1 NAME
103              
104             MooseX::SetOnce - write-once, read-many attributes for Moose
105              
106             =head1 VERSION
107              
108             version 0.202
109              
110             =head1 SYNOPSIS
111              
112             Add the "SetOnce" trait to attributes:
113              
114             package Class;
115             use Moose;
116             use MooseX::SetOnce;
117              
118             has some_attr => (
119             is => 'rw',
120             traits => [ qw(SetOnce) ],
121             );
122              
123             ...and then you can only set them once:
124              
125             my $object = Class->new;
126              
127             $object->some_attr(10); # works fine
128             $object->some_attr(20); # throws an exception: it's already set!
129              
130             =head1 DESCRIPTION
131              
132             The 'SetOnce' attribute lets your class have attributes that are not lazy and
133             not set, but that cannot be altered once set.
134              
135             The logic is very simple: if you try to alter the value of an attribute with
136             the SetOnce trait, either by accessor or writer, and the attribute has a value,
137             it will throw an exception.
138              
139             If the attribute has a clearer, you may clear the attribute and set it again.
140              
141             =head1 AUTHOR
142              
143             Ricardo SIGNES <cpan@semiotic.systems>
144              
145             =head1 CONTRIBUTORS
146              
147             =for stopwords Jesse Luehrs Karen Etheridge Kent Fredric Ricardo Signes
148              
149             =over 4
150              
151             =item *
152              
153             Jesse Luehrs <doy@tozt.net>
154              
155             =item *
156              
157             Karen Etheridge <ether@cpan.org>
158              
159             =item *
160              
161             Kent Fredric <kentfredric@gmail.com>
162              
163             =item *
164              
165             Ricardo Signes <rjbs@semiotic.systems>
166              
167             =back
168              
169             =head1 COPYRIGHT AND LICENSE
170              
171             This software is copyright (c) 2022 by Ricardo SIGNES.
172              
173             This is free software; you can redistribute it and/or modify it under
174             the same terms as the Perl 5 programming language system itself.
175              
176             =cut