lib/Class/Accessor/Grouped.pm

   1 package Class::Accessor::Grouped;
   2 use strict;
   3 use warnings;
   4 use Carp;
   5 use Class::ISA;
   6 use Scalar::Util qw/blessed reftype/;
   7 use vars qw($VERSION);
   8
   9 $VERSION = '0.03';
  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 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
  40 this is used as both field and accessor name, if a listref it is expected to
  41 be of the form [ $accessor, $field ].
  42
  43 =cut
  44
  45 sub mk_group_accessors {
  46   my ($self, $group, @fields) = @_;
  47
  48   $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  49   return;
  50 }
  51
  52
  53 {
  54     no strict 'refs';
  55     no warnings 'redefine';
  56
  57     sub _mk_group_accessors {
  58         my($self, $maker, $group, @fields) = @_;
  59         my $class = ref $self || $self;
  60
  61         # So we don't have to do lots of lookups inside the loop.
  62         $maker = $self->can($maker) unless ref $maker;
  63
  64         foreach my $field (@fields) {
  65             if( $field eq 'DESTROY' ) {
  66                 carp("Having a data accessor named DESTROY  in ".
  67                              "'$class' is unwise.");
  68             }
  69
  70             my $name = $field;
  71
  72             ($name, $field) = @$field if ref $field;
  73
  74             my $accessor = $self->$maker($group, $field);
  75             my $alias = "_${name}_accessor";
  76
  77             #warn "$class $group $field $alias";
  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 the field name passed as
 286 an argument. This behaves much like L<Class::Data::Accessor> where the field can be set in a
 287 base class, inherited and changed in subclasses, and inherited and changed for object instances.
 288
 289 =cut
 290
 291 sub get_inherited {
 292     my ($self, $get) = @_;
 293     my $class;
 294
 295     if (blessed $self) {
 296         my $reftype = reftype $self;
 297         $class = ref $self;
 298
 299         if ($reftype eq 'HASH' && exists $self->{$get}) {
 300             return $self->{$get};
 301         } elsif ($reftype ne 'HASH') {
 302             croak('Cannot get inherited value on an object instance that is not hash-based');
 303         };
 304     } else {
 305         $class = $self;
 306     };
 307
 308     no strict 'refs';
 309     return ${$class.'::__cag_'.$get} if defined(${$class.'::__cag_'.$get});
 310
 311     if (!@{$class.'::__cag_supers'}) {
 312         @{$class.'::__cag_supers'} = $self->get_super_paths;
 313     };
 314
 315     foreach (@{$class.'::__cag_supers'}) {
 316         return ${$_.'::__cag_'.$get} if defined(${$_.'::__cag_'.$get});
 317     };
 318
 319     return;
 320 }
 321
 322 =head2 set_inherited
 323
 324 =over 4
 325
 326 =item Arguments: $field, $new_value
 327
 328 Returns: $new_value
 329
 330 =back
 331
 332 Simple setter for Classes and hash-based objects which sets and then returns the value
 333 for the field name passed as an argument. When called on a hash-based object it will set the appropriate
 334 hash key value. When called on a class, it will set a class level variable.
 335
 336 B<Note:>: This method will die if you try to set an object variable on a non hash-based object.
 337
 338 =cut
 339
 340 sub set_inherited {
 341     my ($self, $set, $val) = @_;
 342
 343     if (blessed $self) {
 344         if (reftype($self) eq 'HASH') {
 345             return $self->{$set} = $val;
 346         } else {
 347             croak('Cannot set inherited value on an object instance that is not hash-based');
 348         };
 349     } else {
 350         no strict 'refs';
 351
 352         return ${$self.'::__cag_'.$set} = $val;
 353     };
 354 }
 355
 356 =head2 get_super_paths
 357
 358 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 359
 360 =cut
 361
 362 sub get_super_paths {
 363     my $class = blessed $_[0] || $_[0];
 364
 365     return Class::ISA::super_path($class);
 366 };
 367
 368 1;
 369
 370 =head1 AUTHORS
 371
 372 Matt S. Trout <mst@shadowcatsystems.co.uk>
 373 Christopher H. Laco <claco@chrislaco.com>
 374
 375 =head1 LICENSE
 376
 377 You may distribute this code under the same terms as Perl itself.
 378
 379 =cut
 380