1package Object::Enum;
2$Object::Enum::VERSION = '0.073';
3use strict;
4use warnings;
5use 5.006001;
6
7use Carp ();
8use Sub::Install ();
9
10use base qw(
11            Class::Data::Inheritable
12            Class::Accessor::Fast
13          );
14
15__PACKAGE__->mk_classdata($_) for (
16  '_values',
17  '_unset',
18  '_default',
19);
20
21__PACKAGE__->mk_accessors(
22  'value',
23);
24
25__PACKAGE__->_unset(1);
26
27use overload (
28  q{""} => '_stringify',
29  fallback => 1,
30);
31
32use Sub::Exporter -setup => {
33  exports => [ Enum => \&_build_enum ],
34};
35
36sub _build_enum {
37  my ($class, undef, $arg) = @_;
38  return sub { $class->new({ %$arg, %{shift || {} } }) };
39}
40
41=head1 NAME
42
43Object::Enum - replacement for C<< if ($foo eq 'bar') >>
44
45=head1 SYNOPSIS
46
47  use Object::Enum qw(Enum);
48
49  my $color = Enum([ qw(red yellow green) ]);
50  # ... later
51  if ($color->is_red) {
52  # it can't be yellow or green
53
54=head1 EXPORTS
55
56See L<Sub::Exporter> for ways to customize this module's
57exports.
58
59=head2 Enum
60
61An optional shortcut for C<< Object::Enum->new >>.
62
63=head1 CLASS METHODS
64
65=head2 new
66
67  my $obj = Object::Enum->new(\@values);
68  # or
69  $obj = Object::Enum->new(\%arg);
70
71Return a new Object::Enum, with one or more sets of possible
72values.
73
74The simplest case is to pass an arrayref, which returns an
75object capable of having any one of the given values or of
76being unset.
77
78The more complex cases involve passing a hashref, which may
79have the following keys:
80
81=over
82
83=item * unset
84
85whether this object can be 'unset' (defaults to true)
86
87=item * default
88
89this object's default value is (defaults to undef)
90
91=item * values
92
93an arrayref, listing the object's possible values (at least
94one required)
95
96=back
97
98=cut
99
100my $id = 0;
101sub _generate_class {
102  my $class = shift;
103  no strict 'refs';
104  my $gen = sprintf "%s::obj_%08d", $class, ++$id;
105  push @{$gen."::ISA"}, $class;
106  return $gen;
107}
108
109sub _mk_values {
110  my $class = shift;
111  for my $value (keys %{ $class->_values }) {
112    Sub::Install::install_sub({
113      into => $class,
114      as   => "set_$value",
115      code => sub { $_[0]->value($value); return $_[0] },
116    });
117    Sub::Install::install_sub({
118      into => $class,
119      as   => "is_$value",
120      code => sub { (shift->value || '') eq $value },
121    });
122  }
123}
124
125sub new {
126  my ($class, $arg) = @_;
127  $arg ||= [];
128  if (ref $arg eq 'ARRAY') {
129    $arg = { values => $arg };
130  }
131
132  unless (@{$arg->{values} || []}) {
133    Carp::croak("at least one possible value must be provided");
134  }
135
136  exists $arg->{unset}   or $arg->{unset} = 1;
137  exists $arg->{default} or $arg->{default} = undef;
138
139  if (!$arg->{unset} && !defined $arg->{default}) {
140    Carp::croak("must supply a defined default for 'unset' to be false");
141  }
142
143  if (defined($arg->{default}) && ! grep {
144    $_ eq $arg->{default}
145  } @{$arg->{values}}) {
146    Carp::croak("default value must be listed in 'values' or undef");
147  }
148
149  my $gen = $class->_generate_class;
150  $gen->_unset($arg->{unset});
151  $gen->_default($arg->{default});
152  $gen->_values({ map { $_ => 1 } @{$arg->{values}} });
153  $gen->_mk_values;
154
155  return $gen->spawn;
156}
157
158sub _stringify {
159  my $self = shift;
160  return '(undef)' unless defined $self->value;
161  return $self->value;
162}
163
164=head1 OBJECT METHODS
165
166=head2 spawn
167
168=head2 clone
169
170  my $new = $obj->clone;
171
172  my $new = $obj->clone($value);
173
174Create a new Enum from an existing object, using the same arguments as were
175originally passed to C<< new >> when that object was created.
176
177An optional value may be passed in; this is identical to (but more convenient
178than) calling C<value> with the same argument on the newly cloned object.
179
180This method was formerly named C<spawn>.  That name will still work but is
181deprecated.
182
183=cut
184
185sub clone {
186  my $class = shift;
187  my $self = bless {
188    value => $class->_default,
189  } => ref($class) || $class;
190  $self->value(@_) if @_;
191  return $self;
192}
193
194BEGIN { *spawn = \&clone }
195
196=head2 value
197
198The current value as a string (or undef)
199
200Note: don't pass in undef; use the L<unset|/unset> method instead.
201
202=cut
203
204sub value {
205  my $self = shift;
206  if (@_) {
207    my $val = shift;
208    Carp::croak("object $self cannot be set to undef") unless defined $val;
209    unless ($self->_values->{$val}) {
210      Carp::croak("object $self cannot be set to '$val'");
211    }
212    return $self->_value_accessor($val);
213  }
214  return $self->_value_accessor;
215}
216
217=head2 values
218
219The possible values for this object
220
221=cut
222
223sub values {
224  my $self = shift;
225  return keys %{ $self->_values };
226}
227
228=head2 unset
229
230Unset the object's value (set to undef)
231
232=cut
233
234sub unset {
235  my $self = shift;
236  unless ($self->_unset) {
237    Carp::croak("object $self cannot be unset");
238  }
239  $self->_value_accessor(undef);
240}
241
242=head2 is_*
243
244=head2 set_*
245
246Automatically generated from the values passed into C<< new
247>>.
248
249None of these methods take any arguments.
250
251The C<< set_* >> methods are chainable; that is, they return
252the object on which they were called.  This lets you do useful things like:
253
254  use Object::Enum Enum => { -as => 'color', values => [qw(red blue)] };
255
256  print color->set_red->value; # prints 'red'
257
258=cut
259
260=head1 AUTHOR
261
262Hans Dieter Pearcey, C<< <hdp at cpan.org> >>
263
264=head1 BUGS
265
266Please report any bugs or feature requests to
267C<bug-object-enum at rt.cpan.org>, or through the web interface at
268L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Object-Enum>.
269I will be notified, and then you'll automatically be notified of progress on
270your bug as I make changes.
271
272=head1 SUPPORT
273
274You can find documentation for this module with the perldoc command.
275
276    perldoc Object::Enum
277
278You can also look for information at:
279
280=over 4
281
282=item * AnnoCPAN: Annotated CPAN documentation
283
284L<http://annocpan.org/dist/Object-Enum>
285
286=item * CPAN Ratings
287
288L<http://cpanratings.perl.org/d/Object-Enum>
289
290=item * RT: CPAN's request tracker
291
292L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Object-Enum>
293
294=item * Search CPAN
295
296L<http://search.cpan.org/dist/Object-Enum>
297
298=item * GitHub
299
300L<https://github.com/jmmills/object-enum/>
301
302=back
303
304=head1 ACKNOWLEDGEMENTS
305
306=head1 COPYRIGHT & LICENSE
307
308Copyright 2006 Hans Dieter Pearcey, all rights reserved.
309
310This program is free software; you can redistribute it and/or modify it
311under the same terms as Perl itself.
312
313=cut
314
3151; # End of Object::Enum
316