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     # eval for faster fastiness
 191     my $code = eval "sub {
 192         if(\@_ > 1) {
 193             return shift->$set('$field', \@_);
 194         }
 195         else {
 196             return shift->$get('$field');
 197         }
 198     };";
 199     Carp::croak $@ if $@;
 200
 201     return $code;
 202 }
 203
 204 =head2 make_group_ro_accessor
 205
 206 =over 4
 207
 208 =item Arguments: $group, $field
 209
 210 Returns: $sub (\CODE)
 211
 212 =back
 213
 214 Returns a single read-only accessor in a given group; called by
 215 mk_group_ro_accessors for each entry in @fieldspec.
 216
 217 =cut
 218
 219 sub make_group_ro_accessor {
 220     my($class, $group, $field) = @_;
 221
 222     my $get = "get_$group";
 223
 224     my $code = eval "sub {
 225         if(\@_ > 1) {
 226             my \$caller = caller;
 227             Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
 228                         \"objects of class '$class'\");
 229         }
 230         else {
 231             return shift->$get('$field');
 232         }
 233     };";
 234     Carp::croak $@ if $@;
 235
 236     return $code;
 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     my $code = 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     Carp::croak $@ if $@;
 270
 271     return $code;
 272 }
 273
 274 =head2 get_simple
 275
 276 =over 4
 277
 278 =item Arguments: $field
 279
 280 Returns: $value
 281
 282 =back
 283
 284 Simple getter for hash-based objects which returns the value for the field
 285 name passed as an argument.
 286
 287 =cut
 288
 289 sub get_simple {
 290   return $_[0]->{$_[1]};
 291 }
 292
 293 =head2 set_simple
 294
 295 =over 4
 296
 297 =item Arguments: $field, $new_value
 298
 299 Returns: $new_value
 300
 301 =back
 302
 303 Simple setter for hash-based objects which sets and then returns the value
 304 for the field name passed as an argument.
 305
 306 =cut
 307
 308 sub set_simple {
 309   return $_[0]->{$_[1]} = $_[2];
 310 }
 311
 312
 313 =head2 get_inherited
 314
 315 =over 4
 316
 317 =item Arguments: $field
 318
 319 Returns: $value
 320
 321 =back
 322
 323 Simple getter for Classes and hash-based objects which returns the value for
 324 the field name passed as an argument. This behaves much like
 325 L<Class::Data::Accessor> where the field can be set in a base class,
 326 inherited and changed in subclasses, and inherited and changed for object
 327 instances.
 328
 329 =cut
 330
 331 sub get_inherited {
 332     my $class;
 333
 334     if ( ($class = ref $_[0]) && Scalar::Util::blessed $_[0]) {
 335         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 336           return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
 337         }
 338         else {
 339           Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 340         }
 341     }
 342     else {
 343         $class = $_[0];
 344     }
 345
 346     no strict 'refs';
 347     no warnings qw/uninitialized/;
 348
 349     my $cag_slot = '::__cag_'. $_[1];
 350     return ${$class.$cag_slot} if defined(${$class.$cag_slot});
 351
 352     # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
 353     my $cur_gen = mro::get_pkg_gen ($class);
 354     if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
 355         @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
 356         ${$class.'::__cag_pkg_gen__'} = $cur_gen;
 357     }
 358
 359     for (@{$class.'::__cag_supers__'}) {
 360         return ${$_.$cag_slot} if defined(${$_.$cag_slot});
 361     };
 362
 363     return undef;
 364 }
 365
 366 =head2 set_inherited
 367
 368 =over 4
 369
 370 =item Arguments: $field, $new_value
 371
 372 Returns: $new_value
 373
 374 =back
 375
 376 Simple setter for Classes and hash-based objects which sets and then returns
 377 the value for the field name passed as an argument. When called on a hash-based
 378 object it will set the appropriate hash key value. When called on a class, it
 379 will set a class level variable.
 380
 381 B<Note:>: This method will die if you try to set an object variable on a non
 382 hash-based object.
 383
 384 =cut
 385
 386 sub set_inherited {
 387     if (Scalar::Util::blessed $_[0]) {
 388         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 389             return $_[0]->{$_[1]} = $_[2];
 390         } else {
 391             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 392         };
 393     } else {
 394         no strict 'refs';
 395
 396         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 397     };
 398 }
 399
 400 =head2 get_component_class
 401
 402 =over 4
 403
 404 =item Arguments: $field
 405
 406 Returns: $value
 407
 408 =back
 409
 410 Gets the value of the specified component class.
 411
 412     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 413
 414     $self->result_class->method();
 415
 416     ## same as
 417     $self->get_component_class('result_class')->method();
 418
 419 =cut
 420
 421 sub get_component_class {
 422     return $_[0]->get_inherited($_[1]);
 423 };
 424
 425 =head2 set_component_class
 426
 427 =over 4
 428
 429 =item Arguments: $field, $class
 430
 431 Returns: $new_value
 432
 433 =back
 434
 435 Inherited accessor that automatically loads the specified class before setting
 436 it. This method will die if the specified class could not be loaded.
 437
 438     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 439     __PACKAGE__->result_class('MyClass');
 440
 441     $self->result_class->method();
 442
 443 =cut
 444
 445 sub set_component_class {
 446     if ($_[2]) {
 447         local $^W = 0;
 448         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 449             eval "use $_[2]";
 450
 451             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 452         };
 453     };
 454
 455     return $_[0]->set_inherited($_[1], $_[2]);
 456 };
 457
 458 =head2 get_super_paths
 459
 460 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 461
 462 =cut
 463
 464 sub get_super_paths {
 465     return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
 466 };
 467
 468 1;
 469
 470 =head1 PERFORMANCE
 471
 472 You can speed up accessors of type 'simple' by installing L<Class::XSAccessor>.
 473
 474 =head1 AUTHORS
 475
 476 Matt S. Trout <mst@shadowcatsystems.co.uk>
 477 Christopher H. Laco <claco@chrislaco.com>
 478
 479 =head1 CONTRIBUTORS
 480
 481 groditi: Guillermo Roditi <groditi@cpan.org>
 482 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 483
 484 =head1 COPYRIGHT & LICENSE
 485
 486 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 487
 488 This program is free software; you can redistribute it and/or modify
 489 it under the same terms as perl itself.
 490
 491 =cut