lib/DBIx/Class/AccessorGroup.pm

   1 package DBIx::Class::AccessorGroup;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 DBIx::Class::AccessorGroup -  Lets you build groups of accessors
   9
  10 =head1 SYNOPSIS
  11
  12 =head1 DESCRIPTION
  13
  14 This class lets you build groups of accessors that will call different
  15 getters and setters.
  16
  17 =head1 METHODS
  18
  19 =over 4
  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                 require Carp;
  44                 &Carp::carp("Having a data accessor named DESTROY  in ".
  45                              "'$class' is unwise.");
  46             }
  47
  48             my $name = $field;
  49
  50             ($name, $field) = @$field if ref $field;
  51
  52             my $accessor = $self->$maker($group, $field);
  53             my $alias = "_${name}_accessor";
  54
  55             #warn "$class $group $field $alias";
  56
  57             *{$class."\:\:$name"}  = $accessor;
  58               #unless defined &{$class."\:\:$field"}
  59
  60             *{$class."\:\:$alias"}  = $accessor;
  61               #unless defined &{$class."\:\:$alias"}
  62         }
  63     }
  64 }
  65
  66 sub mk_group_ro_accessors {
  67     my($self, $group, @fields) = @_;
  68
  69     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
  70 }
  71
  72 sub mk_group_wo_accessors {
  73     my($self, $group, @fields) = @_;
  74
  75     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
  76 }
  77
  78 sub make_group_accessor {
  79     my ($class, $group, $field) = @_;
  80
  81     my $set = "set_$group";
  82     my $get = "get_$group";
  83
  84     # Build a closure around $field.
  85     return sub {
  86         my $self = shift;
  87
  88         if(@_) {
  89             return $self->$set($field, @_);
  90         }
  91         else {
  92             return $self->$get($field);
  93         }
  94     };
  95 }
  96
  97 sub make_group_ro_accessor {
  98     my($class, $group, $field) = @_;
  99
 100     my $get = "get_$group";
 101
 102     return sub {
 103         my $self = shift;
 104
 105         if(@_) {
 106             my $caller = caller;
 107             require Carp;
 108             Carp::croak("'$caller' cannot alter the value of '$field' on ".
 109                         "objects of class '$class'");
 110         }
 111         else {
 112             return $self->$get($field);
 113         }
 114     };
 115 }
 116
 117 sub make_group_wo_accessor {
 118     my($class, $group, $field) = @_;
 119
 120     my $set = "set_$group";
 121
 122     return sub {
 123         my $self = shift;
 124
 125         unless (@_) {
 126             my $caller = caller;
 127             require Carp;
 128             Carp::croak("'$caller' cannot access the value of '$field' on ".
 129                         "objects of class '$class'");
 130         }
 131         else {
 132             return $self->$set($field, @_);
 133         }
 134     };
 135 }
 136
 137 sub get_simple {
 138   my ($self, $get) = @_;
 139   return $self->{$get};
 140 }
 141
 142 sub set_simple {
 143   my ($self, $set, $val) = @_;
 144   return $self->{$set} = $val;
 145 }
 146
 147 1;
 148
 149 =back
 150
 151 =head1 AUTHORS
 152
 153 Matt S. Trout <mst@shadowcatsystems.co.uk>
 154
 155 =head1 LICENSE
 156
 157 You may distribute this code under the same terms as Perl itself.
 158
 159 =cut
 160