2 package Class::MOP::Class;
8 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
10 use B 'svref_2object';
12 our $VERSION = '0.06';
16 sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
21 # Metaclasses are singletons, so we cache them here.
22 # there is no need to worry about destruction though
23 # because they should die only when the program dies.
24 # After all, do package definitions even get reaped?
29 my $package_name = shift;
30 (defined $package_name && $package_name && !blessed($package_name))
31 || confess "You must pass a package name and it cannot be blessed";
32 $class->construct_class_instance(':package' => $package_name, @_);
35 # NOTE: (meta-circularity)
36 # this is a special form of &construct_instance
37 # (see below), which is used to construct class
38 # meta-object instances for any Class::MOP::*
39 # class. All other classes will use the more
40 # normal &construct_instance.
41 sub construct_class_instance {
44 my $package_name = $options{':package'};
45 (defined $package_name && $package_name)
46 || confess "You must pass a package name";
47 return $METAS{$package_name} if exists $METAS{$package_name};
48 $class = blessed($class) || $class;
49 # now create the metaclass
51 if ($class =~ /^Class::MOP::/) {
53 '$:package' => $package_name,
55 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
56 '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method',
61 # it is safe to use meta here because
62 # class will always be a subclass of
63 # Class::MOP::Class, which defines meta
64 $meta = bless $class->meta->construct_instance(%options) => $class
66 # and check the metaclass compatibility
67 $meta->check_metaclass_compatability();
68 $METAS{$package_name} = $meta;
71 sub check_metaclass_compatability {
74 # this is always okay ...
75 return if blessed($self) eq 'Class::MOP::Class';
77 my @class_list = $self->class_precedence_list;
78 shift @class_list; # shift off $self->name
80 foreach my $class_name (@class_list) {
81 my $meta = $METAS{$class_name};
82 ($self->isa(blessed($meta)))
83 || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
84 " is not compatible with the " .
85 $class_name . "->meta => (" . (blessed($meta)) . ")";
91 my ($class, $package_name, $package_version, %options) = @_;
92 (defined $package_name && $package_name)
93 || confess "You must pass a package name";
94 my $code = "package $package_name;";
95 $code .= "\$$package_name\:\:VERSION = '$package_version';"
96 if defined $package_version;
98 confess "creation of $package_name failed : $@" if $@;
99 my $meta = $class->initialize($package_name);
101 $meta->add_method('meta' => sub {
102 Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
105 $meta->superclasses(@{$options{superclasses}})
106 if exists $options{superclasses};
108 # process attributes first, so that they can
109 # install accessors, but locally defined methods
110 # can then overwrite them. It is maybe a little odd, but
111 # I think this should be the order of things.
112 if (exists $options{attributes}) {
113 foreach my $attr (@{$options{attributes}}) {
114 $meta->add_attribute($attr);
117 if (exists $options{methods}) {
118 foreach my $method_name (keys %{$options{methods}}) {
119 $meta->add_method($method_name, $options{methods}->{$method_name});
128 # all these attribute readers will be bootstrapped
129 # away in the Class::MOP bootstrap section
131 sub name { $_[0]->{'$:package'} }
132 sub get_attribute_map { $_[0]->{'%:attributes'} }
133 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
134 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
136 # Instance Construction & Cloning
141 # we need to protect the integrity of the
142 # Class::MOP::Class singletons here, so we
143 # delegate this to &construct_class_instance
144 # which will deal with the singletons
145 return $class->construct_class_instance(@_)
146 if $class->name->isa('Class::MOP::Class');
147 bless $class->construct_instance(@_) => $class->name;
150 sub construct_instance {
151 my ($class, %params) = @_;
153 foreach my $attr ($class->compute_all_applicable_attributes()) {
154 my $init_arg = $attr->init_arg();
155 # try to fetch the init arg from the %params ...
157 $val = $params{$init_arg} if exists $params{$init_arg};
158 # if nothing was in the %params, we can use the
159 # attribute's default value (if it has one)
160 $val ||= $attr->default($instance) if $attr->has_default();
161 $instance->{$attr->name} = $val;
168 my $instance = shift;
169 (blessed($instance) && $instance->isa($class->name))
170 || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
172 # we need to protect the integrity of the
173 # Class::MOP::Class singletons here, they
174 # should not be cloned.
175 return $instance if $instance->isa('Class::MOP::Class');
176 bless $class->clone_instance($instance, @_) => blessed($instance);
180 my ($class, $instance, %params) = @_;
182 || confess "You can only clone instances, \$self is not a blessed instance";
183 my $clone = { %$instance, %params };
189 # &name should be here too, but it is above
190 # because it gets bootstrapped away
195 ${$self->name . '::VERSION'};
205 @{$self->name . '::ISA'} = @supers;
207 @{$self->name . '::ISA'};
210 sub class_precedence_list {
213 # We need to check for ciruclar inheirtance here.
214 # This will do nothing if all is well, and blow
215 # up otherwise. Yes, it's an ugly hack, better
216 # suggestions are welcome.
217 { $self->name->isa('This is a test for circular inheritance') }
218 # ... and no back to our regularly scheduled program
222 $self->initialize($_)->class_precedence_list()
223 } $self->superclasses()
230 my ($self, $method_name, $method) = @_;
231 (defined $method_name && $method_name)
232 || confess "You must define a method name";
233 # use reftype here to allow for blessed subs ...
234 (reftype($method) && reftype($method) eq 'CODE')
235 || confess "Your code block must be a CODE reference";
236 my $full_method_name = ($self->name . '::' . $method_name);
239 no warnings 'redefine';
240 *{$full_method_name} = subname $full_method_name => $method;
244 my ($self, $method_name, $method) = @_;
245 (defined $method_name && $method_name)
246 || confess "You must define a method name";
247 # use reftype here to allow for blessed subs ...
248 (reftype($method) && reftype($method) eq 'CODE')
249 || confess "Your code block must be a CODE reference";
250 my $full_method_name = ($self->name . '::' . $method_name);
253 no warnings 'redefine';
254 *{$full_method_name} = $method;
259 ## private utility functions for has_method
260 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
261 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
264 my ($self, $method_name) = @_;
265 (defined $method_name && $method_name)
266 || confess "You must define a method name";
268 my $sub_name = ($self->name . '::' . $method_name);
271 return 0 if !defined(&{$sub_name});
272 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
273 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
280 my ($self, $method_name) = @_;
281 (defined $method_name && $method_name)
282 || confess "You must define a method name";
285 return \&{$self->name . '::' . $method_name}
286 if $self->has_method($method_name);
287 return; # <- make sure to return undef
291 my ($self, $method_name) = @_;
292 (defined $method_name && $method_name)
293 || confess "You must define a method name";
295 my $removed_method = $self->get_method($method_name);
298 delete ${$self->name . '::'}{$method_name}
299 if defined $removed_method;
301 return $removed_method;
304 sub get_method_list {
307 grep { $self->has_method($_) } %{$self->name . '::'};
310 sub compute_all_applicable_methods {
313 # keep a record of what we have seen
314 # here, this will handle all the
315 # inheritence issues because we are
316 # using the &class_precedence_list
317 my (%seen_class, %seen_method);
318 foreach my $class ($self->class_precedence_list()) {
319 next if $seen_class{$class};
320 $seen_class{$class}++;
321 # fetch the meta-class ...
322 my $meta = $self->initialize($class);
323 foreach my $method_name ($meta->get_method_list()) {
324 next if exists $seen_method{$method_name};
325 $seen_method{$method_name}++;
327 name => $method_name,
329 code => $meta->get_method($method_name)
336 sub find_all_methods_by_name {
337 my ($self, $method_name) = @_;
338 (defined $method_name && $method_name)
339 || confess "You must define a method name to find";
341 # keep a record of what we have seen
342 # here, this will handle all the
343 # inheritence issues because we are
344 # using the &class_precedence_list
346 foreach my $class ($self->class_precedence_list()) {
347 next if $seen_class{$class};
348 $seen_class{$class}++;
349 # fetch the meta-class ...
350 my $meta = $self->initialize($class);;
352 name => $method_name,
354 code => $meta->get_method($method_name)
355 } if $meta->has_method($method_name);
365 # either we have an attribute object already
366 # or we need to create one from the args provided
367 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
368 # make sure it is derived from the correct type though
369 ($attribute->isa('Class::MOP::Attribute'))
370 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
371 $attribute->attach_to_class($self);
372 $attribute->install_accessors();
373 $self->get_attribute_map->{$attribute->name} = $attribute;
377 my ($self, $attribute_name) = @_;
378 (defined $attribute_name && $attribute_name)
379 || confess "You must define an attribute name";
380 exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
384 my ($self, $attribute_name) = @_;
385 (defined $attribute_name && $attribute_name)
386 || confess "You must define an attribute name";
387 return $self->get_attribute_map->{$attribute_name}
388 if $self->has_attribute($attribute_name);
392 sub remove_attribute {
393 my ($self, $attribute_name) = @_;
394 (defined $attribute_name && $attribute_name)
395 || confess "You must define an attribute name";
396 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
397 return unless defined $removed_attribute;
398 delete $self->get_attribute_map->{$attribute_name};
399 $removed_attribute->remove_accessors();
400 $removed_attribute->detach_from_class();
401 return $removed_attribute;
404 sub get_attribute_list {
406 keys %{$self->get_attribute_map};
409 sub compute_all_applicable_attributes {
412 # keep a record of what we have seen
413 # here, this will handle all the
414 # inheritence issues because we are
415 # using the &class_precedence_list
416 my (%seen_class, %seen_attr);
417 foreach my $class ($self->class_precedence_list()) {
418 next if $seen_class{$class};
419 $seen_class{$class}++;
420 # fetch the meta-class ...
421 my $meta = $self->initialize($class);
422 foreach my $attr_name ($meta->get_attribute_list()) {
423 next if exists $seen_attr{$attr_name};
424 $seen_attr{$attr_name}++;
425 push @attrs => $meta->get_attribute($attr_name);
433 sub add_package_variable {
434 my ($self, $variable, $initial_value) = @_;
435 (defined $variable && $variable =~ /^[\$\@\%]/)
436 || confess "variable name does not have a sigil";
438 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
439 if (defined $initial_value) {
441 *{$self->name . '::' . $name} = $initial_value;
444 eval $sigil . $self->name . '::' . $name;
445 confess "Could not create package variable ($variable) because : $@" if $@;
449 sub has_package_variable {
450 my ($self, $variable) = @_;
451 (defined $variable && $variable =~ /^[\$\@\%]/)
452 || confess "variable name does not have a sigil";
453 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
455 defined ${$self->name . '::'}{$name} ? 1 : 0;
458 sub get_package_variable {
459 my ($self, $variable) = @_;
460 (defined $variable && $variable =~ /^[\$\@\%]/)
461 || confess "variable name does not have a sigil";
462 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
464 # try to fetch it first,.. see what happens
465 my $ref = eval '\\' . $sigil . $self->name . '::' . $name;
466 confess "Could not get the package variable ($variable) because : $@" if $@;
467 # if we didn't die, then we can return it
471 sub remove_package_variable {
472 my ($self, $variable) = @_;
473 (defined $variable && $variable =~ /^[\$\@\%]/)
474 || confess "variable name does not have a sigil";
475 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
477 delete ${$self->name . '::'}{$name};
488 Class::MOP::Class - Class Meta Object
492 # use this for introspection ...
494 # add a method to Foo ...
495 Foo->meta->add_method('bar' => sub { ... })
497 # get a list of all the classes searched
498 # the method dispatcher in the correct order
499 Foo->meta->class_precedence_list()
501 # remove a method from Foo
502 Foo->meta->remove_method('bar');
504 # or use this to actually create classes ...
506 Class::MOP::Class->create('Bar' => '0.01' => (
507 superclasses => [ 'Foo' ],
509 Class::MOP:::Attribute->new('$bar'),
510 Class::MOP:::Attribute->new('$baz'),
513 calculate_bar => sub { ... },
514 construct_baz => sub { ... }
520 This is the largest and currently most complex part of the Perl 5
521 meta-object protocol. It controls the introspection and
522 manipulation of Perl 5 classes (and it can create them too). The
523 best way to understand what this module can do, is to read the
524 documentation for each of it's methods.
528 =head2 Self Introspection
534 This will return a B<Class::MOP::Class> instance which is related
535 to this class. Thereby allowing B<Class::MOP::Class> to actually
538 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
539 bootstrap this module by installing a number of attribute meta-objects
540 into it's metaclass. This will allow this class to reap all the benifits
541 of the MOP when subclassing it.
545 =head2 Class construction
547 These methods will handle creating B<Class::MOP::Class> objects,
548 which can be used to both create new classes, and analyze
549 pre-existing classes.
551 This module will internally store references to all the instances
552 you create with these methods, so that they do not need to be
553 created any more than nessecary. Basically, they are singletons.
557 =item B<create ($package_name, ?$package_version,
558 superclasses =E<gt> ?@superclasses,
559 methods =E<gt> ?%methods,
560 attributes =E<gt> ?%attributes)>
562 This returns a B<Class::MOP::Class> object, bringing the specified
563 C<$package_name> into existence and adding any of the
564 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
567 =item B<initialize ($package_name)>
569 This initializes and returns returns a B<Class::MOP::Class> object
570 for a given a C<$package_name>.
572 =item B<construct_class_instance (%options)>
574 This will construct an instance of B<Class::MOP::Class>, it is
575 here so that we can actually "tie the knot" for B<Class::MOP::Class>
576 to use C<construct_instance> once all the bootstrapping is done. This
577 method is used internally by C<initialize> and should never be called
578 from outside of that method really.
580 =item B<check_metaclass_compatability>
582 This method is called as the very last thing in the
583 C<construct_class_instance> method. This will check that the
584 metaclass you are creating is compatible with the metaclasses of all
585 your ancestors. For more inforamtion about metaclass compatibility
586 see the C<About Metaclass compatibility> section in L<Class::MOP>.
590 =head2 Object instance construction and cloning
592 These methods are B<entirely optional>, it is up to you whether you want
597 =item B<new_object (%params)>
599 This is a convience method for creating a new object of the class, and
600 blessing it into the appropriate package as well. Ideally your class
601 would call a C<new> this method like so:
604 my ($class, %param) = @_;
605 $class->meta->new_object(%params);
608 Of course the ideal place for this would actually be in C<UNIVERSAL::>
609 but that is considered bad style, so we do not do that.
611 =item B<construct_instance (%params)>
613 This method is used to construct an instace structure suitable for
614 C<bless>-ing into your package of choice. It works in conjunction
615 with the Attribute protocol to collect all applicable attributes.
617 This will construct and instance using a HASH ref as storage
618 (currently only HASH references are supported). This will collect all
619 the applicable attributes and layout out the fields in the HASH ref,
620 it will then initialize them using either use the corresponding key
621 in C<%params> or any default value or initializer found in the
622 attribute meta-object.
624 =item B<clone_object ($instance, %params)>
626 This is a convience method for cloning an object instance, then
627 blessing it into the appropriate package. This method will call
628 C<clone_instance>, which performs a shallow copy of the object,
629 see that methods documentation for more details. Ideally your
630 class would call a C<clone> this method like so:
633 my ($self, %param) = @_;
634 $self->meta->clone_object($self, %params);
637 Of course the ideal place for this would actually be in C<UNIVERSAL::>
638 but that is considered bad style, so we do not do that.
640 =item B<clone_instance($instance, %params)>
642 This method is a compliment of C<construct_instance> (which means if
643 you override C<construct_instance>, you need to override this one too),
644 and clones the instance shallowly.
646 The cloned structure returned is (like with C<construct_instance>) an
647 unC<bless>ed HASH reference, it is your responsibility to then bless
648 this cloned structure into the right class (which C<clone_object> will
651 As of 0.11, this method will clone the C<$instance> structure shallowly,
652 as opposed to the deep cloning implemented in prior versions. After much
653 thought, research and discussion, I have decided that anything but basic
654 shallow cloning is outside the scope of the meta-object protocol. I
655 think Yuval "nothingmuch" Kogman put it best when he said that cloning
656 is too I<context-specific> to be part of the MOP.
666 This is a read-only attribute which returns the package name for the
667 given B<Class::MOP::Class> instance.
671 This is a read-only attribute which returns the C<$VERSION> of the
672 package for the given B<Class::MOP::Class> instance.
676 =head2 Inheritance Relationships
680 =item B<superclasses (?@superclasses)>
682 This is a read-write attribute which represents the superclass
683 relationships of the class the B<Class::MOP::Class> instance is
684 associated with. Basically, it can get and set the C<@ISA> for you.
687 Perl will occasionally perform some C<@ISA> and method caching, if
688 you decide to change your superclass relationship at runtime (which
689 is quite insane and very much not recommened), then you should be
690 aware of this and the fact that this module does not make any
691 attempt to address this issue.
693 =item B<class_precedence_list>
695 This computes the a list of all the class's ancestors in the same order
696 in which method dispatch will be done. This is similair to
697 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
705 =item B<method_metaclass>
707 =item B<add_method ($method_name, $method)>
709 This will take a C<$method_name> and CODE reference to that
710 C<$method> and install it into the class's package.
713 This does absolutely nothing special to C<$method>
714 other than use B<Sub::Name> to make sure it is tagged with the
715 correct name, and therefore show up correctly in stack traces and
718 =item B<alias_method ($method_name, $method)>
720 This will take a C<$method_name> and CODE reference to that
721 C<$method> and alias the method into the class's package.
724 Unlike C<add_method>, this will B<not> try to name the
725 C<$method> using B<Sub::Name>, it only aliases the method in
728 =item B<has_method ($method_name)>
730 This just provides a simple way to check if the class implements
731 a specific C<$method_name>. It will I<not> however, attempt to check
732 if the class inherits the method (use C<UNIVERSAL::can> for that).
734 This will correctly handle functions defined outside of the package
735 that use a fully qualified name (C<sub Package::name { ... }>).
737 This will correctly handle functions renamed with B<Sub::Name> and
738 installed using the symbol tables. However, if you are naming the
739 subroutine outside of the package scope, you must use the fully
740 qualified name, including the package name, for C<has_method> to
741 correctly identify it.
743 This will attempt to correctly ignore functions imported from other
744 packages using B<Exporter>. It breaks down if the function imported
745 is an C<__ANON__> sub (such as with C<use constant>), which very well
746 may be a valid method being applied to the class.
748 In short, this method cannot always be trusted to determine if the
749 C<$method_name> is actually a method. However, it will DWIM about
750 90% of the time, so it's a small trade off I think.
752 =item B<get_method ($method_name)>
754 This will return a CODE reference of the specified C<$method_name>,
755 or return undef if that method does not exist.
757 =item B<remove_method ($method_name)>
759 This will attempt to remove a given C<$method_name> from the class.
760 It will return the CODE reference that it has removed, and will
761 attempt to use B<Sub::Name> to clear the methods associated name.
763 =item B<get_method_list>
765 This will return a list of method names for all I<locally> defined
766 methods. It does B<not> provide a list of all applicable methods,
767 including any inherited ones. If you want a list of all applicable
768 methods, use the C<compute_all_applicable_methods> method.
770 =item B<compute_all_applicable_methods>
772 This will return a list of all the methods names this class will
773 respond to, taking into account inheritance. The list will be a list of
774 HASH references, each one containing the following information; method
775 name, the name of the class in which the method lives and a CODE
776 reference for the actual method.
778 =item B<find_all_methods_by_name ($method_name)>
780 This will traverse the inheritence hierarchy and locate all methods
781 with a given C<$method_name>. Similar to
782 C<compute_all_applicable_methods> it returns a list of HASH references
783 with the following information; method name (which will always be the
784 same as C<$method_name>), the name of the class in which the method
785 lives and a CODE reference for the actual method.
787 The list of methods produced is a distinct list, meaning there are no
788 duplicates in it. This is especially useful for things like object
789 initialization and destruction where you only want the method called
790 once, and in the correct order.
796 It should be noted that since there is no one consistent way to define
797 the attributes of a class in Perl 5. These methods can only work with
798 the information given, and can not easily discover information on
799 their own. See L<Class::MOP::Attribute> for more details.
803 =item B<attribute_metaclass>
805 =item B<get_attribute_map>
807 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
809 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
810 instance associated with the given class, and associates it with
811 the C<$attribute_name>. Unlike methods, attributes within the MOP
812 are stored as meta-information only. They will be used later to
813 construct instances from (see C<construct_instance> above).
814 More details about the attribute meta-objects can be found in the
815 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
818 It should be noted that any accessor, reader/writer or predicate
819 methods which the C<$attribute_meta_object> has will be installed
820 into the class at this time.
822 =item B<has_attribute ($attribute_name)>
824 Checks to see if this class has an attribute by the name of
825 C<$attribute_name> and returns a boolean.
827 =item B<get_attribute ($attribute_name)>
829 Returns the attribute meta-object associated with C<$attribute_name>,
830 if none is found, it will return undef.
832 =item B<remove_attribute ($attribute_name)>
834 This will remove the attribute meta-object stored at
835 C<$attribute_name>, then return the removed attribute meta-object.
838 Removing an attribute will only affect future instances of
839 the class, it will not make any attempt to remove the attribute from
840 any existing instances of the class.
842 It should be noted that any accessor, reader/writer or predicate
843 methods which the attribute meta-object stored at C<$attribute_name>
844 has will be removed from the class at this time. This B<will> make
845 these attributes somewhat inaccessable in previously created
846 instances. But if you are crazy enough to do this at runtime, then
847 you are crazy enough to deal with something like this :).
849 =item B<get_attribute_list>
851 This returns a list of attribute names which are defined in the local
852 class. If you want a list of all applicable attributes for a class,
853 use the C<compute_all_applicable_attributes> method.
855 =item B<compute_all_applicable_attributes>
857 This will traverse the inheritance heirachy and return a list of all
858 the applicable attributes for this class. It does not construct a
859 HASH reference like C<compute_all_applicable_methods> because all
860 that same information is discoverable through the attribute
865 =head2 Package Variables
867 Since Perl's classes are built atop the Perl package system, it is
868 fairly common to use package scoped variables for things like static
869 class variables. The following methods are convience methods for
870 the creation and inspection of package scoped variables.
874 =item B<add_package_variable ($variable_name, ?$initial_value)>
876 Given a C<$variable_name>, which must contain a leading sigil, this
877 method will create that variable within the package which houses the
878 class. It also takes an optional C<$initial_value>, which must be a
879 reference of the same type as the sigil of the C<$variable_name>
882 =item B<get_package_variable ($variable_name)>
884 This will return a reference to the package variable in
887 =item B<has_package_variable ($variable_name)>
889 Returns true (C<1>) if there is a package variable defined for
890 C<$variable_name>, and false (C<0>) otherwise.
892 =item B<remove_package_variable ($variable_name)>
894 This will attempt to remove the package variable at C<$variable_name>.
900 Stevan Little E<lt>stevan@iinteractive.comE<gt>
902 =head1 COPYRIGHT AND LICENSE
904 Copyright 2006 by Infinity Interactive, Inc.
906 L<http://www.iinteractive.com>
908 This library is free software; you can redistribute it and/or modify
909 it under the same terms as Perl itself.