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