Commit | Line | Data |
52e8a34c |
1 | |
2 | package InsideOutClass; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Class::MOP 'meta'; |
8 | |
9 | use Scalar::Util 'refaddr'; |
10 | |
11 | our $VERSION = '0.01'; |
12 | |
13 | __PACKAGE__->meta->superclasses('Class::MOP::Class'); |
14 | |
15 | sub construct_instance { |
16 | my ($class, %params) = @_; |
17 | my $instance = \(my $var); |
18 | foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) { |
19 | # if the attr has an init_arg, use that, otherwise, |
20 | # use the attributes name itself as the init_arg |
21 | my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; |
22 | # try to fetch the init arg from the %params ... |
23 | my $val; |
24 | $val = $params{$init_arg} if exists $params{$init_arg}; |
25 | # if nothing was in the %params, we can use the |
26 | # attribute's default value (if it has one) |
27 | $val ||= $attr->default($instance) if $attr->has_default(); |
28 | # now add this to the instance structure |
29 | $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val; |
30 | } |
31 | return $instance; |
32 | } |
33 | |
34 | |
35 | package InsideOutAttribute; |
36 | |
37 | use strict; |
38 | use warnings; |
39 | |
40 | use Carp 'confess'; |
41 | use Scalar::Util 'blessed', 'reftype', 'refaddr'; |
42 | |
43 | use Class::MOP 'meta'; |
44 | |
45 | our $VERSION = '0.01'; |
46 | |
47 | __PACKAGE__->meta->superclasses('Class::MOP::Attribute'); |
48 | |
49 | { |
50 | # this is just a utility routine to |
51 | # handle the details of accessors |
52 | my $_inspect_accessor = sub { |
53 | my ($attr_name, $type, $accessor) = @_; |
54 | |
55 | my %ACCESSOR_TEMPLATES = ( |
56 | 'accessor' => 'sub { |
57 | $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2; |
58 | $' . $attr_name . '{ refaddr($_[0]) }; |
59 | }', |
60 | 'reader' => 'sub { |
61 | $' . $attr_name . '{ refaddr($_[0]) }; |
62 | }', |
63 | 'writer' => 'sub { |
64 | $' . $attr_name . '{ refaddr($_[0]) } = $_[1]; |
65 | }', |
66 | 'predicate' => 'sub { |
67 | defined($' . $attr_name . '{ refaddr($_[0]) }) ? 1 : 0; |
68 | }' |
69 | ); |
70 | |
71 | if (reftype($accessor) && reftype($accessor) eq 'HASH') { |
72 | my ($name, $method) = each %{$accessor}; |
73 | return ($name, Class::MOP::Attribute::Accessor->wrap($method)); |
74 | } |
75 | else { |
76 | my $method = eval $ACCESSOR_TEMPLATES{$type}; |
77 | confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@; |
78 | return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); |
79 | } |
80 | }; |
81 | |
82 | sub install_accessors { |
83 | my ($self, $class) = @_; |
84 | (blessed($class) && $class->isa('Class::MOP::Class')) |
85 | || confess "You must pass a Class::MOP::Class instance (or a subclass)"; |
86 | |
87 | $class->add_package_variable('%' . $self->name); |
88 | |
89 | $class->add_method( |
90 | $_inspect_accessor->($class->name . '::' . $self->name, 'accessor' => $self->accessor()) |
91 | ) if $self->has_accessor(); |
92 | |
93 | $class->add_method( |
94 | $_inspect_accessor->($class->name . '::' . $self->name, 'reader' => $self->reader()) |
95 | ) if $self->has_reader(); |
96 | |
97 | $class->add_method( |
98 | $_inspect_accessor->($class->name . '::' . $self->name, 'writer' => $self->writer()) |
99 | ) if $self->has_writer(); |
100 | |
101 | $class->add_method( |
102 | $_inspect_accessor->($class->name . '::' . $self->name, 'predicate' => $self->predicate()) |
103 | ) if $self->has_predicate(); |
104 | return; |
105 | } |
106 | |
107 | } |
108 | |
109 | ## &remove_attribute is left as an exercise for the reader :) |
110 | |
111 | 1; |