lib/DBIx/Class/AccessorGroup.pm

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