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 (Scalar::Util::blessed $_[0]) {
 332         my $reftype = Scalar::Util::reftype $_[0];
 333         $class = ref $_[0];
 334
 335         if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) {
 336             return $_[0]->{$_[1]};
 337         } elsif ($reftype ne 'HASH') {
 338             Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 339         };
 340     } else {
 341         $class = $_[0];
 342     };
 343
 344     no strict 'refs';
 345     no warnings qw/uninitialized/;
 346     return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});
 347
 348     # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
 349     my $pkg_gen = mro::get_pkg_gen ($class);
 350     if ( ${$class.'::__cag_pkg_gen'} != $pkg_gen ) {
 351         @{$class.'::__cag_supers'} = $_[0]->get_super_paths;
 352         ${$class.'::__cag_pkg_gen'} = $pkg_gen;
 353     };
 354
 355     foreach (@{$class.'::__cag_supers'}) {
 356         return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]});
 357     };
 358
 359     return undef;
 360 }
 361
 362 =head2 set_inherited
 363
 364 =over 4
 365
 366 =item Arguments: $field, $new_value
 367
 368 Returns: $new_value
 369
 370 =back
 371
 372 Simple setter for Classes and hash-based objects which sets and then returns
 373 the value for the field name passed as an argument. When called on a hash-based
 374 object it will set the appropriate hash key value. When called on a class, it
 375 will set a class level variable.
 376
 377 B<Note:>: This method will die if you try to set an object variable on a non
 378 hash-based object.
 379
 380 =cut
 381
 382 sub set_inherited {
 383     if (Scalar::Util::blessed $_[0]) {
 384         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 385             return $_[0]->{$_[1]} = $_[2];
 386         } else {
 387             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 388         };
 389     } else {
 390         no strict 'refs';
 391
 392         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 393     };
 394 }
 395
 396 =head2 get_component_class
 397
 398 =over 4
 399
 400 =item Arguments: $field
 401
 402 Returns: $value
 403
 404 =back
 405
 406 Gets the value of the specified component class.
 407
 408     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 409
 410     $self->result_class->method();
 411
 412     ## same as
 413     $self->get_component_class('result_class')->method();
 414
 415 =cut
 416
 417 sub get_component_class {
 418     return $_[0]->get_inherited($_[1]);
 419 };
 420
 421 =head2 set_component_class
 422
 423 =over 4
 424
 425 =item Arguments: $field, $class
 426
 427 Returns: $new_value
 428
 429 =back
 430
 431 Inherited accessor that automatically loads the specified class before setting
 432 it. This method will die if the specified class could not be loaded.
 433
 434     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 435     __PACKAGE__->result_class('MyClass');
 436
 437     $self->result_class->method();
 438
 439 =cut
 440
 441 sub set_component_class {
 442     if ($_[2]) {
 443         local $^W = 0;
 444         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 445             eval "use $_[2]";
 446
 447             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 448         };
 449     };
 450
 451     return $_[0]->set_inherited($_[1], $_[2]);
 452 };
 453
 454 =head2 get_super_paths
 455
 456 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 457
 458 =cut
 459
 460 sub get_super_paths {
 461     my $class = Scalar::Util::blessed $_[0] || $_[0];
 462
 463     return @{mro::get_linear_isa($class)};
 464 };
 465
 466 1;
 467
 468 =head1 PERFORMANCE
 469
 470 You can speed up accessors of type 'simple' by installing L<Class::XSAccessor>.
 471 Note however that the use of this module is disabled by default on Win32
 472 systems, as it causes yet unresolved segfaults. If you are a Win32 user, and
 473 want to try this module with L<Class::XSAccessor>, set
 474 C<$Class::Accessor::Grouped::hasXS> to a true value B<before> registering
 475 your accessors (e.g. in a C<BEGIN> block)
 476
 477 =head1 AUTHORS
 478
 479 Matt S. Trout <mst@shadowcatsystems.co.uk>
 480 Christopher H. Laco <claco@chrislaco.com>
 481
 482 With contributions from:
 483
 484 Guillermo Roditi <groditi@cpan.org>
 485
 486 =head1 COPYRIGHT & LICENSE
 487
 488 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 489
 490 This program is free software; you can redistribute it and/or modify
 491 it under the same terms as perl itself.
 492
 493 =cut