lib/Class/Accessor/Grouped.pm

   1 package Class::Accessor::Grouped;
   2 use strict;
   3 use warnings;
   4 use Carp ();
   5 use Class::Inspector ();
   6 use Scalar::Util ();
   7 use MRO::Compat;
   8
   9 our $VERSION = '0.08002';
  10
  11 =head1 NAME
  12
  13 Class::Accessor::Grouped - Lets you build groups of accessors
  14
  15 =head1 SYNOPSIS
  16
  17 =head1 DESCRIPTION
  18
  19 This class lets you build groups of accessors that will call different
  20 getters and setters.
  21
  22 =head1 METHODS
  23
  24 =head2 mk_group_accessors
  25
  26 =over 4
  27
  28 =item Arguments: $group, @fieldspec
  29
  30 Returns: none
  31
  32 =back
  33
  34 Creates a set of accessors in a given group.
  35
  36 $group is the name of the accessor group for the generated accessors; they
  37 will call get_$group($field) on get and set_$group($field, $value) on set.
  38
  39 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
  40 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
  41 methods.
  42
  43 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
  44 this is used as both field and accessor name, if a listref it is expected to
  45 be of the form [ $accessor, $field ].
  46
  47 =cut
  48
  49 sub mk_group_accessors {
  50   my ($self, $group, @fields) = @_;
  51
  52   $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  53   return;
  54 }
  55
  56
  57 {
  58     no strict 'refs';
  59     no warnings 'redefine';
  60
  61     sub _mk_group_accessors {
  62         my($self, $maker, $group, @fields) = @_;
  63         my $class = Scalar::Util::blessed $self || $self;
  64
  65         # So we don't have to do lots of lookups inside the loop.
  66         $maker = $self->can($maker) unless ref $maker;
  67
  68         foreach my $field (@fields) {
  69             if( $field eq 'DESTROY' ) {
  70                 Carp::carp("Having a data accessor named DESTROY  in ".
  71                              "'$class' is unwise.");
  72             }
  73
  74             my $name = $field;
  75
  76             ($name, $field) = @$field if ref $field;
  77
  78             my $accessor = $self->$maker($group, $field);
  79             my $alias = "_${name}_accessor";
  80
  81             *{$class."\:\:$name"}  = $accessor;
  82               #unless defined &{$class."\:\:$field"}
  83
  84             *{$class."\:\:$alias"}  = $accessor;
  85               #unless defined &{$class."\:\:$alias"}
  86         }
  87     }
  88 }
  89
  90 =head2 mk_group_ro_accessors
  91
  92 =over 4
  93
  94 =item Arguments: $group, @fieldspec
  95
  96 Returns: none
  97
  98 =back
  99
 100 Creates a set of read only accessors in a given group. Identical to
 101 <L:/mk_group_accessors> but accessors will throw an error if passed a value
 102 rather than setting the value.
 103
 104 =cut
 105
 106 sub mk_group_ro_accessors {
 107     my($self, $group, @fields) = @_;
 108
 109     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 110 }
 111
 112 =head2 mk_group_wo_accessors
 113
 114 =over 4
 115
 116 =item Arguments: $group, @fieldspec
 117
 118 Returns: none
 119
 120 =back
 121
 122 Creates a set of write only accessors in a given group. Identical to
 123 <L:/mk_group_accessors> but accessors will throw an error if not passed a
 124 value rather than getting the value.
 125
 126 =cut
 127
 128 sub mk_group_wo_accessors {
 129     my($self, $group, @fields) = @_;
 130
 131     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 132 }
 133
 134 =head2 make_group_accessor
 135
 136 =over 4
 137
 138 =item Arguments: $group, $field
 139
 140 Returns: $sub (\CODE)
 141
 142 =back
 143
 144 Returns a single accessor in a given group; called by mk_group_accessors
 145 for each entry in @fieldspec.
 146
 147 =cut
 148
 149 sub make_group_accessor {
 150     my ($class, $group, $field) = @_;
 151
 152     my $set = "set_$group";
 153     my $get = "get_$group";
 154
 155     # eval for faster fastiness
 156     return eval "sub {
 157         if(\@_ > 1) {
 158             return shift->$set('$field', \@_);
 159         }
 160         else {
 161             return shift->$get('$field');
 162         }
 163     };"
 164 }
 165
 166 =head2 make_group_ro_accessor
 167
 168 =over 4
 169
 170 =item Arguments: $group, $field
 171
 172 Returns: $sub (\CODE)
 173
 174 =back
 175
 176 Returns a single read-only accessor in a given group; called by
 177 mk_group_ro_accessors for each entry in @fieldspec.
 178
 179 =cut
 180
 181 sub make_group_ro_accessor {
 182     my($class, $group, $field) = @_;
 183
 184     my $get = "get_$group";
 185
 186     return eval "sub {
 187         if(\@_ > 1) {
 188             my \$caller = caller;
 189             Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
 190                         \"objects of class '$class'\");
 191         }
 192         else {
 193             return shift->$get('$field');
 194         }
 195     };"
 196 }
 197
 198 =head2 make_group_wo_accessor
 199
 200 =over 4
 201
 202 =item Arguments: $group, $field
 203
 204 Returns: $sub (\CODE)
 205
 206 =back
 207
 208 Returns a single write-only accessor in a given group; called by
 209 mk_group_wo_accessors for each entry in @fieldspec.
 210
 211 =cut
 212
 213 sub make_group_wo_accessor {
 214     my($class, $group, $field) = @_;
 215
 216     my $set = "set_$group";
 217
 218     return eval "sub {
 219         unless (\@_ > 1) {
 220             my \$caller = caller;
 221             Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
 222                         \"objects of class '$class'\");
 223         }
 224         else {
 225             return shift->$set('$field', \@_);
 226         }
 227     };"
 228 }
 229
 230 =head2 get_simple
 231
 232 =over 4
 233
 234 =item Arguments: $field
 235
 236 Returns: $value
 237
 238 =back
 239
 240 Simple getter for hash-based objects which returns the value for the field
 241 name passed as an argument.
 242
 243 =cut
 244
 245 sub get_simple {
 246   return $_[0]->{$_[1]};
 247 }
 248
 249 =head2 set_simple
 250
 251 =over 4
 252
 253 =item Arguments: $field, $new_value
 254
 255 Returns: $new_value
 256
 257 =back
 258
 259 Simple setter for hash-based objects which sets and then returns the value
 260 for the field name passed as an argument.
 261
 262 =cut
 263
 264 sub set_simple {
 265   return $_[0]->{$_[1]} = $_[2];
 266 }
 267
 268
 269 =head2 get_inherited
 270
 271 =over 4
 272
 273 =item Arguments: $field
 274
 275 Returns: $value
 276
 277 =back
 278
 279 Simple getter for Classes and hash-based objects which returns the value for
 280 the field name passed as an argument. This behaves much like
 281 L<Class::Data::Accessor> where the field can be set in a base class,
 282 inherited and changed in subclasses, and inherited and changed for object
 283 instances.
 284
 285 =cut
 286
 287 sub get_inherited {
 288     my $class;
 289
 290     if (Scalar::Util::blessed $_[0]) {
 291         my $reftype = Scalar::Util::reftype $_[0];
 292         $class = ref $_[0];
 293
 294         if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) {
 295             return $_[0]->{$_[1]};
 296         } elsif ($reftype ne 'HASH') {
 297             Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 298         };
 299     } else {
 300         $class = $_[0];
 301     };
 302
 303     no strict 'refs';
 304     return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});
 305
 306     if (!@{$class.'::__cag_supers'}) {
 307         @{$class.'::__cag_supers'} = $_[0]->get_super_paths;
 308     };
 309
 310     foreach (@{$class.'::__cag_supers'}) {
 311         return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]});
 312     };
 313
 314     return undef;
 315 }
 316
 317 =head2 set_inherited
 318
 319 =over 4
 320
 321 =item Arguments: $field, $new_value
 322
 323 Returns: $new_value
 324
 325 =back
 326
 327 Simple setter for Classes and hash-based objects which sets and then returns
 328 the value for the field name passed as an argument. When called on a hash-based
 329 object it will set the appropriate hash key value. When called on a class, it
 330 will set a class level variable.
 331
 332 B<Note:>: This method will die if you try to set an object variable on a non
 333 hash-based object.
 334
 335 =cut
 336
 337 sub set_inherited {
 338     if (Scalar::Util::blessed $_[0]) {
 339         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 340             return $_[0]->{$_[1]} = $_[2];
 341         } else {
 342             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 343         };
 344     } else {
 345         no strict 'refs';
 346
 347         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 348     };
 349 }
 350
 351 =head2 get_component_class
 352
 353 =over 4
 354
 355 =item Arguments: $field
 356
 357 Returns: $value
 358
 359 =back
 360
 361 Gets the value of the specified component class.
 362
 363     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 364
 365     $self->result_class->method();
 366
 367     ## same as
 368     $self->get_component_class('result_class')->method();
 369
 370 =cut
 371
 372 sub get_component_class {
 373     return $_[0]->get_inherited($_[1]);
 374 };
 375
 376 =head2 set_component_class
 377
 378 =over 4
 379
 380 =item Arguments: $field, $class
 381
 382 Returns: $new_value
 383
 384 =back
 385
 386 Inherited accessor that automatically loads the specified class before setting
 387 it. This method will die if the specified class could not be loaded.
 388
 389     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 390     __PACKAGE__->result_class('MyClass');
 391
 392     $self->result_class->method();
 393
 394 =cut
 395
 396 sub set_component_class {
 397     if ($_[2]) {
 398         local $^W = 0;
 399         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 400             eval "use $_[2]";
 401
 402             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 403         };
 404     };
 405
 406     return $_[0]->set_inherited($_[1], $_[2]);
 407 };
 408
 409 =head2 get_super_paths
 410
 411 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 412
 413 =cut
 414
 415 sub get_super_paths {
 416     my $class = Scalar::Util::blessed $_[0] || $_[0];
 417
 418     return @{mro::get_linear_isa($class)};
 419 };
 420
 421 1;
 422
 423 =head1 AUTHORS
 424
 425 Matt S. Trout <mst@shadowcatsystems.co.uk>
 426 Christopher H. Laco <claco@chrislaco.com>
 427
 428 =head1 LICENSE
 429
 430 You may distribute this code under the same terms as Perl itself.
 431
 432 =cut
 433