lib/Class/Accessor/Grouped.pm

   1 package Class::Accessor::Grouped;
   2 use strict;
   3 use warnings;
   4 use Carp::Clan;
   5 use vars qw($VERSION);
   6
   7 $VERSION = '0.01';
   8
   9 =head1 NAME
  10
  11 Class:Accessor::Grouped-  Lets you build groups of accessors
  12
  13 =head1 SYNOPSIS
  14
  15 =head1 DESCRIPTION
  16
  17 This class lets you build groups of accessors that will call different
  18 getters and setters.
  19
  20 =head1 METHODS
  21
  22 =head2 mk_group_accessors
  23
  24 =over 4
  25
  26 =item Arguments: $group, @fieldspec
  27
  28 Returns: none
  29
  30 =back
  31
  32 Creates a set of accessors in a given group.
  33
  34 $group is the name of the accessor group for the generated accessors; they
  35 will call get_$group($field) on get and set_$group($field, $value) on set.
  36
  37 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
  38 this is used as both field and accessor name, if a listref it is expected to
  39 be of the form [ $accessor, $field ].
  40
  41 =cut
  42
  43 sub mk_group_accessors {
  44   my ($self, $group, @fields) = @_;
  45
  46   $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  47   return;
  48 }
  49
  50
  51 {
  52     no strict 'refs';
  53     no warnings 'redefine';
  54
  55     sub _mk_group_accessors {
  56         my($self, $maker, $group, @fields) = @_;
  57         my $class = ref $self || $self;
  58
  59         # So we don't have to do lots of lookups inside the loop.
  60         $maker = $self->can($maker) unless ref $maker;
  61
  62         foreach my $field (@fields) {
  63             if( $field eq 'DESTROY' ) {
  64                 carp("Having a data accessor named DESTROY  in ".
  65                              "'$class' is unwise.");
  66             }
  67
  68             my $name = $field;
  69
  70             ($name, $field) = @$field if ref $field;
  71
  72             my $accessor = $self->$maker($group, $field);
  73             my $alias = "_${name}_accessor";
  74
  75             #warn "$class $group $field $alias";
  76
  77             *{$class."\:\:$name"}  = $accessor;
  78               #unless defined &{$class."\:\:$field"}
  79
  80             *{$class."\:\:$alias"}  = $accessor;
  81               #unless defined &{$class."\:\:$alias"}
  82         }
  83     }
  84 }
  85
  86 =head2 mk_group_ro_accessors
  87
  88 =over 4
  89
  90 =item Arguments: $group, @fieldspec
  91
  92 Returns: none
  93
  94 =back
  95
  96 Creates a set of read only accessors in a given group. Identical to
  97 <L:/mk_group_accessors> but accessors will throw an error if passed a value
  98 rather than setting the value.
  99
 100 =cut
 101
 102 sub mk_group_ro_accessors {
 103     my($self, $group, @fields) = @_;
 104
 105     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 106 }
 107
 108 =head2 mk_group_wo_accessors
 109
 110 =over 4
 111
 112 =item Arguments: $group, @fieldspec
 113
 114 Returns: none
 115
 116 =back
 117
 118 Creates a set of write only accessors in a given group. Identical to
 119 <L:/mk_group_accessors> but accessors will throw an error if not passed a
 120 value rather than getting the value.
 121
 122 =cut
 123
 124 sub mk_group_wo_accessors {
 125     my($self, $group, @fields) = @_;
 126
 127     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 128 }
 129
 130 =head2 make_group_accessor
 131
 132 =over 4
 133
 134 =item Arguments: $group, $field
 135
 136 Returns: $sub (\CODE)
 137
 138 =back
 139
 140 Returns a single accessor in a given group; called by mk_group_accessors
 141 for each entry in @fieldspec.
 142
 143 =cut
 144
 145 sub make_group_accessor {
 146     my ($class, $group, $field) = @_;
 147
 148     my $set = "set_$group";
 149     my $get = "get_$group";
 150
 151     # Build a closure around $field.
 152     return sub {
 153         my $self = shift;
 154
 155         if(@_) {
 156             return $self->$set($field, @_);
 157         }
 158         else {
 159             return $self->$get($field);
 160         }
 161     };
 162 }
 163
 164 =head2 make_group_ro_accessor
 165
 166 =over 4
 167
 168 =item Arguments: $group, $field
 169
 170 Returns: $sub (\CODE)
 171
 172 =back
 173
 174 Returns a single read-only accessor in a given group; called by
 175 mk_group_ro_accessors for each entry in @fieldspec.
 176
 177 =cut
 178
 179 sub make_group_ro_accessor {
 180     my($class, $group, $field) = @_;
 181
 182     my $get = "get_$group";
 183
 184     return sub {
 185         my $self = shift;
 186
 187         if(@_) {
 188             my $caller = caller;
 189             croak("'$caller' cannot alter the value of '$field' on ".
 190                         "objects of class '$class'");
 191         }
 192         else {
 193             return $self->$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 sub {
 219         my $self = shift;
 220
 221         unless (@_) {
 222             my $caller = caller;
 223             croak("'$caller' cannot access the value of '$field' on ".
 224                         "objects of class '$class'");
 225         }
 226         else {
 227             return $self->$set($field, @_);
 228         }
 229     };
 230 }
 231
 232 =head2 get_simple
 233
 234 =over 4
 235
 236 =item Arguments: $field
 237
 238 Returns: $value
 239
 240 =back
 241
 242 Simple getter for hash-based objects which returns the value for the field
 243 name passed as an argument.
 244
 245 =cut
 246
 247 sub get_simple {
 248   my ($self, $get) = @_;
 249   return $self->{$get};
 250 }
 251
 252 =head2 set_simple
 253
 254 =over 4
 255
 256 =item Arguments: $field, $new_value
 257
 258 Returns: $new_value
 259
 260 =back
 261
 262 Simple setter for hash-based objects which sets and then returns the value
 263 for the field name passed as an argument.
 264
 265 =cut
 266
 267 sub set_simple {
 268   my ($self, $set, $val) = @_;
 269   return $self->{$set} = $val;
 270 }
 271
 272 1;
 273
 274 =head1 AUTHORS
 275
 276 Matt S. Trout <mst@shadowcatsystems.co.uk>
 277
 278 =head1 LICENSE
 279
 280 You may distribute this code under the same terms as Perl itself.
 281
 282 =cut
 283