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