lib/Class/MOP/Object.pm

   1
   2 package Class::MOP::Object;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp qw(confess);
   8 use Scalar::Util 'blessed';
   9
  10 # introspection
  11
  12 sub meta {
  13     require Class::MOP::Class;
  14     Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  15 }
  16
  17 sub _new {
  18     Class::MOP::class_of(shift)->new_object(@_);
  19 }
  20
  21 # RANT:
  22 # Cmon, how many times have you written
  23 # the following code while debugging:
  24 #
  25 #  use Data::Dumper;
  26 #  warn Dumper $obj;
  27 #
  28 # It can get seriously annoying, so why
  29 # not just do this ...
  30 sub dump {
  31     my $self = shift;
  32     require Data::Dumper;
  33     local $Data::Dumper::Maxdepth = shift || 1;
  34     Data::Dumper::Dumper $self;
  35 }
  36
  37 sub _real_ref_name {
  38     my $self = shift;
  39     return blessed($self);
  40 }
  41
  42 sub _is_compatible_with {
  43     my $self = shift;
  44     my ($other_name) = @_;
  45
  46     return $self->isa($other_name);
  47 }
  48
  49 sub _can_be_made_compatible_with {
  50     my $self = shift;
  51     return !$self->_is_compatible_with(@_)
  52         && defined($self->_get_compatible_metaclass(@_));
  53 }
  54
  55 sub _make_compatible_with {
  56     my $self = shift;
  57     my ($other_name) = @_;
  58
  59     my $new_metaclass = $self->_get_compatible_metaclass($other_name);
  60
  61     confess "Can't make $self compatible with metaclass $other_name"
  62         unless defined $new_metaclass;
  63
  64     # can't use rebless_instance here, because it might not be an actual
  65     # subclass in the case of, e.g. moose role reconciliation
  66     $new_metaclass->meta->_force_rebless_instance($self)
  67         if blessed($self) ne $new_metaclass;
  68
  69     return $self;
  70 }
  71
  72 sub _get_compatible_metaclass {
  73     my $self = shift;
  74     my ($other_name) = @_;
  75
  76     return $self->_get_compatible_metaclass_by_subclassing($other_name);
  77 }
  78
  79 sub _get_compatible_metaclass_by_subclassing {
  80     my $self = shift;
  81     my ($other_name) = @_;
  82     my $meta_name = blessed($self) ? $self->_real_ref_name : $self;
  83
  84     if ($meta_name->isa($other_name)) {
  85         return $meta_name;
  86     }
  87     elsif ($other_name->isa($meta_name)) {
  88         return $other_name;
  89     }
  90
  91     return;
  92 }
  93
  94 1;
  95
  96 __END__
  97
  98 =pod
  99
 100 =head1 NAME
 101
 102 Class::MOP::Object - Base class for metaclasses
 103
 104 =head1 DESCRIPTION
 105
 106 This class is a very minimal base class for metaclasses.
 107
 108 =head1 METHODS
 109
 110 This class provides a few methods which are useful in all metaclasses.
 111
 112 =over 4
 113
 114 =item B<< Class::MOP::???->meta >>
 115
 116 This returns a L<Class::MOP::Class> object.
 117
 118 =item B<< $metaobject->dump($max_depth) >>
 119
 120 This method uses L<Data::Dumper> to dump the object. You can pass an
 121 optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The
 122 default maximum depth is 1.
 123
 124 =back
 125
 126 =cut