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