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