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