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             require Carp;
 126             croak("'$caller' cannot access the value of '$field' on ".
 127                         "objects of class '$class'");
 128         }
 129         else {
 130             return $self->$set($field, @_);
 131         }
 132     };
 133 }
 134
 135 sub get_simple {
 136   my ($self, $get) = @_;
 137   return $self->{$get};
 138 }
 139
 140 sub set_simple {
 141   my ($self, $set, $val) = @_;
 142   return $self->{$set} = $val;
 143 }
 144
 145 sub get_component_class {
 146   my ($self, $get) = @_;
 147   if (ref $self) {
 148       return $self->{$get};
 149   } else {
 150       $get = "_$get";
 151       return $self->can($get) ? $self->$get : undef;
 152   }
 153 }
 154
 155 sub set_component_class {
 156   my ($self, $set, $val) = @_;
 157   eval "require $val";
 158   if (ref $self) {
 159       return $self->{$set} = $val;
 160   } else {
 161       $set = "_$set";
 162       return $self->can($set) ? $self->$set($val) : $self->mk_classdata($set => $val);
 163   }
 164 }
 165
 166 1;
 167
 168 =head1 AUTHORS
 169
 170 Matt S. Trout <mst@shadowcatsystems.co.uk>
 171
 172 =head1 LICENSE
 173
 174 You may distribute this code under the same terms as Perl itself.
 175
 176 =cut
 177