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.09000';
  11
  12 BEGIN {
  13     our $hasXS;
  14
  15     sub _hasXS {
  16         return $hasXS if defined $hasXS;
  17
  18         $hasXS = 0;
  19         eval {
  20             require Class::XSAccessor;
  21             $hasXS = 1;
  22         };
  23
  24         return $hasXS;
  25     }
  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
 101             if ( $hasXS && $group eq 'simple' ) {
 102                 Class::XSAccessor::newxs_accessor("${class}::${name}", $field, 0);
 103                 Class::XSAccessor::newxs_accessor("${class}::${alias}", $field, 0);
 104
 105                 # XXX: is the alias accessor really necessary?
 106             }
 107             else {
 108                 my $accessor = $self->$maker($group, $field);
 109                 my $alias_accessor = $self->$maker($group, $field);
 110
 111                 *$full_name = Sub::Name::subname($full_name, $accessor);
 112                   #unless defined &{$class."\:\:$field"}
 113
 114                 *$full_alias = Sub::Name::subname($full_alias, $alias_accessor);
 115                   #unless defined &{$class."\:\:$alias"}
 116             }
 117         }
 118     }
 119 }
 120
 121 =head2 mk_group_ro_accessors
 122
 123 =over 4
 124
 125 =item Arguments: $group, @fieldspec
 126
 127 Returns: none
 128
 129 =back
 130
 131 Creates a set of read only accessors in a given group. Identical to
 132 L</mk_group_accessors> but accessors will throw an error if passed a value
 133 rather than setting the value.
 134
 135 =cut
 136
 137 sub mk_group_ro_accessors {
 138     my($self, $group, @fields) = @_;
 139
 140     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 141 }
 142
 143 =head2 mk_group_wo_accessors
 144
 145 =over 4
 146
 147 =item Arguments: $group, @fieldspec
 148
 149 Returns: none
 150
 151 =back
 152
 153 Creates a set of write only accessors in a given group. Identical to
 154 L</mk_group_accessors> but accessors will throw an error if not passed a
 155 value rather than getting the value.
 156
 157 =cut
 158
 159 sub mk_group_wo_accessors {
 160     my($self, $group, @fields) = @_;
 161
 162     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 163 }
 164
 165 =head2 make_group_accessor
 166
 167 =over 4
 168
 169 =item Arguments: $group, $field
 170
 171 Returns: $sub (\CODE)
 172
 173 =back
 174
 175 Returns a single accessor in a given group; called by mk_group_accessors
 176 for each entry in @fieldspec.
 177
 178 =cut
 179
 180 sub make_group_accessor {
 181     my ($class, $group, $field) = @_;
 182
 183     my $set = "set_$group";
 184     my $get = "get_$group";
 185
 186     # eval for faster fastiness
 187     return eval "sub {
 188         if(\@_ > 1) {
 189             return shift->$set('$field', \@_);
 190         }
 191         else {
 192             return shift->$get('$field');
 193         }
 194     };"
 195 }
 196
 197 =head2 make_group_ro_accessor
 198
 199 =over 4
 200
 201 =item Arguments: $group, $field
 202
 203 Returns: $sub (\CODE)
 204
 205 =back
 206
 207 Returns a single read-only accessor in a given group; called by
 208 mk_group_ro_accessors for each entry in @fieldspec.
 209
 210 =cut
 211
 212 sub make_group_ro_accessor {
 213     my($class, $group, $field) = @_;
 214
 215     my $get = "get_$group";
 216
 217     return eval "sub {
 218         if(\@_ > 1) {
 219             my \$caller = caller;
 220             Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
 221                         \"objects of class '$class'\");
 222         }
 223         else {
 224             return shift->$get('$field');
 225         }
 226     };"
 227 }
 228
 229 =head2 make_group_wo_accessor
 230
 231 =over 4
 232
 233 =item Arguments: $group, $field
 234
 235 Returns: $sub (\CODE)
 236
 237 =back
 238
 239 Returns a single write-only accessor in a given group; called by
 240 mk_group_wo_accessors for each entry in @fieldspec.
 241
 242 =cut
 243
 244 sub make_group_wo_accessor {
 245     my($class, $group, $field) = @_;
 246
 247     my $set = "set_$group";
 248
 249     return eval "sub {
 250         unless (\@_ > 1) {
 251             my \$caller = caller;
 252             Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
 253                         \"objects of class '$class'\");
 254         }
 255         else {
 256             return shift->$set('$field', \@_);
 257         }
 258     };"
 259 }
 260
 261 =head2 get_simple
 262
 263 =over 4
 264
 265 =item Arguments: $field
 266
 267 Returns: $value
 268
 269 =back
 270
 271 Simple getter for hash-based objects which returns the value for the field
 272 name passed as an argument.
 273
 274 =cut
 275
 276 sub get_simple {
 277   return $_[0]->{$_[1]};
 278 }
 279
 280 =head2 set_simple
 281
 282 =over 4
 283
 284 =item Arguments: $field, $new_value
 285
 286 Returns: $new_value
 287
 288 =back
 289
 290 Simple setter for hash-based objects which sets and then returns the value
 291 for the field name passed as an argument.
 292
 293 =cut
 294
 295 sub set_simple {
 296   return $_[0]->{$_[1]} = $_[2];
 297 }
 298
 299
 300 =head2 get_inherited
 301
 302 =over 4
 303
 304 =item Arguments: $field
 305
 306 Returns: $value
 307
 308 =back
 309
 310 Simple getter for Classes and hash-based objects which returns the value for
 311 the field name passed as an argument. This behaves much like
 312 L<Class::Data::Accessor> where the field can be set in a base class,
 313 inherited and changed in subclasses, and inherited and changed for object
 314 instances.
 315
 316 =cut
 317
 318 sub get_inherited {
 319     my $class;
 320
 321     if (Scalar::Util::blessed $_[0]) {
 322         my $reftype = Scalar::Util::reftype $_[0];
 323         $class = ref $_[0];
 324
 325         if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) {
 326             return $_[0]->{$_[1]};
 327         } elsif ($reftype ne 'HASH') {
 328             Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 329         };
 330     } else {
 331         $class = $_[0];
 332     };
 333
 334     no strict 'refs';
 335     no warnings qw/uninitialized/;
 336     return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});
 337
 338     # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
 339     my $pkg_gen = mro::get_pkg_gen ($class);
 340     if ( ${$class.'::__cag_pkg_gen'} != $pkg_gen ) {
 341         @{$class.'::__cag_supers'} = $_[0]->get_super_paths;
 342         ${$class.'::__cag_pkg_gen'} = $pkg_gen;
 343     };
 344
 345     foreach (@{$class.'::__cag_supers'}) {
 346         return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]});
 347     };
 348
 349     return undef;
 350 }
 351
 352 =head2 set_inherited
 353
 354 =over 4
 355
 356 =item Arguments: $field, $new_value
 357
 358 Returns: $new_value
 359
 360 =back
 361
 362 Simple setter for Classes and hash-based objects which sets and then returns
 363 the value for the field name passed as an argument. When called on a hash-based
 364 object it will set the appropriate hash key value. When called on a class, it
 365 will set a class level variable.
 366
 367 B<Note:>: This method will die if you try to set an object variable on a non
 368 hash-based object.
 369
 370 =cut
 371
 372 sub set_inherited {
 373     if (Scalar::Util::blessed $_[0]) {
 374         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 375             return $_[0]->{$_[1]} = $_[2];
 376         } else {
 377             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 378         };
 379     } else {
 380         no strict 'refs';
 381
 382         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 383     };
 384 }
 385
 386 =head2 get_component_class
 387
 388 =over 4
 389
 390 =item Arguments: $field
 391
 392 Returns: $value
 393
 394 =back
 395
 396 Gets the value of the specified component class.
 397
 398     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 399
 400     $self->result_class->method();
 401
 402     ## same as
 403     $self->get_component_class('result_class')->method();
 404
 405 =cut
 406
 407 sub get_component_class {
 408     return $_[0]->get_inherited($_[1]);
 409 };
 410
 411 =head2 set_component_class
 412
 413 =over 4
 414
 415 =item Arguments: $field, $class
 416
 417 Returns: $new_value
 418
 419 =back
 420
 421 Inherited accessor that automatically loads the specified class before setting
 422 it. This method will die if the specified class could not be loaded.
 423
 424     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 425     __PACKAGE__->result_class('MyClass');
 426
 427     $self->result_class->method();
 428
 429 =cut
 430
 431 sub set_component_class {
 432     if ($_[2]) {
 433         local $^W = 0;
 434         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 435             eval "use $_[2]";
 436
 437             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 438         };
 439     };
 440
 441     return $_[0]->set_inherited($_[1], $_[2]);
 442 };
 443
 444 =head2 get_super_paths
 445
 446 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 447
 448 =cut
 449
 450 sub get_super_paths {
 451     my $class = Scalar::Util::blessed $_[0] || $_[0];
 452
 453     return @{mro::get_linear_isa($class)};
 454 };
 455
 456 1;
 457
 458 =head1 AUTHORS
 459
 460 Matt S. Trout <mst@shadowcatsystems.co.uk>
 461 Christopher H. Laco <claco@chrislaco.com>
 462
 463 With contributions from:
 464
 465 Guillermo Roditi <groditi@cpan.org>
 466
 467 =head1 COPYRIGHT & LICENSE
 468
 469 Copyright (c) 2006-2009 Matt S. Trout <mst@shadowcatsystems.co.uk>
 470
 471 This program is free software; you can redistribute it and/or modify
 472 it under the same terms as perl itself.
 473
 474 =cut