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