1
2package Class::Interfaces;
3
4use strict;
5use warnings;
6
7our $VERSION = '0.04';
8
9sub import {
10    my $class = shift;
11    my %interfaces = @_;
12    foreach my $interface (keys %interfaces) {
13        # build the interface
14        my (@methods, @subclasses);
15        if (ref($interfaces{$interface}) eq 'HASH') {
16            my $interface_spec = $interfaces{$interface};
17            # if we have an isa
18            if (exists ${$interface_spec}{isa}) {
19                # if is an array (multiple inheritance)
20                if (ref($interface_spec->{isa}) eq 'ARRAY') {
21                    @subclasses = @{$interface_spec->{isa}};
22                }
23                else {
24                    # if its another kind of ref, its an error
25                    (!ref($interface_spec->{isa}))
26                        || $class->_error_handler("Interface ($interface) isa list must be an array reference");
27                    # otherwise its just a single item
28                    @subclasses = $interface_spec->{isa};
29                }
30            }
31            if (exists ${$interface_spec}{methods}) {
32                (ref($interface_spec->{methods}) eq 'ARRAY')
33                    || $class->_error_handler("Method list for Interface ($interface) must be an array reference");
34                @methods = @{$interface_spec->{methods}};
35            }
36        }
37        elsif (ref($interfaces{$interface}) eq 'ARRAY') {
38            @methods = @{$interfaces{$interface}};
39        }
40        elsif (!defined($interfaces{$interface})) {
41            # allow undefined here, this indicates an empty
42            # interface, sometimes called a marker interface
43            ;
44        }
45        else {
46            $class->_error_handler("Cannot use a " . $interfaces{$interface} . " to build an interface");
47        }
48        # now create the interfaces
49        my $package = $class->_build_interface_package($interface, @subclasses);
50        eval $package;
51        $class->_error_handler("Could not create Interface ($interface) because", $@) if $@;
52        eval {
53            my $method_stub = $class->can('_method_stub');
54            no strict 'refs';
55            # without at least this VERSION declaration
56            # a Marker interface will not work with
57            # 'use base' basically it would complain
58            # that the package is empty.
59            # we only assign this if the VERSION is already
60            # empty too, so we don't step on any customizations
61            # done in subclasses.
62            ${"${interface}::"}{VERSION} ||= -1;
63            # now we create all our methods :)
64            foreach my $method (@methods) {
65                ($method !~ /^(BEGIN|INIT|CHECK|END|DESTORY|AUTOLOAD|import|bootstrap)$/)
66                    || $class->_error_handler("Cannot create an interface using reserved perl methods");
67                *{"${interface}::${method}"} = $method_stub;
68            }
69        };
70        $class->_error_handler("Could not create sub methods for Interface ($interface) because", $@) if $@;
71    }
72}
73
74sub _build_interface_package {
75    my ($class, $interface, @subclasses) = @_;
76    my $package = "package $interface;";
77    $package .= "\@${interface}::ISA = qw(" . (join " " => @subclasses) . ");" if @subclasses;
78    return $package;
79}
80
81sub _error_handler {
82    my ($class, $message, $sub_exception) = @_;
83    die "$message : $sub_exception" if $sub_exception;
84    die "$message";
85}
86
87sub _method_stub { die "Method Not Implemented" }
88
891;
90
91__END__
92
93=head1 NAME
94
95Class::Interfaces - A module for defining interface classes inline
96
97=head1 SYNOPSIS
98
99  # define some simple interfaces
100  use Class::Interfaces (
101      Serializable => [ 'pack', 'unpack' ],
102      Printable    => [ 'toString' ],
103      Iterable     => [ 'iterator' ],
104      Iterator     => [ 'hasNext', 'next' ]
105      );
106
107  # or some more complex ones ...
108
109  # interface can also inherit from
110  # other interfaces using this form
111  use Class::Interfaces (
112      BiDirectionalIterator => {
113          isa     => 'Iterator',
114          methods => [ 'hasPrev', 'prev' ]
115          },
116      ResetableIterator => {
117          isa     => 'Iterator',
118          methods => [ 'reset' ]
119          },
120      # we even support multiple inheritance
121      ResetableBiDirectionalIterator => {
122          isa => [ 'ResetableIterator', 'BiDirectionalIterator' ]
123          }
124      );
125
126  # it is also possible to create an
127  # empty interface, sometimes called
128  # a marker interface
129  use Class::Interfaces (
130      JustAMarker => undef
131      );
132
133=head1 DESCRIPTION
134
135This module provides a simple means to define abstract class interfaces, which can be used to program using the concepts of interface polymorphism.
136
137=head2 Interface Polymorphism
138
139Interface polymorphism is a very powerful concept in object oriented programming. The concept is that if a class I<implements> a given interface it is expected to follow the guidelines set down by that interface. This in essence is a contract between the implementing class an all other classes, which says that it will provide correct implementations of the interface's abstract methods. Through this, it then becomes possible to treat an instance of an implementing class according to the interface and not need to know much of anything about the actual class itself. This can lead to highly generic code which is able to work with a wide range of virtually arbitrary classes just by using the methods of the certain interface which the class implements. Here is an example, using the interfaces from the L<SYNOPSIS> section:
140
141  eval {
142      my $list = get_list();
143      $list->isa('Iterable') || die "Unable to process $list : is not an Iterable object";
144      my $iterator = $list->iterator();
145      $iterator->isa('Iterator') || die "Unrecognized iterator type : $iterator";
146      while ($iterator->hasNext()) {
147          my $current = $iterator->next();
148          if ($current->isa('Serializable')) {
149              store_into_database($current->pack());
150          }
151          elsif ($current->isa('Printable')) {
152              store_into_database($current->toString());
153          }
154          else {
155              die "Unable to store $current into database : unrecognized object type";
156          }
157      }
158  };
159  if ($@) {
160      # ... do something with the exception
161  }
162
163Now, this may seem like there is a lot of manual type checking, branching and error handling, this is due to perl's object type system. Some say that perl is a strongly typed langugage because a SCALAR cannot be converted (cast) as an ARRAY, and conversions to a HASH can only be done in limited circumstances. Perl enforces these rules at both compile and run time. However, this strong typing breaks down when it comes to perl's object system. If we could enforce object types in the same way we can enforce SCALAR, ARRAY and HASH types, then the above code would need less manual type checking and therefore less branching and error handling. For instance, below is a java-esque example of the same code, showing how type checking would simplify things.
164
165  Iterable list = get_list();
166  Iterator iterator = list.iterator();
167  while (iterator.hasNext()) {
168      try {
169          store_into_database(iterator.next());
170      }
171      catch (Exception e) {
172          // ... do something with the exception
173      }
174  }
175
176  void store_into_database (Serializable current) { ... }
177  void store_into_database (Printable current) { ... }
178
179While the java-esque example is much shorter, it is really doing the same thing, just all the type checking and error handling is performed by the language itself. But the power of the concept of interface polymorphism is not lost.
180
181=head2 Subclassing Class::Interfaces
182
183For the most part, you will never need to subclass Class::Interfaces since it's default behavior will most likley be sufficient for most class stub generating needs. However, it is now possible (as of 0.02) to subclass Class::Interfaces and customize some of it's behavior. Below in the L<CLASS METHODS> section, you will find a list of methods which you can override in your Class::Interfaces subclass and therefore customize how your interfaces are built.
184
185=head1 INTERFACE
186
187Class::Interfaces is interacted with through the C<use> interface. It expects a hash of interface descriptors in the following formats.
188
189=over 4
190
191=item E<lt>I<interface name>E<gt> =E<gt> [ E<lt>list of method namesE<gt> ]
192
193An interface can be simply described as either an ARRAY reference containing method labels as strings, or as C<undef> for empty (marker) interfaces.
194
195=item E<lt>I<interface name>E<gt> =E<gt> { E<lt>interface descriptionE<gt> }
196
197Another option is to use the HASH reference, which can support the following key value pair formats.
198
199=over 4
200
201=item isa =E<gt> E<lt>super interfaceE<gt>
202
203An interface can inherit from another interface by assigning an interface name (as a string) as the value of the C<isa> key.
204
205=item isa =E<gt> [ E<lt>list of super interfacesE<gt> ]
206
207Or an interface can inherit from multiple interfaces by assigning an ARRAY reference of interface names (as strings) as the value of the C<isa> key.
208
209=item methods =E<gt> [ E<lt>list of method namesE<gt> ]
210
211An interface can define it's method labels as an ARRAY reference containing string as the value of the C<methods> key.
212
213=back
214
215Obviously only one form of the C<isa> key can be used at a time (as the second would cancel first out), but you can use any other combination of C<isa> and C<methods> with this format.
216
217=back
218
219=head1 CLASS METHODS
220
221The following methods are class methods, which if you like, can be overriden by a subclass of Class::Interfaces. This can be used to customize the building of interfaces for your specific needs.
222
223=over
224
225=item B<_build_interface_package ($class, $interface, @subclasses)>
226
227This method is used to construct a the interface package itself, it just creates and returns a string which Class::Interfaces will then C<eval> into being.
228
229This method can be customized to do any number of things, such as; add a specified namespace prefix onto the C<$interface> name, add additional classes into the C<@subclasses> list, basically preprocess any of the arguments in any number of ways.
230
231=item B<_error_handler ($class, $message, $sub_exception)>
232
233All errors which might happen during class generation are sent through this routine. The main use of this is if your application is excepting object-based exceptions and not just string-based exceptions, you can customize this to do that for you.
234
235=item B<_method_stub ($class)>
236
237When a method is created in the interface, it is given a default implementation (or stub). This usually will die with the string "Method Not Implemented", however, this may not always be what you want it to do.
238
239This can be used much like C<_error_handler> in that you can make it throw an object-based exception if that is what you application expects. But it can also be used to log missing methods, or to not do anything and just allow things to fail silently too. It is all dependent upon your needs.
240
241=back
242
243=head1 TO DO
244
245The documentation needs some work.
246
247=head1 BUGS
248
249None that I am aware of. Of course, if you find a bug, let me know, and I will be sure to fix it.
250
251=head1 CODE COVERAGE
252
253I use B<Devel::Cover> to test the code coverage of my tests, below is the B<Devel::Cover> report on this module test suite.
254
255 ---------------------------- ------ ------ ------ ------ ------ ------ ------
256 File                           stmt branch   cond    sub    pod   time  total
257 ---------------------------- ------ ------ ------ ------ ------ ------ ------
258 Class/Interfaces.pm           100.0  100.0   50.0  100.0    n/a  100.0   98.9
259 ---------------------------- ------ ------ ------ ------ ------ ------ ------
260 Total                         100.0  100.0   50.0  100.0    n/a  100.0   98.9
261 ---------------------------- ------ ------ ------ ------ ------ ------ ------
262
263=head1 SEE ALSO
264
265=over 4
266
267=item L<Object::Interface>
268
269=item L<interface>
270
271=back
272
273=head1 ACKNOWLEDGEMENTS
274
275=over 4
276
277=item Thanks for Matthew Simon Cavalletto for pointing out a problem with a reg-exp and for suggestions on the documentation.
278
279=back
280
281=head1 AUTHOR
282
283stevan little, E<lt>stevan@iinteractive.comE<gt>
284
285=head1 COPYRIGHT AND LICENSE
286
287Copyright 2004 by Infinity Interactive, Inc.
288
289L<http://www.iinteractive.com>
290
291This library is free software; you can redistribute it and/or modify
292it under the same terms as Perl itself.
293
294=cut
295
296