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