lib/DBIx/Class/AccessorGroup.pm

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