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