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