lib/Class/Accessor/Grouped.pm

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