2 package Class::MOP::Class;
8 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
11 our $VERSION = '0.06';
15 sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
20 # Metaclasses are singletons, so we cache them here.
21 # there is no need to worry about destruction though
22 # because they should die only when the program dies.
23 # After all, do package definitions even get reaped?
28 my $package_name = shift;
29 (defined $package_name && $package_name && !blessed($package_name))
30 || confess "You must pass a package name and it cannot be blessed";
31 $class->construct_class_instance(':package' => $package_name, @_);
34 # NOTE: (meta-circularity)
35 # this is a special form of &construct_instance
36 # (see below), which is used to construct class
37 # meta-object instances for any Class::MOP::*
38 # class. All other classes will use the more
39 # normal &construct_instance.
40 sub construct_class_instance {
43 my $package_name = $options{':package'};
44 (defined $package_name && $package_name)
45 || confess "You must pass a package name";
46 return $METAS{$package_name} if exists $METAS{$package_name};
47 $class = blessed($class) || $class;
48 # now create the metaclass
50 if ($class =~ /^Class::MOP::/) {
52 '$:package' => $package_name,
54 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
55 '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method',
60 # it is safe to use meta here because
61 # class will always be a subclass of
62 # Class::MOP::Class, which defines meta
63 $meta = bless $class->meta->construct_instance(%options) => $class
65 # and check the metaclass compatibility
66 $meta->check_metaclass_compatability();
67 $METAS{$package_name} = $meta;
70 sub check_metaclass_compatability {
73 # this is always okay ...
74 return if blessed($self) eq 'Class::MOP::Class';
76 my @class_list = $self->class_precedence_list;
77 shift @class_list; # shift off $self->name
79 foreach my $class_name (@class_list) {
80 my $meta = $METAS{$class_name};
81 ($self->isa(blessed($meta)))
82 || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
83 " is not compatible with the " .
84 $class_name . "->meta => (" . (blessed($meta)) . ")";
90 my ($class, $package_name, $package_version, %options) = @_;
91 (defined $package_name && $package_name)
92 || confess "You must pass a package name";
93 my $code = "package $package_name;";
94 $code .= "\$$package_name\:\:VERSION = '$package_version';"
95 if defined $package_version;
97 confess "creation of $package_name failed : $@" if $@;
98 my $meta = $class->initialize($package_name);
100 $meta->add_method('meta' => sub {
101 Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
104 $meta->superclasses(@{$options{superclasses}})
105 if exists $options{superclasses};
107 # process attributes first, so that they can
108 # install accessors, but locally defined methods
109 # can then overwrite them. It is maybe a little odd, but
110 # I think this should be the order of things.
111 if (exists $options{attributes}) {
112 foreach my $attr (@{$options{attributes}}) {
113 $meta->add_attribute($attr);
116 if (exists $options{methods}) {
117 foreach my $method_name (keys %{$options{methods}}) {
118 $meta->add_method($method_name, $options{methods}->{$method_name});
127 # all these attribute readers will be bootstrapped
128 # away in the Class::MOP bootstrap section
130 sub name { $_[0]->{'$:package'} }
131 sub get_attribute_map { $_[0]->{'%:attributes'} }
132 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
133 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
135 # Instance Construction & Cloning
140 # we need to protect the integrity of the
141 # Class::MOP::Class singletons here, so we
142 # delegate this to &construct_class_instance
143 # which will deal with the singletons
144 return $class->construct_class_instance(@_)
145 if $class->name->isa('Class::MOP::Class');
146 bless $class->construct_instance(@_) => $class->name;
149 sub construct_instance {
150 my ($class, %params) = @_;
152 foreach my $attr ($class->compute_all_applicable_attributes()) {
153 my $init_arg = $attr->init_arg();
154 # try to fetch the init arg from the %params ...
156 $val = $params{$init_arg} if exists $params{$init_arg};
157 # if nothing was in the %params, we can use the
158 # attribute's default value (if it has one)
159 $val ||= $attr->default($instance) if $attr->has_default();
160 $instance->{$attr->name} = $val;
167 my $instance = shift;
168 (blessed($instance) && $instance->isa($class->name))
169 || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
171 # we need to protect the integrity of the
172 # Class::MOP::Class singletons here, they
173 # should not be cloned.
174 return $instance if $instance->isa('Class::MOP::Class');
175 bless $class->clone_instance($instance, @_) => blessed($instance);
179 my ($class, $instance, %params) = @_;
181 || confess "You can only clone instances, \$self is not a blessed instance";
182 my $clone = { %$instance, %params };
188 # &name should be here too, but it is above
189 # because it gets bootstrapped away
194 ${$self->name . '::VERSION'};
204 @{$self->name . '::ISA'} = @supers;
206 @{$self->name . '::ISA'};
209 sub class_precedence_list {
212 # We need to check for ciruclar inheirtance here.
213 # This will do nothing if all is well, and blow
214 # up otherwise. Yes, it's an ugly hack, better
215 # suggestions are welcome.
216 { $self->name->isa('This is a test for circular inheritance') }
217 # ... and no back to our regularly scheduled program
221 $self->initialize($_)->class_precedence_list()
222 } $self->superclasses()
229 my ($self, $method_name, $method) = @_;
230 (defined $method_name && $method_name)
231 || confess "You must define a method name";
232 # use reftype here to allow for blessed subs ...
233 (reftype($method) && reftype($method) eq 'CODE')
234 || confess "Your code block must be a CODE reference";
235 my $full_method_name = ($self->name . '::' . $method_name);
237 $method = Class::MOP::Method->new($method) unless blessed($method);
240 no warnings 'redefine';
241 *{$full_method_name} = subname $full_method_name => $method;
245 my ($self, $method_name, $method) = @_;
246 (defined $method_name && $method_name)
247 || confess "You must define a method name";
248 # use reftype here to allow for blessed subs ...
249 (reftype($method) && reftype($method) eq 'CODE')
250 || confess "Your code block must be a CODE reference";
251 my $full_method_name = ($self->name . '::' . $method_name);
253 $method = Class::MOP::Method->new($method) unless blessed($method);
256 no warnings 'redefine';
257 *{$full_method_name} = $method;
261 my ($self, $method_name) = @_;
262 (defined $method_name && $method_name)
263 || confess "You must define a method name";
265 my $sub_name = ($self->name . '::' . $method_name);
268 return 0 if !defined(&{$sub_name});
270 my $method = \&{$sub_name};
271 $method = Class::MOP::Method->new($method) unless blessed($method);
273 return 0 if $method->package_name ne $self->name &&
274 $method->name ne '__ANON__';
279 my ($self, $method_name) = @_;
280 (defined $method_name && $method_name)
281 || confess "You must define a method name";
283 return unless $self->has_method($method_name);
286 return \&{$self->name . '::' . $method_name};
290 my ($self, $method_name) = @_;
291 (defined $method_name && $method_name)
292 || confess "You must define a method name";
294 my $removed_method = $self->get_method($method_name);
297 delete ${$self->name . '::'}{$method_name}
298 if defined $removed_method;
300 return $removed_method;
303 sub get_method_list {
306 grep { $self->has_method($_) } %{$self->name . '::'};
309 sub compute_all_applicable_methods {
312 # keep a record of what we have seen
313 # here, this will handle all the
314 # inheritence issues because we are
315 # using the &class_precedence_list
316 my (%seen_class, %seen_method);
317 foreach my $class ($self->class_precedence_list()) {
318 next if $seen_class{$class};
319 $seen_class{$class}++;
320 # fetch the meta-class ...
321 my $meta = $self->initialize($class);
322 foreach my $method_name ($meta->get_method_list()) {
323 next if exists $seen_method{$method_name};
324 $seen_method{$method_name}++;
326 name => $method_name,
328 code => $meta->get_method($method_name)
335 sub find_all_methods_by_name {
336 my ($self, $method_name) = @_;
337 (defined $method_name && $method_name)
338 || confess "You must define a method name to find";
340 # keep a record of what we have seen
341 # here, this will handle all the
342 # inheritence issues because we are
343 # using the &class_precedence_list
345 foreach my $class ($self->class_precedence_list()) {
346 next if $seen_class{$class};
347 $seen_class{$class}++;
348 # fetch the meta-class ...
349 my $meta = $self->initialize($class);;
351 name => $method_name,
353 code => $meta->get_method($method_name)
354 } if $meta->has_method($method_name);
363 # either we have an attribute object already
364 # or we need to create one from the args provided
365 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
366 # make sure it is derived from the correct type though
367 ($attribute->isa('Class::MOP::Attribute'))
368 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
369 $attribute->attach_to_class($self);
370 $attribute->install_accessors();
371 $self->get_attribute_map->{$attribute->name} = $attribute;
375 my ($self, $attribute_name) = @_;
376 (defined $attribute_name && $attribute_name)
377 || confess "You must define an attribute name";
378 exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
382 my ($self, $attribute_name) = @_;
383 (defined $attribute_name && $attribute_name)
384 || confess "You must define an attribute name";
385 return $self->get_attribute_map->{$attribute_name}
386 if $self->has_attribute($attribute_name);
390 sub remove_attribute {
391 my ($self, $attribute_name) = @_;
392 (defined $attribute_name && $attribute_name)
393 || confess "You must define an attribute name";
394 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
395 return unless defined $removed_attribute;
396 delete $self->get_attribute_map->{$attribute_name};
397 $removed_attribute->remove_accessors();
398 $removed_attribute->detach_from_class();
399 return $removed_attribute;
402 sub get_attribute_list {
404 keys %{$self->get_attribute_map};
407 sub compute_all_applicable_attributes {
410 # keep a record of what we have seen
411 # here, this will handle all the
412 # inheritence issues because we are
413 # using the &class_precedence_list
414 my (%seen_class, %seen_attr);
415 foreach my $class ($self->class_precedence_list()) {
416 next if $seen_class{$class};
417 $seen_class{$class}++;
418 # fetch the meta-class ...
419 my $meta = $self->initialize($class);
420 foreach my $attr_name ($meta->get_attribute_list()) {
421 next if exists $seen_attr{$attr_name};
422 $seen_attr{$attr_name}++;
423 push @attrs => $meta->get_attribute($attr_name);
431 sub add_package_variable {
432 my ($self, $variable, $initial_value) = @_;
433 (defined $variable && $variable =~ /^[\$\@\%]/)
434 || confess "variable name does not have a sigil";
436 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
437 if (defined $initial_value) {
439 *{$self->name . '::' . $name} = $initial_value;
442 eval $sigil . $self->name . '::' . $name;
443 confess "Could not create package variable ($variable) because : $@" if $@;
447 sub has_package_variable {
448 my ($self, $variable) = @_;
449 (defined $variable && $variable =~ /^[\$\@\%]/)
450 || confess "variable name does not have a sigil";
451 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
453 defined ${$self->name . '::'}{$name} ? 1 : 0;
456 sub get_package_variable {
457 my ($self, $variable) = @_;
458 (defined $variable && $variable =~ /^[\$\@\%]/)
459 || confess "variable name does not have a sigil";
460 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
462 # try to fetch it first,.. see what happens
463 my $ref = eval '\\' . $sigil . $self->name . '::' . $name;
464 confess "Could not get the package variable ($variable) because : $@" if $@;
465 # if we didn't die, then we can return it
469 sub remove_package_variable {
470 my ($self, $variable) = @_;
471 (defined $variable && $variable =~ /^[\$\@\%]/)
472 || confess "variable name does not have a sigil";
473 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
475 delete ${$self->name . '::'}{$name};
486 Class::MOP::Class - Class Meta Object
490 # use this for introspection ...
492 # add a method to Foo ...
493 Foo->meta->add_method('bar' => sub { ... })
495 # get a list of all the classes searched
496 # the method dispatcher in the correct order
497 Foo->meta->class_precedence_list()
499 # remove a method from Foo
500 Foo->meta->remove_method('bar');
502 # or use this to actually create classes ...
504 Class::MOP::Class->create('Bar' => '0.01' => (
505 superclasses => [ 'Foo' ],
507 Class::MOP:::Attribute->new('$bar'),
508 Class::MOP:::Attribute->new('$baz'),
511 calculate_bar => sub { ... },
512 construct_baz => sub { ... }
518 This is the largest and currently most complex part of the Perl 5
519 meta-object protocol. It controls the introspection and
520 manipulation of Perl 5 classes (and it can create them too). The
521 best way to understand what this module can do, is to read the
522 documentation for each of it's methods.
526 =head2 Self Introspection
532 This will return a B<Class::MOP::Class> instance which is related
533 to this class. Thereby allowing B<Class::MOP::Class> to actually
536 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
537 bootstrap this module by installing a number of attribute meta-objects
538 into it's metaclass. This will allow this class to reap all the benifits
539 of the MOP when subclassing it.
543 =head2 Class construction
545 These methods will handle creating B<Class::MOP::Class> objects,
546 which can be used to both create new classes, and analyze
547 pre-existing classes.
549 This module will internally store references to all the instances
550 you create with these methods, so that they do not need to be
551 created any more than nessecary. Basically, they are singletons.
555 =item B<create ($package_name, ?$package_version,
556 superclasses =E<gt> ?@superclasses,
557 methods =E<gt> ?%methods,
558 attributes =E<gt> ?%attributes)>
560 This returns a B<Class::MOP::Class> object, bringing the specified
561 C<$package_name> into existence and adding any of the
562 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
565 =item B<initialize ($package_name)>
567 This initializes and returns returns a B<Class::MOP::Class> object
568 for a given a C<$package_name>.
570 =item B<construct_class_instance (%options)>
572 This will construct an instance of B<Class::MOP::Class>, it is
573 here so that we can actually "tie the knot" for B<Class::MOP::Class>
574 to use C<construct_instance> once all the bootstrapping is done. This
575 method is used internally by C<initialize> and should never be called
576 from outside of that method really.
578 =item B<check_metaclass_compatability>
580 This method is called as the very last thing in the
581 C<construct_class_instance> method. This will check that the
582 metaclass you are creating is compatible with the metaclasses of all
583 your ancestors. For more inforamtion about metaclass compatibility
584 see the C<About Metaclass compatibility> section in L<Class::MOP>.
588 =head2 Object instance construction and cloning
590 These methods are B<entirely optional>, it is up to you whether you want
595 =item B<new_object (%params)>
597 This is a convience method for creating a new object of the class, and
598 blessing it into the appropriate package as well. Ideally your class
599 would call a C<new> this method like so:
602 my ($class, %param) = @_;
603 $class->meta->new_object(%params);
606 Of course the ideal place for this would actually be in C<UNIVERSAL::>
607 but that is considered bad style, so we do not do that.
609 =item B<construct_instance (%params)>
611 This method is used to construct an instace structure suitable for
612 C<bless>-ing into your package of choice. It works in conjunction
613 with the Attribute protocol to collect all applicable attributes.
615 This will construct and instance using a HASH ref as storage
616 (currently only HASH references are supported). This will collect all
617 the applicable attributes and layout out the fields in the HASH ref,
618 it will then initialize them using either use the corresponding key
619 in C<%params> or any default value or initializer found in the
620 attribute meta-object.
622 =item B<clone_object ($instance, %params)>
624 This is a convience method for cloning an object instance, then
625 blessing it into the appropriate package. This method will call
626 C<clone_instance>, which performs a shallow copy of the object,
627 see that methods documentation for more details. Ideally your
628 class would call a C<clone> this method like so:
631 my ($self, %param) = @_;
632 $self->meta->clone_object($self, %params);
635 Of course the ideal place for this would actually be in C<UNIVERSAL::>
636 but that is considered bad style, so we do not do that.
638 =item B<clone_instance($instance, %params)>
640 This method is a compliment of C<construct_instance> (which means if
641 you override C<construct_instance>, you need to override this one too),
642 and clones the instance shallowly.
644 The cloned structure returned is (like with C<construct_instance>) an
645 unC<bless>ed HASH reference, it is your responsibility to then bless
646 this cloned structure into the right class (which C<clone_object> will
649 As of 0.11, this method will clone the C<$instance> structure shallowly,
650 as opposed to the deep cloning implemented in prior versions. After much
651 thought, research and discussion, I have decided that anything but basic
652 shallow cloning is outside the scope of the meta-object protocol. I
653 think Yuval "nothingmuch" Kogman put it best when he said that cloning
654 is too I<context-specific> to be part of the MOP.
664 This is a read-only attribute which returns the package name for the
665 given B<Class::MOP::Class> instance.
669 This is a read-only attribute which returns the C<$VERSION> of the
670 package for the given B<Class::MOP::Class> instance.
674 =head2 Inheritance Relationships
678 =item B<superclasses (?@superclasses)>
680 This is a read-write attribute which represents the superclass
681 relationships of the class the B<Class::MOP::Class> instance is
682 associated with. Basically, it can get and set the C<@ISA> for you.
685 Perl will occasionally perform some C<@ISA> and method caching, if
686 you decide to change your superclass relationship at runtime (which
687 is quite insane and very much not recommened), then you should be
688 aware of this and the fact that this module does not make any
689 attempt to address this issue.
691 =item B<class_precedence_list>
693 This computes the a list of all the class's ancestors in the same order
694 in which method dispatch will be done. This is similair to
695 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
703 =item B<method_metaclass>
705 =item B<add_method ($method_name, $method)>
707 This will take a C<$method_name> and CODE reference to that
708 C<$method> and install it into the class's package.
711 This does absolutely nothing special to C<$method>
712 other than use B<Sub::Name> to make sure it is tagged with the
713 correct name, and therefore show up correctly in stack traces and
716 =item B<alias_method ($method_name, $method)>
718 This will take a C<$method_name> and CODE reference to that
719 C<$method> and alias the method into the class's package.
722 Unlike C<add_method>, this will B<not> try to name the
723 C<$method> using B<Sub::Name>, it only aliases the method in
726 =item B<has_method ($method_name)>
728 This just provides a simple way to check if the class implements
729 a specific C<$method_name>. It will I<not> however, attempt to check
730 if the class inherits the method (use C<UNIVERSAL::can> for that).
732 This will correctly handle functions defined outside of the package
733 that use a fully qualified name (C<sub Package::name { ... }>).
735 This will correctly handle functions renamed with B<Sub::Name> and
736 installed using the symbol tables. However, if you are naming the
737 subroutine outside of the package scope, you must use the fully
738 qualified name, including the package name, for C<has_method> to
739 correctly identify it.
741 This will attempt to correctly ignore functions imported from other
742 packages using B<Exporter>. It breaks down if the function imported
743 is an C<__ANON__> sub (such as with C<use constant>), which very well
744 may be a valid method being applied to the class.
746 In short, this method cannot always be trusted to determine if the
747 C<$method_name> is actually a method. However, it will DWIM about
748 90% of the time, so it's a small trade off I think.
750 =item B<get_method ($method_name)>
752 This will return a CODE reference of the specified C<$method_name>,
753 or return undef if that method does not exist.
755 =item B<remove_method ($method_name)>
757 This will attempt to remove a given C<$method_name> from the class.
758 It will return the CODE reference that it has removed, and will
759 attempt to use B<Sub::Name> to clear the methods associated name.
761 =item B<get_method_list>
763 This will return a list of method names for all I<locally> defined
764 methods. It does B<not> provide a list of all applicable methods,
765 including any inherited ones. If you want a list of all applicable
766 methods, use the C<compute_all_applicable_methods> method.
768 =item B<compute_all_applicable_methods>
770 This will return a list of all the methods names this class will
771 respond to, taking into account inheritance. The list will be a list of
772 HASH references, each one containing the following information; method
773 name, the name of the class in which the method lives and a CODE
774 reference for the actual method.
776 =item B<find_all_methods_by_name ($method_name)>
778 This will traverse the inheritence hierarchy and locate all methods
779 with a given C<$method_name>. Similar to
780 C<compute_all_applicable_methods> it returns a list of HASH references
781 with the following information; method name (which will always be the
782 same as C<$method_name>), the name of the class in which the method
783 lives and a CODE reference for the actual method.
785 The list of methods produced is a distinct list, meaning there are no
786 duplicates in it. This is especially useful for things like object
787 initialization and destruction where you only want the method called
788 once, and in the correct order.
794 It should be noted that since there is no one consistent way to define
795 the attributes of a class in Perl 5. These methods can only work with
796 the information given, and can not easily discover information on
797 their own. See L<Class::MOP::Attribute> for more details.
801 =item B<attribute_metaclass>
803 =item B<get_attribute_map>
805 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
807 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
808 instance associated with the given class, and associates it with
809 the C<$attribute_name>. Unlike methods, attributes within the MOP
810 are stored as meta-information only. They will be used later to
811 construct instances from (see C<construct_instance> above).
812 More details about the attribute meta-objects can be found in the
813 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
816 It should be noted that any accessor, reader/writer or predicate
817 methods which the C<$attribute_meta_object> has will be installed
818 into the class at this time.
820 =item B<has_attribute ($attribute_name)>
822 Checks to see if this class has an attribute by the name of
823 C<$attribute_name> and returns a boolean.
825 =item B<get_attribute ($attribute_name)>
827 Returns the attribute meta-object associated with C<$attribute_name>,
828 if none is found, it will return undef.
830 =item B<remove_attribute ($attribute_name)>
832 This will remove the attribute meta-object stored at
833 C<$attribute_name>, then return the removed attribute meta-object.
836 Removing an attribute will only affect future instances of
837 the class, it will not make any attempt to remove the attribute from
838 any existing instances of the class.
840 It should be noted that any accessor, reader/writer or predicate
841 methods which the attribute meta-object stored at C<$attribute_name>
842 has will be removed from the class at this time. This B<will> make
843 these attributes somewhat inaccessable in previously created
844 instances. But if you are crazy enough to do this at runtime, then
845 you are crazy enough to deal with something like this :).
847 =item B<get_attribute_list>
849 This returns a list of attribute names which are defined in the local
850 class. If you want a list of all applicable attributes for a class,
851 use the C<compute_all_applicable_attributes> method.
853 =item B<compute_all_applicable_attributes>
855 This will traverse the inheritance heirachy and return a list of all
856 the applicable attributes for this class. It does not construct a
857 HASH reference like C<compute_all_applicable_methods> because all
858 that same information is discoverable through the attribute
863 =head2 Package Variables
865 Since Perl's classes are built atop the Perl package system, it is
866 fairly common to use package scoped variables for things like static
867 class variables. The following methods are convience methods for
868 the creation and inspection of package scoped variables.
872 =item B<add_package_variable ($variable_name, ?$initial_value)>
874 Given a C<$variable_name>, which must contain a leading sigil, this
875 method will create that variable within the package which houses the
876 class. It also takes an optional C<$initial_value>, which must be a
877 reference of the same type as the sigil of the C<$variable_name>
880 =item B<get_package_variable ($variable_name)>
882 This will return a reference to the package variable in
885 =item B<has_package_variable ($variable_name)>
887 Returns true (C<1>) if there is a package variable defined for
888 C<$variable_name>, and false (C<0>) otherwise.
890 =item B<remove_package_variable ($variable_name)>
892 This will attempt to remove the package variable at C<$variable_name>.
898 Stevan Little E<lt>stevan@iinteractive.comE<gt>
900 =head1 COPYRIGHT AND LICENSE
902 Copyright 2006 by Infinity Interactive, Inc.
904 L<http://www.iinteractive.com>
906 This library is free software; you can redistribute it and/or modify
907 it under the same terms as Perl itself.