lib/DBIx/Class/AccessorGroup.pm

   1 package DBIx::Class::AccessorGroup;
   2
   3 use strict;
   4 use warnings;
   5
   6 use NEXT;
   7
   8 sub mk_group_accessors {
   9     my($self, $group, @fields) = @_;
  10
  11     $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  12 }
  13
  14
  15 {
  16     no strict 'refs';
  17     no warnings 'redefine';
  18
  19     sub _mk_group_accessors {
  20         my($self, $maker, $group, @fields) = @_;
  21         my $class = ref $self || $self;
  22
  23         # So we don't have to do lots of lookups inside the loop.
  24         $maker = $self->can($maker) unless ref $maker;
  25
  26         foreach my $field (@fields) {
  27             if( $field eq 'DESTROY' ) {
  28                 require Carp;
  29                 &Carp::carp("Having a data accessor named DESTROY  in ".
  30                              "'$class' is unwise.");
  31             }
  32
  33             my $name = $field;
  34
  35             ($name, $field) = @$field if ref $field;
  36
  37             my $accessor = $self->$maker($group, $field);
  38             my $alias = "_${name}_accessor";
  39
  40             #warn "$class $group $field $alias";
  41
  42             *{$class."\:\:$name"}  = $accessor;
  43               #unless defined &{$class."\:\:$field"}
  44
  45             *{$class."\:\:$alias"}  = $accessor;
  46               #unless defined &{$class."\:\:$alias"}
  47         }
  48     }
  49 }
  50
  51 sub mk_group_ro_accessors {
  52     my($self, $group, @fields) = @_;
  53
  54     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
  55 }
  56
  57 sub mk_group_wo_accessors {
  58     my($self, $group, @fields) = @_;
  59
  60     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
  61 }
  62
  63 sub make_group_accessor {
  64     my ($class, $group, $field) = @_;
  65
  66     my $set = "set_$group";
  67     my $get = "get_$group";
  68
  69     # Build a closure around $field.
  70     return sub {
  71         my $self = shift;
  72
  73         if(@_) {
  74             return $self->$set($field, @_);
  75         }
  76         else {
  77             return $self->$get($field);
  78         }
  79     };
  80 }
  81
  82 sub make_group_ro_accessor {
  83     my($class, $group, $field) = @_;
  84
  85     my $get = "get_$group";
  86
  87     return sub {
  88         my $self = shift;
  89
  90         if(@_) {
  91             my $caller = caller;
  92             require Carp;
  93             Carp::croak("'$caller' cannot alter the value of '$field' on ".
  94                         "objects of class '$class'");
  95         }
  96         else {
  97             return $self->$get($field);
  98         }
  99     };
 100 }
 101
 102 sub make_group_wo_accessor {
 103     my($class, $group, $field) = @_;
 104
 105     my $set = "set_$group";
 106
 107     return sub {
 108         my $self = shift;
 109
 110         unless (@_) {
 111             my $caller = caller;
 112             require Carp;
 113             Carp::croak("'$caller' cannot access the value of '$field' on ".
 114                         "objects of class '$class'");
 115         }
 116         else {
 117             return $self->$set($field, @_);
 118         }
 119     };
 120 }
 121
 122 1;