197 lines
3.8 KiB
Perl
197 lines
3.8 KiB
Perl
package Class::MOP::Object;
|
|
our $VERSION = '2.2014';
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use parent 'Class::MOP::Mixin';
|
|
use Scalar::Util 'blessed';
|
|
use Module::Runtime;
|
|
|
|
# introspection
|
|
|
|
sub throw_error {
|
|
shift->_throw_exception( Legacy => message => join('', @_) );
|
|
}
|
|
|
|
sub _inline_throw_error {
|
|
my ( $self, $message ) = @_;
|
|
return 'die Module::Runtime::use_module("Moose::Exception::Legacy")->new(message => ' . $message. ')';
|
|
}
|
|
|
|
sub _new {
|
|
Class::MOP::class_of(shift)->new_object(@_);
|
|
}
|
|
|
|
# RANT:
|
|
# Cmon, how many times have you written
|
|
# the following code while debugging:
|
|
#
|
|
# use Data::Dumper;
|
|
# warn Dumper $obj;
|
|
#
|
|
# It can get seriously annoying, so why
|
|
# not just do this ...
|
|
sub dump {
|
|
my $self = shift;
|
|
require Data::Dumper;
|
|
local $Data::Dumper::Maxdepth = shift || 1;
|
|
Data::Dumper::Dumper $self;
|
|
}
|
|
|
|
sub _real_ref_name {
|
|
my $self = shift;
|
|
return blessed($self);
|
|
}
|
|
|
|
sub _is_compatible_with {
|
|
my $self = shift;
|
|
my ($other_name) = @_;
|
|
|
|
return $self->isa($other_name);
|
|
}
|
|
|
|
sub _can_be_made_compatible_with {
|
|
my $self = shift;
|
|
return !$self->_is_compatible_with(@_)
|
|
&& defined($self->_get_compatible_metaclass(@_));
|
|
}
|
|
|
|
sub _make_compatible_with {
|
|
my $self = shift;
|
|
my ($other_name) = @_;
|
|
|
|
my $new_metaclass = $self->_get_compatible_metaclass($other_name);
|
|
|
|
unless ( defined $new_metaclass ) {
|
|
$self->_throw_exception( CannotMakeMetaclassCompatible => superclass_name => $other_name,
|
|
class => $self,
|
|
);
|
|
}
|
|
|
|
# can't use rebless_instance here, because it might not be an actual
|
|
# subclass in the case of, e.g. moose role reconciliation
|
|
$new_metaclass->meta->_force_rebless_instance($self)
|
|
if blessed($self) ne $new_metaclass;
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub _get_compatible_metaclass {
|
|
my $self = shift;
|
|
my ($other_name) = @_;
|
|
|
|
return $self->_get_compatible_metaclass_by_subclassing($other_name);
|
|
}
|
|
|
|
sub _get_compatible_metaclass_by_subclassing {
|
|
my $self = shift;
|
|
my ($other_name) = @_;
|
|
my $meta_name = blessed($self) ? $self->_real_ref_name : $self;
|
|
|
|
if ($meta_name->isa($other_name)) {
|
|
return $meta_name;
|
|
}
|
|
elsif ($other_name->isa($meta_name)) {
|
|
return $other_name;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
1;
|
|
|
|
# ABSTRACT: Base class for metaclasses
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
Class::MOP::Object - Base class for metaclasses
|
|
|
|
=head1 VERSION
|
|
|
|
version 2.2014
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This class is a very minimal base class for metaclasses.
|
|
|
|
=head1 METHODS
|
|
|
|
This class provides a few methods which are useful in all metaclasses.
|
|
|
|
=head2 Class::MOP::???->meta
|
|
|
|
This returns a L<Class::MOP::Class> object.
|
|
|
|
=head2 $metaobject->dump($max_depth)
|
|
|
|
This method uses L<Data::Dumper> to dump the object. You can pass an
|
|
optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The
|
|
default maximum depth is 1.
|
|
|
|
=head2 $metaclass->throw_error($message)
|
|
|
|
This method calls L<Class::MOP::Mixin/_throw_exception> internally, with an object
|
|
of class L<Moose::Exception::Legacy>.
|
|
|
|
=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
|