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