lib/DBIx/Class/AccessorGroup.pm

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