Commit | Line | Data |
fe5d862b |
1 | package DBIx::Class::AccessorGroup; |
2 | |
12bbb339 |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use base qw/Class::Data::Inheritable/; |
604d9f38 |
7 | use NEXT; |
12bbb339 |
8 | |
9 | __PACKAGE__->mk_classdata('_accessor_group_deleted' => { }); |
10 | |
fe5d862b |
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'; |
12bbb339 |
20 | no warnings 'redefine'; |
fe5d862b |
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 | |
b8e1e21f |
36 | my $name = $field; |
37 | |
38 | ($name, $field) = @$field if ref $field; |
39 | |
fe5d862b |
40 | my $accessor = $self->$maker($group, $field); |
b8e1e21f |
41 | my $alias = "_${name}_accessor"; |
fe5d862b |
42 | |
12bbb339 |
43 | #warn "$class $group $field $alias"; |
fe5d862b |
44 | |
b8e1e21f |
45 | *{$class."\:\:$name"} = $accessor; |
12bbb339 |
46 | #unless defined &{$class."\:\:$field"} |
47 | |
48 | *{$class."\:\:$alias"} = $accessor; |
49 | #unless defined &{$class."\:\:$alias"} |
fe5d862b |
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(@_) { |
12bbb339 |
77 | return $self->$set($field, @_); |
fe5d862b |
78 | } |
79 | else { |
12bbb339 |
80 | return $self->$get($field); |
fe5d862b |
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 { |
12bbb339 |
100 | return $self->$get($field); |
fe5d862b |
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 { |
12bbb339 |
120 | return $self->$set($field, @_); |
fe5d862b |
121 | } |
122 | }; |
123 | } |
124 | |
12bbb339 |
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 | |
fe5d862b |
134 | 1; |