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 =cut
  22
  23 sub mk_group_accessors {
  24     my($self, $group, @fields) = @_;
  25
  26     $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  27 }
  28
  29
  30 {
  31     no strict 'refs';
  32     no warnings 'redefine';
  33
  34     sub _mk_group_accessors {
  35         my($self, $maker, $group, @fields) = @_;
  36         my $class = ref $self || $self;
  37
  38         # So we don't have to do lots of lookups inside the loop.
  39         $maker = $self->can($maker) unless ref $maker;
  40
  41         foreach my $field (@fields) {
  42             if( $field eq 'DESTROY' ) {
  43                 carp("Having a data accessor named DESTROY  in ".
  44                              "'$class' is unwise.");
  45             }
  46
  47             my $name = $field;
  48
  49             ($name, $field) = @$field if ref $field;
  50
  51             my $accessor = $self->$maker($group, $field);
  52             my $alias = "_${name}_accessor";
  53
  54             #warn "$class $group $field $alias";
  55
  56             *{$class."\:\:$name"}  = $accessor;
  57               #unless defined &{$class."\:\:$field"}
  58
  59             *{$class."\:\:$alias"}  = $accessor;
  60               #unless defined &{$class."\:\:$alias"}
  61         }
  62     }
  63 }
  64
  65 sub mk_group_ro_accessors {
  66     my($self, $group, @fields) = @_;
  67
  68     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
  69 }
  70
  71 sub mk_group_wo_accessors {
  72     my($self, $group, @fields) = @_;
  73
  74     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
  75 }
  76
  77 sub make_group_accessor {
  78     my ($class, $group, $field) = @_;
  79
  80     my $set = "set_$group";
  81     my $get = "get_$group";
  82
  83     # Build a closure around $field.
  84     return sub {
  85         my $self = shift;
  86
  87         if(@_) {
  88             return $self->$set($field, @_);
  89         }
  90         else {
  91             return $self->$get($field);
  92         }
  93     };
  94 }
  95
  96 sub make_group_ro_accessor {
  97     my($class, $group, $field) = @_;
  98
  99     my $get = "get_$group";
 100
 101     return sub {
 102         my $self = shift;
 103
 104         if(@_) {
 105             my $caller = caller;
 106             croak("'$caller' cannot alter the value of '$field' on ".
 107                         "objects of class '$class'");
 108         }
 109         else {
 110             return $self->$get($field);
 111         }
 112     };
 113 }
 114
 115 sub make_group_wo_accessor {
 116     my($class, $group, $field) = @_;
 117
 118     my $set = "set_$group";
 119
 120     return sub {
 121         my $self = shift;
 122
 123         unless (@_) {
 124             my $caller = caller;
 125             croak("'$caller' cannot access the value of '$field' on ".
 126                         "objects of class '$class'");
 127         }
 128         else {
 129             return $self->$set($field, @_);
 130         }
 131     };
 132 }
 133
 134 sub get_simple {
 135   my ($self, $get) = @_;
 136   return $self->{$get};
 137 }
 138
 139 sub set_simple {
 140   my ($self, $set, $val) = @_;
 141   return $self->{$set} = $val;
 142 }
 143
 144 sub get_component_class {
 145   my ($self, $get) = @_;
 146   if (ref $self) {
 147       return $self->{$get};
 148   } else {
 149       $get = "_$get";
 150       return $self->can($get) ? $self->$get : undef;
 151   }
 152 }
 153
 154 sub set_component_class {
 155   my ($self, $set, $val) = @_;
 156   eval "require $val";
 157   if (ref $self) {
 158       return $self->{$set} = $val;
 159   } else {
 160       $set = "_$set";
 161       return $self->can($set) ? $self->$set($val) : $self->mk_classdata($set => $val);
 162   }
 163 }
 164
 165 1;
 166
 167 =head1 AUTHORS
 168
 169 Matt S. Trout <mst@shadowcatsystems.co.uk>
 170
 171 =head1 LICENSE
 172
 173 You may distribute this code under the same terms as Perl itself.
 174
 175 =cut
 176