lib/DBIx/Class/AccessorGroup.pm

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