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