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 $name = $field;
  36
  37             ($name, $field) = @$field if ref $field;
  38
  39             my $accessor = $self->$maker($group, $field);
  40             my $alias = "_${name}_accessor";
  41
  42             #warn "$class $group $field $alias";
  43
  44             *{$class."\:\:$name"}  = $accessor;
  45               #unless defined &{$class."\:\:$field"}
  46
  47             *{$class."\:\:$alias"}  = $accessor;
  48               #unless defined &{$class."\:\:$alias"}
  49         }
  50     }
  51 }
  52
  53 sub mk_group_ro_accessors {
  54     my($self, $group, @fields) = @_;
  55
  56     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
  57 }
  58
  59 sub mk_group_wo_accessors {
  60     my($self, $group, @fields) = @_;
  61
  62     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
  63 }
  64
  65 sub make_group_accessor {
  66     my ($class, $group, $field) = @_;
  67
  68     my $set = "set_$group";
  69     my $get = "get_$group";
  70
  71     # Build a closure around $field.
  72     return sub {
  73         my $self = shift;
  74
  75         if(@_) {
  76             return $self->$set($field, @_);
  77         }
  78         else {
  79             return $self->$get($field);
  80         }
  81     };
  82 }
  83
  84 sub make_group_ro_accessor {
  85     my($class, $group, $field) = @_;
  86
  87     my $get = "get_$group";
  88
  89     return sub {
  90         my $self = shift;
  91
  92         if(@_) {
  93             my $caller = caller;
  94             require Carp;
  95             Carp::croak("'$caller' cannot alter the value of '$field' on ".
  96                         "objects of class '$class'");
  97         }
  98         else {
  99             return $self->$get($field);
 100         }
 101     };
 102 }
 103
 104 sub make_group_wo_accessor {
 105     my($class, $group, $field) = @_;
 106
 107     my $set = "set_$group";
 108
 109     return sub {
 110         my $self = shift;
 111
 112         unless (@_) {
 113             my $caller = caller;
 114             require Carp;
 115             Carp::croak("'$caller' cannot access the value of '$field' on ".
 116                         "objects of class '$class'");
 117         }
 118         else {
 119             return $self->$set($field, @_);
 120         }
 121     };
 122 }
 123
 124 sub delete_accessor {
 125   my ($class, $accessor) = @_;
 126   $class = ref $class if ref $class;
 127   my $sym = "${class}::${accessor}";
 128   undef &$sym;
 129   delete $DB::sub{$sym};
 130   #$class->_accessor_group_deleted->{"${class}::${accessor}"} = 1;
 131 }
 132
 133 1;