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