Commit | Line | Data |
a7caa492 |
1 | package Catalyst::ClassData; |
2 | |
3 | use Moose::Role; |
76aab993 |
4 | use Class::MOP; |
74c89dea |
5 | use Class::MOP::Object; |
a7caa492 |
6 | use Scalar::Util 'blessed'; |
7 | |
8 | sub mk_classdata { |
efbfd430 |
9 | my ($class, $attribute) = @_; |
a7caa492 |
10 | confess("mk_classdata() is a class method, not an object method") |
efbfd430 |
11 | if blessed $class; |
12 | |
13 | my $slot = '$'.$attribute; |
14 | my $accessor = sub { |
eece41a2 |
15 | my $pkg = ref $_[0] || $_[0]; |
74c89dea |
16 | my $meta = $pkg->Class::MOP::Object::meta(); |
76721d3c |
17 | if (@_ > 1) { |
ce50990e |
18 | $meta->namespace->{$attribute} = \$_[1]; |
76721d3c |
19 | no strict 'refs'; |
20 | if (! *{"${pkg}::${attribute}"}{CODE} ) { |
21 | foreach my $super ( $meta->linearized_isa ) { |
22 | # If there is a code symbol for this class data in a parent class, but not in our |
23 | # class then copy it into our package. This is evil. |
24 | my $parent_symbol = *{"${super}::${attribute}"}{CODE} ? \&{"${super}::${attribute}"} : undef; |
25 | if (defined $parent_symbol) { |
26 | *{"${pkg}::${attribute}"} = $parent_symbol; |
27 | last; |
28 | } |
29 | } |
30 | } |
efbfd430 |
31 | return $_[1]; |
32 | } |
76aab993 |
33 | |
eece41a2 |
34 | # tighter version of |
35 | # if ( $meta->has_package_symbol($slot) ) { |
36 | # return ${ $meta->get_package_symbol($slot) }; |
37 | # } |
38 | no strict 'refs'; |
39 | my $v = *{"${pkg}::${attribute}"}{SCALAR}; |
40 | if (defined ${$v}) { |
41 | return ${$v}; |
46d0346d |
42 | } else { |
43 | foreach my $super ( $meta->linearized_isa ) { |
eece41a2 |
44 | # tighter version of same after |
45 | # my $super_meta = Moose::Meta::Class->initialize($super); |
875d8110 |
46 | my $v = ${"${super}::"}{$attribute} ? *{"${super}::${attribute}"}{SCALAR} : undef; |
eece41a2 |
47 | if (defined ${$v}) { |
48 | return ${$v}; |
46d0346d |
49 | } |
efbfd430 |
50 | } |
51 | } |
52 | return; |
a7caa492 |
53 | }; |
76aab993 |
54 | |
55 | confess("Failed to create accessor: $@ ") |
efbfd430 |
56 | unless ref $accessor eq 'CODE'; |
a7caa492 |
57 | |
74c89dea |
58 | my $meta = $class->Class::MOP::Object::meta(); |
843c9233 |
59 | my $immutable_options; |
60 | if( $meta->is_immutable ){ |
61 | $immutable_options = $meta->get_immutable_options; |
62 | $meta->make_mutable; |
63 | } |
a7caa492 |
64 | my $alias = "_${attribute}_accessor"; |
efbfd430 |
65 | $meta->add_method($alias, $accessor); |
66 | $meta->add_method($attribute, $accessor); |
843c9233 |
67 | if(defined $immutable_options){ |
11ae7378 |
68 | $meta->make_immutable(%{ $immutable_options }); |
843c9233 |
69 | } |
efbfd430 |
70 | $class->$attribute($_[2]) if(@_ > 2); |
a7caa492 |
71 | return $accessor; |
72 | } |
73 | |
74 | 1; |
75 | |
76 | __END__ |
46d0346d |
77 | |
78 | |
79 | =head1 NAME |
80 | |
81 | Catalyst::ClassData - Class data acessors |
82 | |
83 | =head1 METHODS |
84 | |
85 | =head2 mk_classdata $name, $optional_value |
86 | |
87 | A moose-safe clone of L<Class::Data::Inheritable> that borrows some ideas from |
88 | L<Class::Accessor::Grouped>; |
89 | |
90 | =head1 AUTHOR |
91 | |
92 | Guillermo Roditi |
93 | |
94 | =head1 COPYRIGHT |
95 | |
96 | This program is free software, you can redistribute it and/or modify it under |
97 | the same terms as Perl itself. |
98 | |
99 | =cut |