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