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 =cut
  20
  21 sub mk_group_accessors {
  22     my($self, $group, @fields) = @_;
  23
  24     $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  25 }
  26
  27
  28 {
  29     no strict 'refs';
  30     no warnings 'redefine';
  31
  32     sub _mk_group_accessors {
  33         my($self, $maker, $group, @fields) = @_;
  34         my $class = ref $self || $self;
  35
  36         # So we don't have to do lots of lookups inside the loop.
  37         $maker = $self->can($maker) unless ref $maker;
  38
  39         foreach my $field (@fields) {
  40             if( $field eq 'DESTROY' ) {
  41                 require Carp;
  42                 &Carp::carp("Having a data accessor named DESTROY  in ".
  43                              "'$class' is unwise.");
  44             }
  45
  46             my $name = $field;
  47
  48             ($name, $field) = @$field if ref $field;
  49
  50             my $accessor = $self->$maker($group, $field);
  51             my $alias = "_${name}_accessor";
  52
  53             #warn "$class $group $field $alias";
  54
  55             *{$class."\:\:$name"}  = $accessor;
  56               #unless defined &{$class."\:\:$field"}
  57
  58             *{$class."\:\:$alias"}  = $accessor;
  59               #unless defined &{$class."\:\:$alias"}
  60         }
  61     }
  62 }
  63
  64 sub mk_group_ro_accessors {
  65     my($self, $group, @fields) = @_;
  66
  67     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
  68 }
  69
  70 sub mk_group_wo_accessors {
  71     my($self, $group, @fields) = @_;
  72
  73     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
  74 }
  75
  76 sub make_group_accessor {
  77     my ($class, $group, $field) = @_;
  78
  79     my $set = "set_$group";
  80     my $get = "get_$group";
  81
  82     # Build a closure around $field.
  83     return sub {
  84         my $self = shift;
  85
  86         if(@_) {
  87             return $self->$set($field, @_);
  88         }
  89         else {
  90             return $self->$get($field);
  91         }
  92     };
  93 }
  94
  95 sub make_group_ro_accessor {
  96     my($class, $group, $field) = @_;
  97
  98     my $get = "get_$group";
  99
 100     return sub {
 101         my $self = shift;
 102
 103         if(@_) {
 104             my $caller = caller;
 105             require Carp;
 106             Carp::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             Carp::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 1;
 146
 147 =head1 AUTHORS
 148
 149 Matt S. Trout <mst@shadowcatsystems.co.uk>
 150
 151 =head1 LICENSE
 152
 153 You may distribute this code under the same terms as Perl itself.
 154
 155 =cut
 156