1=pod
2
3=head1 NAME
4
5Class::Mixin - API for aliasing methods to/from other classes
6
7=head1 OVERVIEW
8
9Class::Mixin provides a way to mix methods from one class into another,
10such that the target class can use both its methods as well as those
11of the source class.
12
13The primary advantage is that the behavior of a class can be modified
14to effectively be another class without changing any of the calling
15code -- just requires using the new class that mixes into the original.
16
17=head1 SYNOPSIS
18
19  # class1.pm
20  package class1;
21  sub sub1 { return 11 };
22  ...
23
24  # class2.pm
25  package class2;
26  use Class::Mixin to=> 'class1';
27  sub sub2 { return 22 };
28
29  # Original calling code
30  use class1;
31  print class1->sub1;  # 11
32  print class1->can('sub2');  # false
33
34  # Updated calling code
35  use class1;
36  use class2;	# performs the mixing-in
37  print class1->sub1;  # 11
38  print class1->can('sub2');  # true
39  print class1->sub2;  # 22  <-- note class1 now has the class2 method
40
41=head1 METHODS
42
43=cut
44
45#######################################################
46package Class::Mixin;
47use strict;
48
49use Symbol ();
50use Carp;
51use warnings::register;
52
53our $VERSION = '1.00';
54
55my %r = map { $_=> 1 } qw(
56	BEGIN
57	INIT
58	CHECK
59	END
60	DESTROY
61	AUTOLOAD
62	ISA
63
64	import
65	can
66	isa
67	ISA
68	STDIN
69	STDOUT
70	STDERR
71	ARGV
72	ARGVOUT
73	ENV
74	INC
75	SIG
76);
77
78sub __new {
79	return $Class::Mixin::OBJ if defined $Class::Mixin::OBJ;
80	$Class::Mixin::OBJ = bless {}, shift;
81	return $Class::Mixin::OBJ;
82}
83
84=pod
85
86=head2 import
87
88Method used when loading class to import symbols or perform
89some function.  In this case we take the calling classes methods
90and map them into the class passed in as a parameter.
91
92=over 2
93
94=item Input
95
96=over 2
97
98=item None
99
100=back
101
102=item Output
103
104None
105
106=back
107
108=cut
109
110sub import {
111	my $cl = shift;
112	return unless @_;
113	my $obj = Class::Mixin->__new;
114	my $p = { @_ };
115	Carp::croak q{Must mixin 'to' or 'from' something} unless exists $p->{to} || exists $p->{from};
116
117	my $class = caller;
118	if( exists $p->{to} ){
119	  $obj->{mixins}->{ $class   }->{ $p->{to} } ||= [];
120	}
121	if( exists $p->{from} ){
122	  $obj->{mixins}->{ $p->{from} }->{ $class } ||= [];
123	}
124}
125
126CHECK { resync() }
127
128=pod
129
130=head2 B<Destructor> DESTROY
131
132This modules uses a destructor for un-mixing methods.  This is done in
133the case that this module is unloaded for some reason.  It will return
134modules to their original states.
135
136=over 2
137
138=item Input
139
140=over 2
141
142=item *
143
144Class::Mixin object
145
146=back
147
148=item Output
149
150=over 2
151
152=item None
153
154=back
155
156=back
157
158=cut
159
160sub DESTROY {
161  my $obj = shift;
162	foreach my $mixin ( keys %{$obj->{mixins}} ) {
163	  foreach my $target ( keys %{$obj->{mixins}->{$mixin}} ) {
164	    foreach my $v ( @{ $obj->{mixins}->{$mixin}->{$target} } ){
165		no strict 'refs';
166		my $m = $v->{'method'};
167		my $c = $v->{'class'} . '::';
168		my $s = $v->{'symbol'};
169		*{ $s } = undef;
170		delete ${ $c }{ $m };
171		$s = undef;
172	    }
173	  }
174	}
175}
176
177=pod
178
179=head2 resync
180
181Function used to process registered 'mixins'.  Typically automatically
182called once immediately after program compilation.  Sometimes though you
183may want to call it manually if a modules is reloaded.
184
185=over 2
186
187=item Input
188
189=over 2
190
191=item None
192
193=back
194
195=item Output
196
197=over 2
198
199=item None
200
201=back
202
203=back
204
205=cut
206
207sub resync {
208	my $obj = Class::Mixin->__new;
209	my $class = caller;
210
211	foreach my $mixin ( keys %{$obj->{mixins}} ) {
212	  foreach my $target ( keys %{$obj->{mixins}->{$mixin}} ) {
213
214		my $mixinSym = $mixin . '::';
215		my $targetSym = $target . '::';
216
217		next if $class ne $mixin && !$class->isa( __PACKAGE__ );
218
219		no strict 'refs';
220
221		foreach my $method ( keys %$mixinSym ) {
222			if ( exists $r{ $method } ) {
223				warnings::warn "Unable to Mixin method '$method', restricted"
224					if warnings::enabled();
225			} elsif ( exists ${ $targetSym }{ $method } ) {
226				warnings::warn qq{
227Unable to Mixin method '$method'
228FROM $mixin
229TO $target
230already defined in $target
231} if warnings::enabled();
232			} else {
233				my $m = Symbol::qualify_to_ref( $method, $mixin );
234				my $t = Symbol::qualify_to_ref( $method, $target );
235				*{ $t } = *{ $m };
236
237				push @{ $obj->{mixins}->{$mixin}->{$target} }, {
238					class=>		$target,
239					method=>	$method,
240					symbol=>	$t,
241				};
242			}
243		}
244
245	  }
246	}
247}
248
2491;
250
251__END__
252
253=pod
254
255=head1 AUTHORS
256
257=over 2
258
259=item *
260
261Stathy G. Touloumis <stathy@stathy.com>
262
263=item *
264
265David Westbrook <dwestbrook@gmail.com>
266
267=back
268
269
270=head1 BUGS
271
272Please report any bugs or feature requests to C<bug-class-mixin at rt.cpan.org>, or through
273the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Class-Mixin>.  I will be notified, and then you'll
274automatically be notified of progress on your bug as I make changes.
275
276
277
278
279=head1 SUPPORT
280
281You can find documentation for this module with the perldoc command.
282
283    perldoc Class::Mixin
284
285
286You can also look for information at:
287
288=over 4
289
290=item * RT: CPAN's request tracker
291
292L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Mixin>
293
294=item * AnnoCPAN: Annotated CPAN documentation
295
296L<http://annocpan.org/dist/Class-Mixin>
297
298=item * CPAN Ratings
299
300L<http://cpanratings.perl.org/d/Class-Mixin>
301
302=item * Search CPAN
303
304L<http://search.cpan.org/dist/Class-Mixin>
305
306=back
307
308=head1 COPYRIGHT AND LICENSE
309
310Copyright (C) 2003-2008 Stathy G. Touloumis
311
312This is free software; you can redistribute it and/or modify it under
313the same terms as Perl itself.
314
315=cut
316
317