|
0 |
package Class::Inner;
|
|
1 |
|
|
2 |
use vars qw/$VERSION/;
|
|
3 |
|
|
4 |
$VERSION = 0.1;
|
|
5 |
|
|
6 |
|
|
7 |
use strict;
|
|
8 |
use Carp;
|
|
9 |
|
|
10 |
=head1 NAME
|
|
11 |
|
|
12 |
Class::Inner - A perlish implementation of Java like inner classes
|
|
13 |
|
|
14 |
=head1 SYNOPSIS
|
|
15 |
|
|
16 |
use Class::Inner;
|
|
17 |
|
|
18 |
my $object = Class::Inner->new(
|
|
19 |
parent => 'ParentClass',
|
|
20 |
methods => { method => sub { ... } }, },
|
|
21 |
constructor => 'new',
|
|
22 |
args => [@constructor_args],
|
|
23 |
);
|
|
24 |
|
|
25 |
=head1 DESCRIPTION
|
|
26 |
|
|
27 |
Yet another implementation of an anonymous class with per object
|
|
28 |
overrideable methods, but with the added attraction of sort of working
|
|
29 |
dispatch to the parent class's method.
|
|
30 |
|
|
31 |
=head2 METHODS
|
|
32 |
|
|
33 |
=over 4
|
|
34 |
|
|
35 |
=item B<new HASH>
|
|
36 |
|
|
37 |
Takes a hash like argument list with the following keys.
|
|
38 |
|
|
39 |
=over 4
|
|
40 |
|
|
41 |
=item B<parent>
|
|
42 |
|
|
43 |
The name of the parent class. Note that you can only get single
|
|
44 |
inheritance with this or B<SUPER> won't work.
|
|
45 |
|
|
46 |
=item B<methods>
|
|
47 |
|
|
48 |
A hash, keys are method names, values are CODEREFs.
|
|
49 |
|
|
50 |
=item B<constructor>
|
|
51 |
|
|
52 |
The name of the constructor method. Defaults to 'new'.
|
|
53 |
|
|
54 |
=item B<args>
|
|
55 |
|
|
56 |
An anonymous array of arguments to pass to the constructor. Defaults
|
|
57 |
to an empty list.
|
|
58 |
|
|
59 |
=back
|
|
60 |
|
|
61 |
Returns an object in an 'anonymous' class which inherits from the
|
|
62 |
parent class. This anonymous class has a couple of 'extra' methods:
|
|
63 |
|
|
64 |
=over 4
|
|
65 |
|
|
66 |
=item B<SUPER>
|
|
67 |
|
|
68 |
If you were to pass something like
|
|
69 |
|
|
70 |
$obj = Class::Inner->new(
|
|
71 |
parent => 'Parent',
|
|
72 |
methods => { method => sub { ...; $self->SUPER::method(@_) } },
|
|
73 |
);
|
|
74 |
|
|
75 |
then C<$self-C<gt>SUPER::method> almost certainly wouldn't do what you expect,
|
|
76 |
so we provide the C<SUPER> method which dispatches to the parent
|
|
77 |
implementation of the current method. There seems to be no good way of
|
|
78 |
getting the full C<SUPER::> functionality, but I'm working on it.
|
|
79 |
|
|
80 |
=item B<DESTROY>
|
|
81 |
|
|
82 |
Because B<Class::Inner> works by creating a whole new class name for your
|
|
83 |
object, it could potentially leak memory if you create a lot of them. So we
|
|
84 |
add a C<DESTROY> method that removes the class from the symbol table once
|
|
85 |
it's finished with.
|
|
86 |
|
|
87 |
If you need to override a parent's DESTROY method, adding a call to
|
|
88 |
C<Class::Inner::clean_symbol_table(ref $self)> to it. Do it at the
|
|
89 |
end of the method or your other method calls won't work.
|
|
90 |
|
|
91 |
=back
|
|
92 |
|
|
93 |
=cut
|
|
94 |
|
|
95 |
#'
|
|
96 |
|
|
97 |
sub new {
|
|
98 |
my $class = shift;
|
|
99 |
my %args = ref($_[0]) ? %{$_[0]} : @_;
|
|
100 |
my $parent = $args{parent} or
|
|
101 |
croak "Can't work without a parent class\n";
|
|
102 |
my %methods = %{$args{methods}||{}};
|
|
103 |
my $constructor = $args{constructor} || 'new';
|
|
104 |
my @constructor_args = @{$args{args} || []};
|
|
105 |
|
|
106 |
my $anon_class = $class->new_classname;
|
|
107 |
|
|
108 |
no strict 'refs';
|
|
109 |
|
|
110 |
@{"$anon_class\::ISA"} = $parent;
|
|
111 |
|
|
112 |
foreach my $methodname (keys %methods) {
|
|
113 |
*{"$anon_class\::$methodname"} = sub {
|
|
114 |
local $Class::Inner::target_method = $methodname;
|
|
115 |
$methods{$methodname}->(@_);
|
|
116 |
};
|
|
117 |
}
|
|
118 |
|
|
119 |
# Add the SUPER method.
|
|
120 |
|
|
121 |
unless (exists $methods{SUPER}) {
|
|
122 |
*{"$anon_class\::SUPER"} = sub {
|
|
123 |
my $self = shift;
|
|
124 |
my $target_method =
|
|
125 |
join '::', $parent, $Class::Inner::target_method;
|
|
126 |
$self->$target_method(@_);
|
|
127 |
};
|
|
128 |
}
|
|
129 |
|
|
130 |
unless (exists $methods{DESTROY}) {
|
|
131 |
*{"$anon_class\::DESTROY"} = sub {
|
|
132 |
my $self = shift;
|
|
133 |
Class::Inner::clean_symbol_table($anon_class);
|
|
134 |
bless $self, $parent;
|
|
135 |
}
|
|
136 |
}
|
|
137 |
# Instantiate
|
|
138 |
my $obj = $anon_class->new(@constructor_args);
|
|
139 |
}
|
|
140 |
|
|
141 |
=item B<clean_symbol_table>
|
|
142 |
|
|
143 |
The helper subroutine that DESTROY uses to remove the class from the
|
|
144 |
symbol table.
|
|
145 |
|
|
146 |
=cut
|
|
147 |
|
|
148 |
sub clean_symbol_table {
|
|
149 |
my $class = shift;
|
|
150 |
no strict 'refs';
|
|
151 |
foreach my $symbol (keys %{"$class\::"}) {
|
|
152 |
delete ${"$class\::"}{$symbol};
|
|
153 |
}
|
|
154 |
delete $::{"$class\::"};
|
|
155 |
}
|
|
156 |
|
|
157 |
=item B<new_classname>
|
|
158 |
|
|
159 |
Returns a name for the next anonymous class.
|
|
160 |
|
|
161 |
=cut
|
|
162 |
|
|
163 |
{
|
|
164 |
my $class_counter;
|
|
165 |
|
|
166 |
sub new_classname {
|
|
167 |
my $baseclass = ref($_[0]) || $_[0];
|
|
168 |
return "$baseclass\::__A" . $class_counter++;
|
|
169 |
}
|
|
170 |
}
|
|
171 |
|
|
172 |
1;
|
|
173 |
__END__
|
|
174 |
|
|
175 |
=back
|
|
176 |
|
|
177 |
=head1 AUTHOR
|
|
178 |
|
|
179 |
Copyright (c) 2001 by Piers Cawley E<lt>pdcawley@iterative-software.comE<gt>.
|
|
180 |
|
|
181 |
All rights reserved. This program is free software; you can redistribute it
|
|
182 |
and/or modify it under the same terms as perl itself.
|
|
183 |
|
|
184 |
Thanks to the Iterative Software people: Leon Brocard, Natalie Ford and
|
|
185 |
Dave Cross. Also, this module was written initially for use in the
|
|
186 |
PerlUnit project, AKA Test::Unit. Kudos to Christian Lemburg and the rest
|
|
187 |
of that team.
|
|
188 |
|
|
189 |
=head1 SEE ALSO
|
|
190 |
|
|
191 |
There are a million and one differen Class constructors available on CPAN,
|
|
192 |
none of them does quite what I want, so I wrote this one to add to
|
|
193 |
that population where hopefully it will live and thrive.
|
|
194 |
|
|
195 |
=head1 BUGS
|
|
196 |
|
|
197 |
Bound to be some. Actually the C<SUPER> method is a workaround for what
|
|
198 |
I consider to be a bug in perl.
|