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