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