Add Moose package
All checks were successful
release / release-plugins (push) Successful in 28s

This commit is contained in:
mschuepbach
2024-04-24 13:33:38 +02:00
parent 24101a5c1a
commit d95734d3d0
413 changed files with 47294 additions and 1 deletions

View File

@@ -0,0 +1,225 @@
package Moose::Meta::Role::Application;
our $VERSION = '2.2207';
use strict;
use warnings;
use metaclass;
use overload ();
use List::Util 1.33 qw( all );
use Moose::Util 'throw_exception';
__PACKAGE__->meta->add_attribute('method_exclusions' => (
init_arg => '-excludes',
reader => 'get_method_exclusions',
default => sub { [] },
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('method_aliases' => (
init_arg => '-alias',
reader => 'get_method_aliases',
default => sub { {} },
Class::MOP::_definition_context(),
));
sub new {
my ($class, %params) = @_;
$class->_new(\%params);
}
sub is_method_excluded {
my ($self, $method_name) = @_;
foreach (@{$self->get_method_exclusions}) {
return 1 if $_ eq $method_name;
}
return 0;
}
sub is_method_aliased {
my ($self, $method_name) = @_;
exists $self->get_method_aliases->{$method_name} ? 1 : 0
}
sub is_aliased_method {
my ($self, $method_name) = @_;
my %aliased_names = reverse %{$self->get_method_aliases};
exists $aliased_names{$method_name} ? 1 : 0;
}
sub apply {
my $self = shift;
$self->check_role_exclusions(@_);
$self->check_required_methods(@_);
$self->check_required_attributes(@_);
$self->apply_overloading(@_);
$self->apply_attributes(@_);
$self->apply_methods(@_);
$self->apply_override_method_modifiers(@_);
$self->apply_before_method_modifiers(@_);
$self->apply_around_method_modifiers(@_);
$self->apply_after_method_modifiers(@_);
}
sub check_role_exclusions { throw_exception( "CannotCallAnAbstractMethod" ); }
sub check_required_methods { throw_exception( "CannotCallAnAbstractMethod" ); }
sub check_required_attributes { throw_exception( "CannotCallAnAbstractMethod" ); }
sub apply_attributes { throw_exception( "CannotCallAnAbstractMethod" ); }
sub apply_methods { throw_exception( "CannotCallAnAbstractMethod" ); }
sub apply_override_method_modifiers { throw_exception( "CannotCallAnAbstractMethod" ); }
sub apply_method_modifiers { throw_exception( "CannotCallAnAbstractMethod" ); }
sub apply_before_method_modifiers { (shift)->apply_method_modifiers('before' => @_) }
sub apply_around_method_modifiers { (shift)->apply_method_modifiers('around' => @_) }
sub apply_after_method_modifiers { (shift)->apply_method_modifiers('after' => @_) }
sub apply_overloading {
my ( $self, $role, $other ) = @_;
return unless $role->is_overloaded;
unless ( $other->is_overloaded ) {
$other->set_overload_fallback_value(
$role->get_overload_fallback_value );
}
for my $overload ( $role->get_all_overloaded_operators ) {
next if $other->has_overloaded_operator( $overload->operator );
$other->add_overloaded_operator(
$overload->operator => $overload->clone );
}
}
1;
# ABSTRACT: A base class for role application
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Application - A base class for role application
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
This is the abstract base class for role applications.
The API for this class and its subclasses still needs some
consideration, and is intentionally not yet documented.
=head2 METHODS
=over 4
=item B<new>
=item B<meta>
=item B<get_method_exclusions>
=item B<is_method_excluded>
=item B<get_method_aliases>
=item B<is_aliased_method>
=item B<is_method_aliased>
=item B<apply>
=item B<check_role_exclusions>
=item B<check_required_methods>
=item B<check_required_attributes>
=item B<apply_attributes>
=item B<apply_methods>
=item B<apply_overloading>
=item B<apply_method_modifiers>
=item B<apply_before_method_modifiers>
=item B<apply_after_method_modifiers>
=item B<apply_around_method_modifiers>
=item B<apply_override_method_modifiers>
=back
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,440 @@
package Moose::Meta::Role::Application::RoleSummation;
our $VERSION = '2.2207';
use strict;
use warnings;
use metaclass;
use List::Util 1.33 qw( all );
use Scalar::Util 'blessed';
use Moose::Meta::Role::Composite;
use parent 'Moose::Meta::Role::Application';
use Moose::Util 'throw_exception';
__PACKAGE__->meta->add_attribute('role_params' => (
reader => 'role_params',
default => sub { {} },
Class::MOP::_definition_context(),
));
sub get_exclusions_for_role {
my ($self, $role) = @_;
$role = $role->name if blessed $role;
my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ?
'-excludes' : 'excludes';
if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) {
if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') {
return $self->role_params->{$role}->{$excludes_key};
}
return [ $self->role_params->{$role}->{$excludes_key} ];
}
return [];
}
sub get_method_aliases_for_role {
my ($self, $role) = @_;
$role = $role->name if blessed $role;
my $alias_key = exists $self->role_params->{$role}->{'-alias'} ?
'-alias' : 'alias';
if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) {
return $self->role_params->{$role}->{$alias_key};
}
return {};
}
sub is_method_excluded {
my ($self, $role, $method_name) = @_;
foreach ($self->get_exclusions_for_role($role->name)) {
return 1 if $_ eq $method_name;
}
return 0;
}
sub is_method_aliased {
my ($self, $role, $method_name) = @_;
exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0
}
sub is_aliased_method {
my ($self, $role, $method_name) = @_;
my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
exists $aliased_names{$method_name} ? 1 : 0;
}
sub check_role_exclusions {
my ($self, $c) = @_;
my %excluded_roles;
for my $role (@{ $c->get_roles }) {
my $name = $role->name;
for my $excluded ($role->get_excluded_roles_list) {
push @{ $excluded_roles{$excluded} }, $name;
}
}
foreach my $role (@{$c->get_roles}) {
foreach my $excluded (keys %excluded_roles) {
next unless $role->does_role($excluded);
my @excluding = @{ $excluded_roles{$excluded} };
throw_exception( RoleExclusionConflict => roles => \@excluding,
role_name => $excluded
);
}
}
$c->add_excluded_roles(keys %excluded_roles);
}
sub check_required_methods {
my ($self, $c) = @_;
my %all_required_methods =
map { $_->name => $_ }
map { $_->get_required_method_list }
@{$c->get_roles};
foreach my $role (@{$c->get_roles}) {
foreach my $required (keys %all_required_methods) {
delete $all_required_methods{$required}
if $role->has_method($required)
|| $self->is_aliased_method($role, $required);
}
}
$c->add_required_methods(values %all_required_methods);
}
sub check_required_attributes {
}
sub apply_attributes {
my ($self, $c) = @_;
my @all_attributes;
for my $role ( @{ $c->get_roles } ) {
push @all_attributes,
map { $role->get_attribute($_) } $role->get_attribute_list;
}
my %seen;
foreach my $attr (@all_attributes) {
my $name = $attr->name;
if ( exists $seen{$name} ) {
next if $seen{$name}->is_same_as($attr);
my $role1 = $seen{$name}->associated_role->name;
my $role2 = $attr->associated_role->name;
throw_exception( AttributeConflictInSummation => attribute_name => $name,
role_name => $role1,
second_role_name => $role2,
);
}
$seen{$name} = $attr;
}
foreach my $attr (@all_attributes) {
$c->add_attribute( $attr->clone );
}
}
sub apply_methods {
my ($self, $c) = @_;
my @all_methods = map {
my $role = $_;
my $aliases = $self->get_method_aliases_for_role($role);
my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
(
(map {
exists $excludes{$_} ? () :
+{
role => $role,
name => $_,
method => $role->get_method($_),
}
} map { $_->name }
grep { !$_->isa('Class::MOP::Method::Meta') }
$role->_get_local_methods),
(map {
+{
role => $role,
name => $aliases->{$_},
method => $role->get_method($_),
}
} keys %$aliases)
);
} @{$c->get_roles};
my (%seen, %conflicts, %method_map);
foreach my $method (@all_methods) {
next if $conflicts{$method->{name}};
my $seen = $seen{$method->{name}};
if ($seen) {
if ($seen->{method}->body != $method->{method}->body) {
$c->add_conflicting_method(
name => $method->{name},
roles => [$method->{role}->name, $seen->{role}->name],
);
delete $method_map{$method->{name}};
$conflicts{$method->{name}} = 1;
next;
}
}
$seen{$method->{name}} = $method;
$method_map{$method->{name}} = $method->{method};
}
$c->add_method($_ => $method_map{$_}) for keys %method_map;
}
sub apply_override_method_modifiers {
my ($self, $c) = @_;
my @all_overrides = map {
my $role = $_;
map {
+{
name => $_,
method => $role->get_override_method_modifier($_),
}
} $role->get_method_modifier_list('override');
} @{$c->get_roles};
my %seen;
foreach my $override (@all_overrides) {
my @role_names = map { $_->name } @{$c->get_roles};
if ( $c->has_method($override->{name}) ){
throw_exception( OverrideConflictInSummation => role_names => \@role_names,
role_application => $self,
method_name => $override->{name}
);
}
if (exists $seen{$override->{name}}) {
if ( $seen{$override->{name}} != $override->{method} ) {
throw_exception( OverrideConflictInSummation => role_names => \@role_names,
role_application => $self,
method_name => $override->{name},
two_overrides_found => 1
);
}
}
$seen{$override->{name}} = $override->{method};
}
$c->add_override_method_modifier(
$_->{name}, $_->{method}
) for @all_overrides;
}
sub apply_method_modifiers {
my ($self, $modifier_type, $c) = @_;
my $add = "add_${modifier_type}_method_modifier";
my $get = "get_${modifier_type}_method_modifiers";
foreach my $role (@{$c->get_roles}) {
foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
$c->$add(
$method_name,
$_
) foreach $role->$get($method_name);
}
}
}
sub apply_overloading {
my ( $self, $c ) = @_;
my @overloaded_roles = grep { $_->is_overloaded } @{ $c->get_roles };
return unless @overloaded_roles;
my %fallback;
for my $role (@overloaded_roles) {
$fallback{ $role->name } = $role->get_overload_fallback_value;
}
for my $role_name ( keys %fallback ) {
for my $other_role_name ( grep { $_ ne $role_name } keys %fallback ) {
my @fb_values = @fallback{ $role_name, $other_role_name };
if ( all {defined} @fb_values ) {
next if $fallback{$role_name} eq $fallback{$other_role_name};
throw_exception(
'OverloadConflictInSummation',
role_names => [ $role_name, $other_role_name ],
role_application => $self,
overloaded_op => 'fallback',
);
}
next if all { !defined } @fb_values;
throw_exception(
'OverloadConflictInSummation',
role_names => [ $role_name, $other_role_name ],
role_application => $self,
overloaded_op => 'fallback',
);
}
}
if ( keys %fallback ) {
$c->set_overload_fallback_value( ( values %fallback )[0] );
}
my %overload_map;
for my $role (@overloaded_roles) {
for my $overload ( $role->get_all_overloaded_operators ) {
$overload_map{ $overload->operator }{ $role->name } = $overload;
}
}
for my $op_name ( keys %overload_map ) {
my @roles = keys %{ $overload_map{$op_name} };
my $overload = $overload_map{$op_name}{ $roles[0] };
if ( @roles > 1 && !all { $overload->_is_equal_to($_) }
values %{ $overload_map{$op_name} } ) {
throw_exception(
'OverloadConflictInSummation',
role_names => [ @roles[ 0, 1 ] ],
role_application => $self,
overloaded_op => $op_name,
);
}
$c->add_overloaded_operator(
$op_name => $overload_map{$op_name}{ $roles[0] } );
}
}
1;
# ABSTRACT: Combine two or more roles
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Application::RoleSummation - Combine two or more roles
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
Summation composes two traits, forming the union of non-conflicting
bindings and 'disabling' the conflicting bindings
=head2 METHODS
=over 4
=item B<new>
=item B<meta>
=item B<role_params>
=item B<get_exclusions_for_role>
=item B<get_method_aliases_for_role>
=item B<is_aliased_method>
=item B<is_method_aliased>
=item B<is_method_excluded>
=item B<apply>
=item B<check_role_exclusions>
=item B<check_required_methods>
=item B<check_required_attributes>
=item B<apply_attributes>
=item B<apply_methods>
=item B<apply_overloading>
=item B<apply_method_modifiers>
=item B<apply_override_method_modifiers>
=back
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,314 @@
package Moose::Meta::Role::Application::ToClass;
our $VERSION = '2.2207';
use strict;
use warnings;
use metaclass;
use List::Util 'first';
use Moose::Util 'throw_exception';
use Scalar::Util 'weaken';
use parent 'Moose::Meta::Role::Application';
__PACKAGE__->meta->add_attribute('role' => (
reader => 'role',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('class' => (
accessor => 'class',
Class::MOP::_definition_context(),
));
sub apply {
my ($self, $role, $class) = @_;
# We need weak_ref in CMOP :(
weaken($self->{role} = $role);
weaken($self->{class} = $class);
$self->SUPER::apply($role, $class);
$class->add_role($role);
$class->add_role_application($self);
}
sub check_role_exclusions {
my ($self, $role, $class) = @_;
if ($class->excludes_role($role->name)) {
throw_exception( ConflictDetectedInCheckRoleExclusionsInToClass => class_name => $class->name,
role_name => $role->name,
);
}
foreach my $excluded_role_name ($role->get_excluded_roles_list) {
if ($class->does_role($excluded_role_name)) {
throw_exception( ClassDoesTheExcludedRole => role_name => $role->name,
excluded_role_name => $excluded_role_name,
class_name => $class->name,
);
}
}
}
sub check_required_methods {
my ($self, $role, $class) = @_;
my @missing;
my @is_attr;
# NOTE:
# we might need to move this down below the
# the attributes so that we can require any
# attribute accessors. However I am thinking
# that maybe those are somehow exempt from
# the require methods stuff.
foreach my $required_method ($role->get_required_method_list) {
my $required_method_name = $required_method->name;
if (!$class->find_method_by_name($required_method_name)) {
next if $self->is_aliased_method($required_method_name);
push @missing, $required_method;
}
}
return unless @missing;
my $error = '';
@missing = sort { $a->name cmp $b->name } @missing;
my @conflicts = grep { $_->isa('Moose::Meta::Role::Method::Conflicting') } @missing;
if (@conflicts) {
my $conflict = $conflicts[0];
my $roles = $conflict->roles_as_english_list;
my @same_role_conflicts = grep { $_->roles_as_english_list eq $roles } @conflicts;
throw_exception( MethodNameConflictInRoles => conflict => \@same_role_conflicts,
class_name => $class->name
);
}
elsif (@missing) {
if (my $meth = first { $class->name->can($_) } @missing) {
throw_exception( RequiredMethodsImportedByClass => class_name => $class->name,
role_name => $role->name,
missing_methods => \@missing,
imported_method => $meth
);
}
else {
throw_exception( RequiredMethodsNotImplementedByClass => class_name => $class->name,
role_name => $role->name,
missing_methods => \@missing,
);
}
}
}
sub check_required_attributes {
}
sub apply_attributes {
my ($self, $role, $class) = @_;
foreach my $attribute_name ($role->get_attribute_list) {
# it if it has one already
if ($class->has_attribute($attribute_name) &&
# make sure we haven't seen this one already too
$class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) {
next;
}
else {
$class->add_attribute(
$role->get_attribute($attribute_name)->attribute_for_class
);
}
}
}
sub apply_methods {
my ( $self, $role, $class ) = @_;
foreach my $method ( $role->_get_local_methods ) {
my $method_name = $method->name;
next if $method->isa('Class::MOP::Method::Meta');
unless ( $self->is_method_excluded($method_name) ) {
my $class_method = $class->get_method($method_name);
next if $class_method && $class_method->body != $method->body;
$class->add_method(
$method_name,
$method,
);
}
next unless $self->is_method_aliased($method_name);
my $aliased_method_name = $self->get_method_aliases->{$method_name};
my $class_method = $class->get_method($aliased_method_name);
if ( $class_method && $class_method->body != $method->body ) {
throw_exception( CannotCreateMethodAliasLocalMethodIsPresentInClass => aliased_method_name => $aliased_method_name,
method => $method,
role_name => $role->name,
class_name => $class->name,
);
}
$class->add_method(
$aliased_method_name,
$method,
);
}
# we must reset the cache here since
# we are just aliasing methods, otherwise
# the modifiers go wonky.
$class->reset_package_cache_flag;
}
sub apply_override_method_modifiers {
my ($self, $role, $class) = @_;
foreach my $method_name ($role->get_method_modifier_list('override')) {
# it if it has one already then ...
if ($class->has_method($method_name)) {
next;
}
else {
# if this is not a role, then we need to
# find the original package of the method
# so that we can tell the class were to
# find the right super() method
my $method = $role->get_override_method_modifier($method_name);
my ($package) = Class::MOP::get_code_info($method);
# if it is a class, we just add it
$class->add_override_method_modifier($method_name, $method, $package);
}
}
}
sub apply_method_modifiers {
my ($self, $modifier_type, $role, $class) = @_;
my $add = "add_${modifier_type}_method_modifier";
my $get = "get_${modifier_type}_method_modifiers";
foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
$class->$add(
$method_name,
$_
) foreach $role->$get($method_name);
}
}
1;
# ABSTRACT: Compose a role into a class
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Application::ToClass - Compose a role into a class
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
=head2 METHODS
=over 4
=item B<new>
=item B<meta>
=item B<apply>
=item B<check_role_exclusions>
=item B<check_required_methods>
=item B<check_required_attributes>
=item B<apply_attributes>
=item B<apply_methods>
=item B<apply_method_modifiers>
=item B<apply_override_method_modifiers>
=back
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,142 @@
package Moose::Meta::Role::Application::ToInstance;
our $VERSION = '2.2207';
use strict;
use warnings;
use metaclass;
use Scalar::Util 'blessed';
use List::Util 1.33 'all';
use Devel::OverloadInfo 0.004 'is_overloaded';
use parent 'Moose::Meta::Role::Application';
__PACKAGE__->meta->add_attribute('rebless_params' => (
reader => 'rebless_params',
default => sub { {} },
Class::MOP::_definition_context(),
));
use constant _NEED_OVERLOAD_HACK_FOR_OBJECTS => "$]" < 5.008009;
sub apply {
my ( $self, $role, $object, $args ) = @_;
my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class';
# This is a special case to handle the case where the object's metaclass
# is a Class::MOP::Class, but _not_ a Moose::Meta::Class (for example,
# when applying a role to a Moose::Meta::Attribute object).
$obj_meta = 'Moose::Meta::Class'
unless $obj_meta->isa('Moose::Meta::Class');
my $class = $obj_meta->create_anon_class(
superclasses => [ blessed($object) ],
roles => [ $role, keys(%$args) ? ($args) : () ],
cache => (all { $_ eq '-alias' || $_ eq '-excludes' } keys %$args),
);
$class->rebless_instance( $object, %{ $self->rebless_params } );
if ( _NEED_OVERLOAD_HACK_FOR_OBJECTS
&& is_overloaded( ref $object ) ) {
# need to use $_[2] here to apply to the object in the caller
_reset_amagic($_[2]);
}
return $object;
}
1;
# ABSTRACT: Compose a role into an instance
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Application::ToInstance - Compose a role into an instance
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
=head2 METHODS
=over 4
=item B<new>
=item B<meta>
=item B<apply>
=item B<rebless_params>
=back
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,283 @@
package Moose::Meta::Role::Application::ToRole;
our $VERSION = '2.2207';
use strict;
use warnings;
use metaclass;
use parent 'Moose::Meta::Role::Application';
use Moose::Util 'throw_exception';
sub apply {
my ($self, $role1, $role2) = @_;
$self->SUPER::apply($role1, $role2);
$role2->add_role($role1);
}
sub check_role_exclusions {
my ($self, $role1, $role2) = @_;
if ( $role2->excludes_role($role1->name) ) {
throw_exception( ConflictDetectedInCheckRoleExclusions => role_name => $role2->name,
excluded_role_name => $role1->name,
);
}
foreach my $excluded_role_name ($role1->get_excluded_roles_list) {
if ( $role2->does_role($excluded_role_name) ) {
throw_exception( RoleDoesTheExcludedRole => role_name => $role2->name,
excluded_role_name => $excluded_role_name,
second_role_name => $role1->name,
);
}
$role2->add_excluded_roles($excluded_role_name);
}
}
sub check_required_methods {
my ($self, $role1, $role2) = @_;
foreach my $required_method ($role1->get_required_method_list) {
my $required_method_name = $required_method->name;
next if $self->is_aliased_method($required_method_name);
$role2->add_required_methods($required_method)
unless $role2->find_method_by_name($required_method_name);
}
}
sub check_required_attributes {
}
sub apply_attributes {
my ($self, $role1, $role2) = @_;
foreach my $attribute_name ($role1->get_attribute_list) {
# it if it has one already
if ($role2->has_attribute($attribute_name) &&
# make sure we haven't seen this one already too
$role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) {
my $role2_name = $role2->name;
throw_exception( AttributeConflictInRoles => role_name => $role1->name,
second_role_name => $role2->name,
attribute_name => $attribute_name
);
}
else {
$role2->add_attribute(
$role1->get_attribute($attribute_name)->clone
);
}
}
}
sub apply_methods {
my ( $self, $role1, $role2 ) = @_;
foreach my $method ( $role1->_get_local_methods ) {
my $method_name = $method->name;
next if $method->isa('Class::MOP::Method::Meta');
unless ( $self->is_method_excluded($method_name) ) {
my $role2_method = $role2->get_method($method_name);
if ( $role2_method
&& $role2_method->body != $method->body ) {
# method conflicts between roles used to result in the method
# becoming a requirement but now are permitted just like
# for classes, hence no code in this branch anymore.
}
else {
$role2->add_method(
$method_name,
$method,
);
}
}
next unless $self->is_method_aliased($method_name);
my $aliased_method_name = $self->get_method_aliases->{$method_name};
my $role2_method = $role2->get_method($aliased_method_name);
if ( $role2_method
&& $role2_method->body != $method->body ) {
throw_exception( CannotCreateMethodAliasLocalMethodIsPresent => aliased_method_name => $aliased_method_name,
method => $method,
role_name => $role2->name,
role_being_applied_name => $role1->name,
);
}
$role2->add_method(
$aliased_method_name,
$role1->get_method($method_name)
);
if ( !$role2->has_method($method_name) ) {
$role2->add_required_methods($method_name)
unless $self->is_method_excluded($method_name);
}
}
}
sub apply_override_method_modifiers {
my ($self, $role1, $role2) = @_;
foreach my $method_name ($role1->get_method_modifier_list('override')) {
# it if it has one already then ...
if ($role2->has_method($method_name)) {
# if it is being composed into another role
# we have a conflict here, because you cannot
# combine an overridden method with a locally
# defined one
throw_exception( OverrideConflictInComposition => role_name => $role2->name,
role_being_applied_name => $role1->name,
method_name => $method_name
);
}
else {
# if we are a role, we need to make sure
# we don't have a conflict with the role
# we are composing into
if ($role2->has_override_method_modifier($method_name) &&
$role1->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) {
throw_exception( OverrideConflictInComposition => role_name => $role2->name,
role_being_applied_name => $role1->name,
method_name => $method_name,
two_overrides_found => 1
);
}
else {
# if there is no conflict,
# just add it to the role
$role2->add_override_method_modifier(
$method_name,
$role1->get_override_method_modifier($method_name)
);
}
}
}
}
sub apply_method_modifiers {
my ($self, $modifier_type, $role1, $role2) = @_;
my $add = "add_${modifier_type}_method_modifier";
my $get = "get_${modifier_type}_method_modifiers";
foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) {
$role2->$add(
$method_name,
$_
) foreach $role1->$get($method_name);
}
}
1;
# ABSTRACT: Compose a role into another role
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Application::ToRole - Compose a role into another role
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
=head2 METHODS
=over 4
=item B<new>
=item B<meta>
=item B<apply>
=item B<check_role_exclusions>
=item B<check_required_methods>
=item B<check_required_attributes>
=item B<apply_attributes>
=item B<apply_methods>
=item B<apply_method_modifiers>
=item B<apply_override_method_modifiers>
=back
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,259 @@
package Moose::Meta::Role::Attribute;
our $VERSION = '2.2207';
use strict;
use warnings;
use List::Util 1.33 'all';
use Scalar::Util 'blessed', 'weaken';
use parent 'Moose::Meta::Mixin::AttributeCore', 'Class::MOP::Object';
use Moose::Util 'throw_exception';
__PACKAGE__->meta->add_attribute(
'metaclass' => (
reader => 'metaclass',
Class::MOP::_definition_context(),
)
);
__PACKAGE__->meta->add_attribute(
'associated_role' => (
reader => 'associated_role',
Class::MOP::_definition_context(),
)
);
__PACKAGE__->meta->add_attribute(
'_original_role' => (
reader => '_original_role',
Class::MOP::_definition_context(),
)
);
__PACKAGE__->meta->add_attribute(
'is' => (
reader => 'is',
Class::MOP::_definition_context(),
)
);
__PACKAGE__->meta->add_attribute(
'original_options' => (
reader => 'original_options',
Class::MOP::_definition_context(),
)
);
sub new {
my ( $class, $name, %options ) = @_;
(defined $name)
|| throw_exception( MustProvideANameForTheAttribute => params => \%options,
class => $class
);
my $role = delete $options{_original_role};
return bless {
name => $name,
original_options => \%options,
_original_role => $role,
%options,
}, $class;
}
sub attach_to_role {
my ( $self, $role ) = @_;
( blessed($role) && $role->isa('Moose::Meta::Role') )
|| throw_exception( MustPassAMooseMetaRoleInstanceOrSubclass => class => $self,
role => $role
);
weaken( $self->{'associated_role'} = $role );
}
sub original_role {
my $self = shift;
return $self->_original_role || $self->associated_role;
}
sub attribute_for_class {
my $self = shift;
my $metaclass = $self->original_role->applied_attribute_metaclass;
return $metaclass->interpolate_class_and_new(
$self->name => %{ $self->original_options },
role_attribute => $self,
);
}
sub clone {
my $self = shift;
my $role = $self->original_role;
return ( ref $self )->new(
$self->name,
%{ $self->original_options },
_original_role => $role,
);
}
sub is_same_as {
my $self = shift;
my $attr = shift;
my $self_options = $self->original_options;
my $other_options = $attr->original_options;
return 0
unless ( join q{|}, sort keys %{$self_options} ) eq ( join q{|}, sort keys %{$other_options} );
for my $key ( keys %{$self_options} ) {
return 0 if defined $self_options->{$key} && ! defined $other_options->{$key};
return 0 if ! defined $self_options->{$key} && defined $other_options->{$key};
next if all { ! defined } $self_options->{$key}, $other_options->{$key};
return 0 unless $self_options->{$key} eq $other_options->{$key};
}
return 1;
}
1;
# ABSTRACT: The Moose attribute metaclass for Roles
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Attribute - The Moose attribute metaclass for Roles
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
This class implements the API for attributes in roles. Attributes in roles are
more like attribute prototypes than full blown attributes. While they are
introspectable, they have very little behavior.
=head1 METHODS
=head2 Moose::Meta::Role::Attribute->new(...)
This method accepts all the options that would be passed to the constructor
for L<Moose::Meta::Attribute>.
=head2 $attr->metaclass
=head2 $attr->is
Returns the option as passed to the constructor.
=head2 $attr->associated_role
Returns the L<Moose::Meta::Role> to which this attribute belongs, if any.
=head2 $attr->original_role
Returns the L<Moose::Meta::Role> in which this attribute was first
defined. This may not be the same as the value of C<associated_role()> for
attributes in a composite role, or when one role consumes other roles.
=head2 $attr->original_options
Returns a hash reference of options passed to the constructor. This is used
when creating a L<Moose::Meta::Attribute> object from this object.
=head2 $attr->attach_to_role($role)
Attaches the attribute to the given L<Moose::Meta::Role>.
=head2 $attr->attribute_for_class($metaclass)
Given an attribute metaclass name, this method calls C<<
$metaclass->interpolate_class_and_new >> to construct an attribute object
which can be added to a L<Moose::Meta::Class>.
=head2 $attr->clone
Creates a new object identical to the object on which the method is called.
=head2 $attr->is_same_as($other_attr)
Compares two role attributes and returns true if they are identical.
In addition, this class implements all informational predicates implements by
L<Moose::Meta::Attribute> (and L<Class::MOP::Attribute>).
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,320 @@
package Moose::Meta::Role::Composite;
our $VERSION = '2.2207';
use strict;
use warnings;
use metaclass;
use Scalar::Util 'blessed';
use Moose::Util 'throw_exception';
use parent 'Moose::Meta::Role';
# NOTE:
# we need to override the ->name
# method from Class::MOP::Package
# since we don't have an actual
# package for this.
# - SL
__PACKAGE__->meta->add_attribute('name' => (
reader => 'name',
Class::MOP::_definition_context(),
));
# NOTE:
# Again, since we don't have a real
# package to store our methods in,
# we use a HASH ref instead.
# - SL
__PACKAGE__->meta->add_attribute('_methods' => (
reader => '_method_map',
default => sub { {} },
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('_overloads' => (
reader => '_overload_map',
default => sub { {} },
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('_overload_fallback' => (
accessor => '_overload_fallback',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute(
'application_role_summation_class',
reader => 'application_role_summation_class',
default => 'Moose::Meta::Role::Application::RoleSummation',
Class::MOP::_definition_context(),
);
sub new {
my ($class, %params) = @_;
# the roles param is required ...
foreach ( @{$params{roles}} ) {
unless ( $_->isa('Moose::Meta::Role') ) {
throw_exception( RolesListMustBeInstancesOfMooseMetaRole => params => \%params,
role => $_,
class => $class
);
}
}
my @composition_roles = map {
$_->composition_class_roles
} @{ $params{roles} };
if (@composition_roles) {
my $meta = Moose::Meta::Class->create_anon_class(
superclasses => [ $class ],
roles => [ @composition_roles ],
cache => 1,
);
$class = $meta->name;
}
# and the name is created from the
# roles if one has not been provided
$params{name} ||= (join "|" => map { $_->name } @{$params{roles}});
$class->_new(\%params);
}
# There's no such thing as an anonymous composite role since composites are an
# artifact of Moose's internals. However, a composite role that contains an
# anon role may _look_ like an anon role since $self->name =~ /$anon_key/ can
# return true if the first role in the composite is anonymous itself.
sub is_anon { 0 }
# This is largely a copy of what's in Moose::Meta::Role (itself
# largely a copy of Class::MOP::Class). However, we can't actually
# call add_package_symbol, because there's no package into which to
# add the symbol.
sub add_method {
my ($self, $method_name, $method) = @_;
unless ( defined $method_name && $method_name ) {
throw_exception( MustDefineAMethodName => instance => $self );
}
my $body;
if (blessed($method)) {
$body = $method->body;
if ($method->package_name ne $self->name) {
$method = $method->clone(
package_name => $self->name,
name => $method_name
) if $method->can('clone');
}
}
else {
$body = $method;
$method = $self->wrap_method_body( body => $body, name => $method_name );
}
$self->_method_map->{$method_name} = $method;
}
sub get_method_list {
my $self = shift;
return keys %{ $self->_method_map };
}
sub _get_local_methods {
my $self = shift;
return values %{ $self->_method_map };
}
sub has_method {
my ($self, $method_name) = @_;
return exists $self->_method_map->{$method_name};
}
sub get_method {
my ($self, $method_name) = @_;
return $self->_method_map->{$method_name};
}
sub is_overloaded {
my ($self) = @_;
return keys %{ $self->_overload_map };
}
sub add_overloaded_operator {
my ( $self, $op_name, $overload ) = @_;
unless ( defined $op_name && $op_name ) {
throw_exception(
'MustDefineAnOverloadOperator',
instance => $self,
);
}
$self->_overload_map->{$op_name} = $overload;
}
sub get_overload_fallback_value {
my ($self) = @_;
return $self->_overload_fallback;
}
sub set_overload_fallback_value {
my $self = shift;
$self->_overload_fallback(shift);
}
sub get_all_overloaded_operators {
my ( $self, $method_name ) = @_;
return values %{ $self->_overload_map };
}
sub apply_params {
my ($self, $role_params) = @_;
Moose::Util::_load_user_class($self->application_role_summation_class);
$self->application_role_summation_class->new(
role_params => $role_params,
)->apply($self);
return $self;
}
sub reinitialize {
my ( $class, $old_meta, @args ) = @_;
throw_exception( CannotInitializeMooseMetaRoleComposite => old_meta => $old_meta,
args => \@args,
role_composite => $class
)
if !blessed $old_meta
|| !$old_meta->isa('Moose::Meta::Role::Composite');
my %existing_classes = map { $_ => $old_meta->$_() } qw(
application_role_summation_class
);
return $old_meta->meta->clone_object( $old_meta, %existing_classes, @args );
}
1;
# ABSTRACT: An object to represent the set of roles
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Composite - An object to represent the set of roles
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
A composite is a role that consists of a set of two or more roles.
The API of a composite role is almost identical to that of a regular
role.
=head1 INHERITANCE
C<Moose::Meta::Role::Composite> is a subclass of L<Moose::Meta::Role>.
=head1 METHODS
=head2 Moose::Meta::Role::Composite->new(%options)
This returns a new composite role object. It accepts the same
options as its parent class, with a few changes:
=over 4
=item * roles
This option is an array reference containing a list of
L<Moose::Meta::Role> object. This is a required option.
=item * name
If a name is not given, one is generated from the roles provided.
=item * apply_params(\%role_params)
Creates a new RoleSummation role application with C<%role_params> and applies
the composite role to it. The RoleSummation role application class used is
determined by the composite role's C<application_role_summation_class>
attribute.
=item * reinitialize($metaclass)
Like C<< Class::MOP::Package->reinitialize >>, but doesn't allow passing a
string with the package name, as there is no real package for composite roles.
=back
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,101 @@
package Moose::Meta::Role::Method;
our $VERSION = '2.2207';
use strict;
use warnings;
use parent 'Moose::Meta::Method';
sub _make_compatible_with {
my $self = shift;
my ($other) = @_;
# XXX: this is pretty gross. the issue here is blah blah blah
# see the comments in CMOP::Method::Meta and CMOP::Method::Wrapped
return $self unless $other->_is_compatible_with($self->_real_ref_name);
return $self->SUPER::_make_compatible_with(@_);
}
1;
# ABSTRACT: A Moose Method metaclass for Roles
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Method - A Moose Method metaclass for Roles
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
This is primarily used to mark methods coming from a role
as being different. Right now it is nothing but a subclass
of L<Moose::Meta::Method>.
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,135 @@
package Moose::Meta::Role::Method::Conflicting;
our $VERSION = '2.2207';
use strict;
use warnings;
use Moose::Util;
use parent 'Moose::Meta::Role::Method::Required';
__PACKAGE__->meta->add_attribute('roles' => (
reader => 'roles',
required => 1,
Class::MOP::_definition_context(),
));
sub roles_as_english_list {
my $self = shift;
Moose::Util::english_list( map { q{'} . $_ . q{'} } @{ $self->roles } );
}
1;
# ABSTRACT: A Moose metaclass for conflicting methods in Roles
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Method::Conflicting - A Moose metaclass for conflicting methods in Roles
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
=head1 INHERITANCE
C<Moose::Meta::Role::Method::Conflicting> is a subclass of
L<Moose::Meta::Role::Method::Required>.
=head1 METHODS
=head2 Moose::Meta::Role::Method::Conflicting->new(%options)
This creates a new type constraint based on the provided C<%options>:
=over 4
=item * name
The method name. This is required.
=item * roles
The list of role names that generated the conflict. This is required.
=back
=head2 $method->name
Returns the conflicting method's name, as provided to the constructor.
=head2 $method->roles
Returns the roles that generated this conflicting method, as provided to the
constructor.
=head2 $method->roles_as_english_list
Returns the roles that generated this conflicting method as an English list.
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

View File

@@ -0,0 +1,127 @@
package Moose::Meta::Role::Method::Required;
our $VERSION = '2.2207';
use strict;
use warnings;
use metaclass;
use overload
'""' => sub { shift->name }, # stringify to method name
'bool' => sub { 1 },
fallback => 1;
use parent 'Class::MOP::Object';
# This is not a Moose::Meta::Role::Method because it has no implementation, it
# is just a name
__PACKAGE__->meta->add_attribute('name' => (
reader => 'name',
required => 1,
Class::MOP::_definition_context(),
));
sub new { shift->_new(@_) }
1;
# ABSTRACT: A Moose metaclass for required methods in Roles
__END__
=pod
=encoding UTF-8
=head1 NAME
Moose::Meta::Role::Method::Required - A Moose metaclass for required methods in Roles
=head1 VERSION
version 2.2207
=head1 DESCRIPTION
=head1 INHERITANCE
C<Moose::Meta::Role::Method::Required> is a subclass of L<Class::MOP::Object>.
It is B<not> a subclass of C<Moose::Meta::Role::Method> since it does not
provide an implementation of the method.
=head1 METHODS
=head2 Moose::Meta::Role::Method::Required->new(%options)
This creates a new type constraint based on the provided C<%options>:
=over 4
=item * name
The method name. This is required.
=back
=head2 $method->name
Returns the required method's name, as provided to the constructor.
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut