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