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.01';
  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
 294     if (blessed $self) {
 295         if (reftype($self) eq 'HASH' && exists $self->{$get}) {
 296             return $self->{$get};
 297         } elsif (reftype($self) ne 'HASH') {
 298             croak('Cannot get inherited value on an object instance that is not hash-based');
 299         };
 300     };
 301
 302     no strict 'refs';
 303
 304     my @supers = Class::ISA::self_and_super_path(ref $self || $self);
 305     foreach (@supers) {
 306         return ${$_.'::_'.$get} if defined(${$_.'::_'.$get});
 307     };
 308 }
 309
 310 =head2 set_inherited
 311
 312 =over 4
 313
 314 =item Arguments: $field, $new_value
 315
 316 Returns: $new_value
 317
 318 =back
 319
 320 Simple setter for Classes and hash-based objects which sets and then returns the value
 321 for the field name passed as an argument. When called on a hash-based object it will set the appropriate
 322 hash key value. When called on a class, it will set a class level variable.
 323
 324 B<Note:>: This method will die if you try to set an object variable on a non hash-based object.
 325
 326 =cut
 327
 328 sub set_inherited {
 329     my ($self, $set, $val) = @_;
 330
 331     if (blessed $self) {
 332         if (reftype($self) eq 'HASH') {
 333             return $self->{$set} = $val;
 334         } else {
 335             croak('Cannot set inherited value on an object instance that is not hash-based');
 336         };
 337     } else {
 338         no strict 'refs';
 339
 340         return ${$self.'::_'.$set} = $val;
 341     };
 342 }
 343
 344 1;
 345
 346 =head1 AUTHORS
 347
 348 Matt S. Trout <mst@shadowcatsystems.co.uk>
 349
 350 =head1 LICENSE
 351
 352 You may distribute this code under the same terms as Perl itself.
 353
 354 =cut
 355