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.09002';
  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 our $hasXS;
  16 sub _hasXS {
  17
  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
 105             if ( $hasXS && $group eq 'simple' ) {
 106                 Class::XSAccessor::newxs_accessor("${class}::${name}", $field, 0);
 107                 Class::XSAccessor::newxs_accessor("${class}::${alias}", $field, 0);
 108
 109                 # XXX: is the alias accessor really necessary?
 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 (Scalar::Util::blessed $_[0]) {
 326         my $reftype = Scalar::Util::reftype $_[0];
 327         $class = ref $_[0];
 328
 329         if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) {
 330             return $_[0]->{$_[1]};
 331         } elsif ($reftype ne 'HASH') {
 332             Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 333         };
 334     } else {
 335         $class = $_[0];
 336     };
 337
 338     no strict 'refs';
 339     no warnings qw/uninitialized/;
 340     return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});
 341
 342     # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
 343     my $pkg_gen = mro::get_pkg_gen ($class);
 344     if ( ${$class.'::__cag_pkg_gen'} != $pkg_gen ) {
 345         @{$class.'::__cag_supers'} = $_[0]->get_super_paths;
 346         ${$class.'::__cag_pkg_gen'} = $pkg_gen;
 347     };
 348
 349     foreach (@{$class.'::__cag_supers'}) {
 350         return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]});
 351     };
 352
 353     return undef;
 354 }
 355
 356 =head2 set_inherited
 357
 358 =over 4
 359
 360 =item Arguments: $field, $new_value
 361
 362 Returns: $new_value
 363
 364 =back
 365
 366 Simple setter for Classes and hash-based objects which sets and then returns
 367 the value for the field name passed as an argument. When called on a hash-based
 368 object it will set the appropriate hash key value. When called on a class, it
 369 will set a class level variable.
 370
 371 B<Note:>: This method will die if you try to set an object variable on a non
 372 hash-based object.
 373
 374 =cut
 375
 376 sub set_inherited {
 377     if (Scalar::Util::blessed $_[0]) {
 378         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 379             return $_[0]->{$_[1]} = $_[2];
 380         } else {
 381             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 382         };
 383     } else {
 384         no strict 'refs';
 385
 386         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 387     };
 388 }
 389
 390 =head2 get_component_class
 391
 392 =over 4
 393
 394 =item Arguments: $field
 395
 396 Returns: $value
 397
 398 =back
 399
 400 Gets the value of the specified component class.
 401
 402     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 403
 404     $self->result_class->method();
 405
 406     ## same as
 407     $self->get_component_class('result_class')->method();
 408
 409 =cut
 410
 411 sub get_component_class {
 412     return $_[0]->get_inherited($_[1]);
 413 };
 414
 415 =head2 set_component_class
 416
 417 =over 4
 418
 419 =item Arguments: $field, $class
 420
 421 Returns: $new_value
 422
 423 =back
 424
 425 Inherited accessor that automatically loads the specified class before setting
 426 it. This method will die if the specified class could not be loaded.
 427
 428     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 429     __PACKAGE__->result_class('MyClass');
 430
 431     $self->result_class->method();
 432
 433 =cut
 434
 435 sub set_component_class {
 436     if ($_[2]) {
 437         local $^W = 0;
 438         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 439             eval "use $_[2]";
 440
 441             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 442         };
 443     };
 444
 445     return $_[0]->set_inherited($_[1], $_[2]);
 446 };
 447
 448 =head2 get_super_paths
 449
 450 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 451
 452 =cut
 453
 454 sub get_super_paths {
 455     my $class = Scalar::Util::blessed $_[0] || $_[0];
 456
 457     return @{mro::get_linear_isa($class)};
 458 };
 459
 460 1;
 461
 462 =head1 Performance
 463
 464 You can speed up accessors of type 'simple' by installing L<Class::XSAccessor>.
 465 Note however that the use of this module is disabled by default on Win32
 466 systems, as it causes yet untracked segfaults. If you are a Win32 user, and
 467 want to try this module with L<Class::XSAccessor>, set
 468 C<$Class::Accessor::Grouped::hasXS> to a true value B<before> registering
 469 your accessors (e.g. in a C<BEGIN> block)
 470
 471 =head1 AUTHORS
 472
 473 Matt S. Trout <mst@shadowcatsystems.co.uk>
 474 Christopher H. Laco <claco@chrislaco.com>
 475
 476 With contributions from:
 477
 478 Guillermo Roditi <groditi@cpan.org>
 479
 480 =head1 COPYRIGHT & LICENSE
 481
 482 Copyright (c) 2006-2009 Matt S. Trout <mst@shadowcatsystems.co.uk>
 483
 484 This program is free software; you can redistribute it and/or modify
 485 it under the same terms as perl itself.
 486
 487 =cut