Now passing four more tests, has_a and has_many compliance extended
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / AccessorGroup.pm
CommitLineData
fe5d862b 1package DBIx::Class::AccessorGroup;
2
12bbb339 3use strict;
4use warnings;
5
6use base qw/Class::Data::Inheritable/;
7
8__PACKAGE__->mk_classdata('_accessor_group_deleted' => { });
9
fe5d862b 10sub 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';
12bbb339 19 no warnings 'redefine';
fe5d862b 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
b8e1e21f 35 my $name = $field;
36
37 ($name, $field) = @$field if ref $field;
38
fe5d862b 39 my $accessor = $self->$maker($group, $field);
b8e1e21f 40 my $alias = "_${name}_accessor";
fe5d862b 41
12bbb339 42 #warn "$class $group $field $alias";
fe5d862b 43
b8e1e21f 44 *{$class."\:\:$name"} = $accessor;
12bbb339 45 #unless defined &{$class."\:\:$field"}
46
47 *{$class."\:\:$alias"} = $accessor;
48 #unless defined &{$class."\:\:$alias"}
fe5d862b 49 }
50 }
51}
52
53sub mk_group_ro_accessors {
54 my($self, $group, @fields) = @_;
55
56 $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
57}
58
59sub mk_group_wo_accessors {
60 my($self, $group, @fields) = @_;
61
62 $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
63}
64
65sub 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(@_) {
12bbb339 76 return $self->$set($field, @_);
fe5d862b 77 }
78 else {
12bbb339 79 return $self->$get($field);
fe5d862b 80 }
81 };
82}
83
84sub 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 {
12bbb339 99 return $self->$get($field);
fe5d862b 100 }
101 };
102}
103
104sub 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 {
12bbb339 119 return $self->$set($field, @_);
fe5d862b 120 }
121 };
122}
123
12bbb339 124sub 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
fe5d862b 1331;