Fixed DBICTest Schema class names, added class_resolver system to make them work
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / AccessorGroup.pm
1 package DBIx::Class::AccessorGroup;
2
3 use strict;
4 use warnings;
5
6 use NEXT;
7
8 =head1 NAME 
9
10 DBIx::Class::AccessorGroup -  Lets you build groups of accessors
11
12 =head1 SYNOPSIS
13
14 =head1 DESCRIPTION
15
16 This class lets you build groups of accessors that will call different
17 getters and setters.
18
19 =head1 METHODS
20
21 =over 4
22
23 =cut
24
25 sub mk_group_accessors {
26     my($self, $group, @fields) = @_;
27
28     $self->_mk_group_accessors('make_group_accessor', $group, @fields);
29 }
30
31
32 {
33     no strict 'refs';
34     no warnings 'redefine';
35
36     sub _mk_group_accessors {
37         my($self, $maker, $group, @fields) = @_;
38         my $class = ref $self || $self;
39
40         # So we don't have to do lots of lookups inside the loop.
41         $maker = $self->can($maker) unless ref $maker;
42
43         foreach my $field (@fields) {
44             if( $field eq 'DESTROY' ) {
45                 require Carp;
46                 &Carp::carp("Having a data accessor named DESTROY  in ".
47                              "'$class' is unwise.");
48             }
49
50             my $name = $field;
51
52             ($name, $field) = @$field if ref $field;
53
54             my $accessor = $self->$maker($group, $field);
55             my $alias = "_${name}_accessor";
56
57             #warn "$class $group $field $alias";
58
59             *{$class."\:\:$name"}  = $accessor;
60               #unless defined &{$class."\:\:$field"}
61
62             *{$class."\:\:$alias"}  = $accessor;
63               #unless defined &{$class."\:\:$alias"}
64         }
65     }
66 }
67
68 sub mk_group_ro_accessors {
69     my($self, $group, @fields) = @_;
70
71     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
72 }
73
74 sub mk_group_wo_accessors {
75     my($self, $group, @fields) = @_;
76
77     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
78 }
79
80 sub make_group_accessor {
81     my ($class, $group, $field) = @_;
82
83     my $set = "set_$group";
84     my $get = "get_$group";
85
86     # Build a closure around $field.
87     return sub {
88         my $self = shift;
89
90         if(@_) {
91             return $self->$set($field, @_);
92         }
93         else {
94             return $self->$get($field);
95         }
96     };
97 }
98
99 sub make_group_ro_accessor {
100     my($class, $group, $field) = @_;
101
102     my $get = "get_$group";
103
104     return sub {
105         my $self = shift;
106
107         if(@_) {
108             my $caller = caller;
109             require Carp;
110             Carp::croak("'$caller' cannot alter the value of '$field' on ".
111                         "objects of class '$class'");
112         }
113         else {
114             return $self->$get($field);
115         }
116     };
117 }
118
119 sub make_group_wo_accessor {
120     my($class, $group, $field) = @_;
121
122     my $set = "set_$group";
123
124     return sub {
125         my $self = shift;
126
127         unless (@_) {
128             my $caller = caller;
129             require Carp;
130             Carp::croak("'$caller' cannot access the value of '$field' on ".
131                         "objects of class '$class'");
132         }
133         else {
134             return $self->$set($field, @_);
135         }
136     };
137 }
138
139 1;
140
141 =back
142
143 =head1 AUTHORS
144
145 Matt S. Trout <perl-stuff@trout.me.uk>
146
147 =head1 LICENSE
148
149 You may distribute this code under the same terms as Perl itself.
150
151 =cut
152