--- /dev/null
+use strict;
+use warnings;
+
+use Config;
+use ExtUtils::MakeMaker;
+
+warn <<'EOF';
+
+ ********************************* WARNING **********************************
+
+ This module uses Dist::Zilla for development. This Build.PL will let you run
+ the tests, but you are encouraged to install Dist::Zilla and the needed
+ plugins if you intend on doing any serious hacking.
+
+ ****************************************************************************
+
+EOF
+
+my $ccflags = ( $Config::Config{ccflags} || '' ) . ' -I.';
+$ccflags .= ' -Wall -Wdeclaration-after-statement';
+
+my %mm = ( CCFLAGS => $ccflags );
+
+{
+ my (@OBJECT, %XS);
+
+ for my $xs (<xs/*.xs>) {
+ (my $c = $xs) =~ s/\.xs$/.c/i;
+ (my $o = $xs) =~ s/\.xs$/\$(OBJ_EXT)/i;
+
+ $XS{$xs} = $c;
+ push @OBJECT, $o;
+ }
+
+ for my $c (<*.c>) {
+ (my $o = $c) =~ s/\.c$/\$(OBJ_EXT)/i;
+ push @OBJECT, $o;
+ }
+
+ %mm = (
+ %mm,
+ clean => { FILES => join( q{ }, @OBJECT ) },
+ OBJECT => join( q{ }, @OBJECT ),
+ XS => \%XS,
+ );
+}
+
+WriteMakefile(
+ NAME => 'Moose',
+ %mm,
+);
+
+package MY;
+
+use Config;
+
+sub const_cccmd {
+ my $ret = shift->SUPER::const_cccmd(@_);
+ return q{} unless $ret;
+
+ if ($Config{cc} =~ /^cl\b/i) {
+ warn 'you are using MSVC... my condolences.';
+ $ret .= ' /Fo$@';
+ }
+ else {
+ $ret .= ' -o $@';
+ }
+
+ return $ret;
+}
+
+sub postamble {
+ return <<'EOF';
+$(OBJECT) : mop.h
+EOF
+}
+++ /dev/null
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include "ppport.h"
-
-#ifndef MGf_COPY
-# define MGf_COPY 0
-#endif
-
-#ifndef MGf_DUP
-# define MGf_DUP 0
-#endif
-
-#ifndef MGf_LOCAL
-# define MGf_LOCAL 0
-#endif
-
-STATIC int unset_export_flag (pTHX_ SV *sv, MAGIC *mg);
-
-STATIC MGVTBL export_flag_vtbl = {
- NULL, /* get */
- unset_export_flag, /* set */
- NULL, /* len */
- NULL, /* clear */
- NULL, /* free */
-#if MGf_COPY
- NULL, /* copy */
-#endif
-#if MGf_DUP
- NULL, /* dup */
-#endif
-#if MGf_LOCAL
- NULL, /* local */
-#endif
-};
-
-STATIC bool
-export_flag_is_set (pTHX_ SV *sv)
-{
- MAGIC *mg, *moremagic;
-
- if (SvTYPE(SvRV(sv)) != SVt_PVGV) {
- return 0;
- }
-
- for (mg = SvMAGIC(SvRV(sv)); mg; mg = moremagic) {
- moremagic = mg->mg_moremagic;
-
- if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &export_flag_vtbl) {
- break;
- }
- }
-
- return !!mg;
-}
-
-STATIC int
-unset_export_flag (pTHX_ SV *sv, MAGIC *mymg)
-{
- MAGIC *mg, *prevmagic = NULL, *moremagic = NULL;
-
- for (mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
- moremagic = mg->mg_moremagic;
-
- if (mg == mymg) {
- break;
- }
- }
-
- if (!mg) {
- return 0;
- }
-
- if (prevmagic) {
- prevmagic->mg_moremagic = moremagic;
- }
- else {
- SvMAGIC_set(sv, moremagic);
- }
-
- mg->mg_moremagic = NULL;
-
- Safefree (mg);
-
- return 0;
-}
-
-MODULE = Moose PACKAGE = Moose::Exporter
-
-void
-_flag_as_reexport (SV *sv)
- PROTOTYPE: \*
- CODE:
- sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, &export_flag_vtbl, NULL, 0);
-
-bool
-_export_is_flagged (SV *sv)
- PROTOTYPE: \*
- CODE:
- RETVAL = export_flag_is_set(aTHX_ sv);
- OUTPUT:
- RETVAL
--- /dev/null
+---
+- name: Point classes
+ classes:
+ - 'MOP::Point'
+ - 'MOP::Point3D'
+ - 'MOP::Immutable::Point'
+ - 'MOP::Immutable::Point3D'
+ - 'MOP::Installed::Point'
+ - 'MOP::Installed::Point3D'
+ - 'Plain::Point'
+ - 'Plain::Point3D'
+ benchmarks:
+ - class: 'Bench::Construct'
+ name: object construction
+ args:
+ y: 137
+ - class: 'Bench::Accessor'
+ name: accessor get
+ construct:
+ x: 4
+ y: 6
+ accessor: x
+ - class: 'Bench::Accessor'
+ name: accessor set
+ construct:
+ x: 4
+ y: 6
+ accessor: x
+ accessor_args: [ 5 ]
+
--- /dev/null
+#!perl -wd:NYTProf
+# a moose using script for profiling
+# Usage: perl bench/profile.pl
+
+require KiokuDB;
--- /dev/null
+#!/usr/bin/perl
+
+package Bench::Accessor;
+use Moose;
+use Moose::Util::TypeConstraints;
+
+eval {
+coerce ArrayRef
+ => from HashRef
+ => via { [ %$_ ] };
+};
+
+has class => (
+ isa => "Str",
+ is => "ro",
+);
+
+has construct => (
+ isa => "ArrayRef",
+ is => "ro",
+ auto_deref => 1,
+ coerce => 1,
+);
+
+has accessor => (
+ isa => "Str",
+ is => "ro",
+);
+
+has accessor_args => (
+ isa => "ArrayRef",
+ is => "ro",
+ auto_deref => 1,
+ coerce => 1,
+);
+
+sub code {
+ my $self = shift;
+
+ my $obj = $self->class->new( $self->construct );
+ my @accessor_args = $self->accessor_args;
+ my $accessor = $self->accessor;
+
+ sub { $obj->$accessor( @accessor_args ) };
+}
+
+__PACKAGE__;
+
+__END__
--- /dev/null
+#!/usr/bin/perl
+
+package Bench::Construct;
+use Moose;
+use Moose::Util::TypeConstraints;
+
+has class => (
+ isa => "Str",
+ is => "ro",
+);
+
+eval {
+coerce ArrayRef
+ => from HashRef
+ => via { [ %$_ ] };
+};
+
+has args => (
+ isa => "ArrayRef",
+ is => "ro",
+ auto_deref => 1,
+ coerce => 1,
+);
+
+sub code {
+ my $self = shift;
+
+ my $class = $self->class;
+ my @args = $self->args;
+
+ sub { my $obj = $class->new( @args ) }
+}
+
+__PACKAGE__;
+
+__END__
--- /dev/null
+#!/usr/bin/perl
+
+package Bench::Run;
+use Moose;
+
+use Benchmark qw/:hireswallclock :all/;
+
+has classes => (
+ isa => "ArrayRef",
+ is => "rw",
+ auto_deref => 1,
+);
+
+has benchmarks => (
+ isa => "ArrayRef",
+ is => "rw",
+ auto_deref => 1,
+);
+
+has min_time => (
+ isa => "Num",
+ is => "rw",
+ default => 5,
+);
+
+sub run {
+ my $self = shift;
+
+ foreach my $bench ( $self->benchmarks ) {
+ my $bench_class = delete $bench->{class};
+ my $name = delete $bench->{name} || $bench_class;
+ my @bench_args = %$bench;
+
+ eval "require $bench_class";
+ die $@ if $@;
+
+ my %res;
+
+ foreach my $class ( $self->classes ) {
+ eval "require $class";
+ die $@ if $@;
+
+ my $b = $bench_class->new( @bench_args, class => $class );
+ $res{$class} = countit( $self->min_time, $b->code );
+ }
+
+ print "- $name:\n";
+ cmpthese( \%res );
+ print "\n";
+ }
+}
+
+__PACKAGE__;
+
+__END__
--- /dev/null
+
+package MOP::Immutable::Point;
+
+use strict;
+use warnings;
+use metaclass;
+
+__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
+__PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
+
+sub clear {
+ my $self = shift;
+ $self->x(0);
+ $self->y(0);
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+__END__
--- /dev/null
+
+package MOP::Immutable::Point3D;
+
+use strict;
+use warnings;
+use metaclass;
+
+use base 'MOP::Point';
+
+__PACKAGE__->meta->add_attribute('z' => (accessor => 'z'));
+
+sub clear {
+ my $self = shift;
+ $self->SUPER::clear();
+ $self->z(0);
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+__END__
\ No newline at end of file
--- /dev/null
+
+use lib reverse @INC;
+
+package MOP::Installed::Point;
+
+use strict;
+use warnings;
+use metaclass;
+
+__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
+__PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
+
+sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+}
+
+sub clear {
+ my $self = shift;
+ $self->x(0);
+ $self->y(0);
+}
+
+1;
+
+__END__
\ No newline at end of file
--- /dev/null
+
+use lib reverse @INC;
+
+package MOP::Installed::Point3D;
+
+use strict;
+use warnings;
+use metaclass;
+
+use base 'MOP::Point';
+
+__PACKAGE__->meta->add_attribute('z' => (accessor => 'z'));
+
+sub clear {
+ my $self = shift;
+ $self->SUPER::clear();
+ $self->z(0);
+}
+
+1;
+
+__END__
\ No newline at end of file
--- /dev/null
+
+package MOP::Point;
+
+use strict;
+use warnings;
+use metaclass;
+
+__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
+__PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
+
+sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+}
+
+sub clear {
+ my $self = shift;
+ $self->x(0);
+ $self->y(0);
+}
+
+1;
+
+__END__
\ No newline at end of file
--- /dev/null
+
+package MOP::Point3D;
+
+use strict;
+use warnings;
+use metaclass;
+
+use base 'MOP::Point';
+
+__PACKAGE__->meta->add_attribute('z' => (accessor => 'z'));
+
+sub clear {
+ my $self = shift;
+ $self->SUPER::clear();
+ $self->z(0);
+}
+
+1;
+
+__END__
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+package Plain::Point;
+
+use strict;
+use warnings;
+
+sub new {
+ my ( $class, %params ) = @_;
+
+ return bless {
+ x => $params{x} || 10,
+ y => $params{y},
+ }, $class;
+}
+
+sub x {
+ my ( $self, @args ) = @_;
+
+ if ( @args ) {
+ $self->{x} = $args[0];
+ }
+
+ return $self->{x};
+}
+
+sub y {
+ my ( $self, @args ) = @_;
+
+ if ( @args ) {
+ $self->{y} = $args[0];
+ }
+
+ return $self->{y};
+}
+
+sub clear {
+ my $self = shift;
+ @{$self}{qw/x y/} = (0, 0);
+}
+
+__PACKAGE__;
+
+__END__
+
--- /dev/null
+#!/usr/bin/perl
+
+package Plain::Point3D;
+
+use strict;
+use warnings;
+
+use base 'Plain::Point';
+
+sub new {
+ my ( $class, %params ) = @_;
+ my $self = $class->SUPER::new( %params );
+ $self->{z} = $params{z};
+ return $self;
+}
+
+sub z {
+ my ( $self, @args ) = @_;
+
+ if ( @args ) {
+ $self->{z} = $args[0];
+ }
+
+ return $self->{z};
+}
+
+sub clear {
+ my $self = shift;
+ $self->SUPER::clear();
+ $self->{z} = 0;
+}
+
+__PACKAGE__;
+
+__END__
+
--- /dev/null
+#!perl -w
+use strict;
+use Benchmark qw(:all);
+
+my ( $count, $module ) = @ARGV;
+$count ||= 10;
+$module ||= 'Moose';
+
+my @blib
+ = qw(-Iblib/lib -Iblib/arch -I../Moose/blib/lib -I../Moose/blib/arch -I../Moose/lib);
+
+$| = 1; # autoflush
+
+print 'Installed: ';
+system $^X, '-le', 'require Moose; print $INC{q{Moose.pm}}';
+
+print 'Blead: ';
+system $^X, @blib, '-le', 'require Moose; print $INC{q{Moose.pm}}';
+
+cmpthese timethese $count => {
+ released => sub {
+ system( $^X, '-e', "require $module" ) == 0 or die;
+ },
+ blead => sub {
+ system( $^X, @blib, '-e', "require $module" ) == 0 or die;
+ },
+};
--- /dev/null
+#!perl -w
+# Usage: perl bench/profile.pl (no other options including -Mblib are reqired)
+
+use strict;
+
+my $script = 'bench/foo.pl';
+
+my $branch = do {
+ open my $in, '.git/HEAD' or die "Cannot open .git/HEAD: $!";
+ my $s = scalar <$in>;
+ chomp $s;
+ $s =~ s{^ref: \s+ refs/heads/}{}xms;
+ $s =~ s{/}{_}xmsg;
+ $s;
+};
+
+print "Profiling $branch ...\n";
+
+my @cmd = ( $^X, '-Iblib/lib', '-Iblib/arch', $script );
+print "> @cmd\n";
+system(@cmd) == 0 or die "Cannot profile";
+
+@cmd = ( $^X, '-S', 'nytprofhtml', '--out', "nytprof-$branch" );
+print "> @cmd\n";
+system(@cmd) == 0 or die "Cannot profile";
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use YAML::Syck;
+use Bench::Run;
+
+my $data = LoadFile( shift || "$FindBin::Bin/all.yml" );
+
+foreach my $bench ( @$data ) {
+ print "== ", delete $bench->{name}, " ==\n\n";
+ Bench::Run->new( %$bench )->run;
+ print "\n\n";
+}
+
+
[@Basic]
+[PruneFiles]
+filenames = Makefile.PL
+
[PkgVersion]
[Metadata]
[CheckChangeLog]
[Prereqs]
-Class::MOP = 1.11
Data::OptList = 0
+Devel::GlobalDestruction = 0
+Eval::Closure = 0
List::MoreUtils = 0.12
+MRO::Compat = 0.05
Package::DeprecationManager = 0.10
+Package::Stash = 0.15
+Package::Stash::XS = 0.17
Params::Util = 1.00
Scalar::Util = 1.19
Sub::Exporter = 0.980
-Sub::Name = 0
+Sub::Name = 0.05
Task::Weaken = 0
Try::Tiny = 0.02
perl = 5.8.3
Test::Requires = 0.05
[Prereqs / DevelopRequires]
+Algorithm::C3 = 0
DateTime = 0
DateTime::Calendar::Mayan = 0
DateTime::Format::MySQL = 0
Regexp::Common = 0
Test::Deep = 0
Test::Inline = 0
+Test::LeakTrace = 0
Test::Output = 0
URI = 0
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Data::Dumper;
+use B::Deparse;
+use Template;
+use Getopt::Long;
+use CGI;
+
+use Class::MOP;
+
+my $stand_alone = 0;
+GetOptions("s" => \$stand_alone);
+
+if ($stand_alone) {
+ require HTTP::Server::Simple::CGI;
+ {
+ package # hide me from PAUSE
+ Class::MOP::Browser::Server;
+ our @ISA = qw(HTTP::Server::Simple::CGI);
+ sub handle_request { ::process_template() }
+ }
+ Class::MOP::Browser::Server->new()->run();
+}
+else {
+ print CGI::header();
+ process_template();
+}
+
+{
+ my $DATA;
+ sub process_template {
+ $DATA ||= join "" => <DATA>;
+ Template->new->process(
+ \$DATA,
+ {
+ 'get_all_metaclasses' => \&::get_all_metaclasses,
+ 'get_metaclass_by_name' => \&::get_metaclass_by_name,
+ 'deparse_method' => \&::deparse_method,
+ 'deparse_item' => \&::deparse_item,
+ }
+ ) or warn Template->error;
+ }
+}
+
+sub get_all_metaclasses {
+ sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances()
+}
+
+sub get_metaclass_by_name {
+ Class::MOP::get_metaclass_by_name(@_);
+}
+
+sub deparse_method {
+ my ($method) = @_;
+ my $deparse = B::Deparse->new("-d");
+ my $body = $deparse->coderef2text($method->body());
+ return "sub " . $method->name . ' ' . _clean_deparse_code($body);
+}
+
+sub deparse_item {
+ my ($item) = @_;
+ return $item unless ref $item;
+ local $Data::Dumper::Deparse = 1;
+ local $Data::Dumper::Indent = 1;
+ my $dumped = Dumper $item;
+ $dumped =~ s/^\$VAR1\s=\s//;
+ $dumped =~ s/\;$//;
+ return _clean_deparse_code($dumped);
+}
+
+sub _clean_deparse_code {
+ my @body = split /\n/ => $_[0];
+ my @cleaned;
+ foreach (@body) {
+ next if /^\s+use/;
+ next if /^\s+BEGIN/;
+ next if /^\s+package/;
+ push @cleaned => $_;
+ }
+ return (join "\n" => @cleaned);
+}
+
+1;
+
+## This is the template file to be used
+
+__DATA__
+[% USE q = CGI %]
+
+[% area = 'attributes' %]
+[% IF q.param('area') %]
+ [% area = q.param('area') %]
+[% END %]
+
+<html>
+<head>
+<title>Class::MOP Browser</title>
+<style type='text/css'>
+
+body {
+ font-family: arial;
+}
+
+td { font-size: 12px; }
+b { font-size: 12px; }
+
+pre {
+ font-family: courier;
+ font-size: 12px;
+ width: 330px;
+ padding: 10px;
+ overflow: auto;
+ border: 1px dotted green;
+}
+
+A {
+ font-family: arial;
+ font-size: 12px;
+ color: black;
+ text-decoration: none;
+}
+
+A:hover {
+ text-decoration: underline;
+}
+
+td.lightblue {
+ background-color: #99BBFF;
+ border-right: 1px solid #336699;
+ border-bottom: 1px solid #336699;
+ border-top: 1px solid #BBDDFF;
+ border-left: 1px solid #BBDDFF;
+}
+
+td.grey {
+ background-color: #CCCCCC;
+ border-right: 1px solid #888888;
+ border-bottom: 1px solid #888888;
+ border-top: 1px solid #DDDDDD;
+ border-left: 1px solid #DDDDDD;
+}
+
+td.manila {
+ background-color: #FFDD99;
+ border-right: 2px solid #CC9933;
+ border-bottom: 2px solid #CC9933;
+ border-top: 2px solid #FFFFBB;
+ border-left: 2px solid #FFFFBB;
+}
+
+td.darkgreen {
+ background-color: #33CC33;
+ border-right: 1px solid #009900;
+ border-bottom: 1px solid #009900;
+ color: #CCFFCC;
+}
+
+td.lightgreen {
+ background-color: #AAFFAA;
+ border-right: 1px solid #33FF33;
+ border-bottom: 1px solid #33FF33;
+}
+
+</style>
+</head>
+<body>
+<h1>Class::MOP Browser</h1>
+<table bgcolor='#CCCCCC' cellpadding='0' cellspacing='0' border='0' align='center' height='400'>
+<tr valign='top'>
+
+<td rowspan='2' width='200'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
+ [% FOREACH metaclass IN get_all_metaclasses() %]
+ <tr>
+ [% IF q.param('class') == metaclass.name %]
+ <td class='lightblue'><b>[% metaclass.name %]</b></td>
+ [% ELSE %]
+ <td class='grey'><a href='?class=[% metaclass.name %]'>[% metaclass.name %]</a></td>
+ [% END %]
+ </tr>
+ [% END %]
+ </table></td>
+<td height='10' width='250'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
+ <tr align='center'>
+ [% FOREACH area_name IN [ 'attributes', 'methods', 'superclasses' ] %]
+ [% IF q.param('class') %]
+ [% IF area == area_name %]
+ <td class='manila'><b>[% area_name %]</b></td>
+ [% ELSE %]
+ <td class='lightblue'><a href='?class=[% q.param('class') %]&area=[% area_name %]'>[% area_name %]</a></td>
+ [% END %]
+ [% ELSE %]
+ <td class='lightblue' style="color: #336699;">[% area_name %]</td>
+ [% END %]
+ [% END %]
+ </tr>
+ </table></td>
+
+<td valign='top' rowspan='2' class='lightgreen' width='450'>
+ <table cellspacing='0' cellpadding='3' border='0'>
+ <tr>
+ <td class='darkgreen' width='100'></td>
+ <td class='darkgreen' width='350'></td>
+ </tr>
+ [% IF q.param('class') && area == 'attributes' && q.param('attr') %]
+
+ [%
+ meta = get_metaclass_by_name(q.param('class'))
+ attr = meta.get_attribute(q.param('attr'))
+ %]
+
+ [% FOREACH aspect IN [ 'name', 'init_arg', 'reader', 'writer', 'accessor', 'predicate', 'default' ]%]
+ [% item = attr.$aspect() %]
+ <tr>
+ <td class='darkgreen' align='right' valign='top'>[% aspect %]</td>
+ <td class='lightgreen'>[% IF item == undef %]—[% ELSE %]<pre>[% deparse_item(item) %]</pre>[% END %]</td>
+ </tr>
+ [% END %]
+
+ [% ELSIF q.param('class') && area == 'methods' && q.param('method') %]
+
+ [%
+ meta = get_metaclass_by_name(q.param('class'))
+ method = meta.get_method(q.param('method'))
+ %]
+
+ [% FOREACH aspect IN [ 'name', 'package_name', 'fully_qualified_name' ]%]
+ <tr>
+ <td class='darkgreen' align='right' valign='top'>[% aspect %]</td>
+ <td class='lightgreen'>[% method.$aspect() %]</td>
+ </tr>
+ [% END %]
+ <tr>
+ <td class='darkgreen' align='right' valign='top'>body</td>
+ <td class='lightgreen'><pre>[% deparse_method(method) %]</pre></td>
+ </tr>
+
+ [% END %]
+ </table></td>
+
+</tr>
+<tr>
+
+[% IF q.param('class') && area %]
+
+[% meta = get_metaclass_by_name(q.param('class')) %]
+
+<td class='lightblue' valign='top'><div style='height: 100%; overflow: auto;'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
+
+ [% IF area == 'methods' %]
+ [% FOREACH method IN meta.get_method_list.sort %]
+ <tr>
+ [% IF q.param('method') == method %]
+ <td class='darkgreen'><b>[% method %]</b></td>
+ [% ELSE %]
+ <td class='manila'><a href='?class=[% q.param('class') %]&area=[% q.param('area') %]&method=[% method %]'>[% method %]</a></td>
+ [% END %]
+ </tr>
+ [% END %]
+ [% END %]
+ [% IF area == 'attributes' %]
+ [% FOREACH attr IN meta.get_attribute_list.sort %]
+ <tr>
+ [% IF q.param('attr') == attr %]
+ <td class='darkgreen'><b>[% attr %]</b></td>
+ [% ELSE %]
+ <td class='manila'><a href='?class=[% q.param('class') %]&area=[% q.param('area') %]&attr=[% attr %]'>[% attr %]</a></td>
+ [% END %]
+ </tr>
+ [% END %]
+ [% END %]
+ [% IF area == 'superclasses' %]
+ [% FOREACH super IN meta.superclasses.sort %]
+ <tr>
+ <td class='manila'><a href='?class=[% super %]'>[% super %]</a></td>
+ </tr>
+ [% END %]
+ [% END %]
+ </table></div></td>
+[% END %]
+
+</tr>
+</table>
+</body>
+</html>
+
--- /dev/null
+
+package # hide the package from PAUSE
+ ArrayBasedStorage::Instance;
+
+use strict;
+use warnings;
+use Scalar::Util qw/refaddr/;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+my $unbound = \'empty-slot-value';
+
+use base 'Class::MOP::Instance';
+
+sub new {
+ my ($class, $meta, @attrs) = @_;
+ my $self = $class->SUPER::new($meta, @attrs);
+ my $index = 0;
+ $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots };
+ return $self;
+}
+
+sub create_instance {
+ my $self = shift;
+ my $instance = bless [], $self->_class_name;
+ $self->initialize_all_slots($instance);
+ return $instance;
+}
+
+sub clone_instance {
+ my ($self, $instance) = shift;
+ $self->bless_instance_structure([ @$instance ]);
+}
+
+# operations on meta instance
+
+sub get_slot_index_map { (shift)->{'slot_index_map'} }
+
+sub initialize_slot {
+ my ($self, $instance, $slot_name) = @_;
+ $self->set_slot_value($instance, $slot_name, $unbound);
+}
+
+sub deinitialize_slot {
+ my ( $self, $instance, $slot_name ) = @_;
+ $self->set_slot_value($instance, $slot_name, $unbound);
+}
+
+sub get_all_slots {
+ my $self = shift;
+ return sort $self->SUPER::get_all_slots;
+}
+
+sub get_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
+ return $value unless ref $value;
+ refaddr $value eq refaddr $unbound ? undef : $value;
+}
+
+sub set_slot_value {
+ my ($self, $instance, $slot_name, $value) = @_;
+ $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value;
+}
+
+sub is_slot_initialized {
+ my ($self, $instance, $slot_name) = @_;
+ # NOTE: maybe use CLOS's *special-unbound-value* for this?
+ my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
+ return 1 unless ref $value;
+ refaddr $value eq refaddr $unbound ? 0 : 1;
+}
+
+sub is_dependent_on_superclasses { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ArrayBasedStorage - An example of an Array based instance storage
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use metaclass (
+ ':instance_metaclass' => 'ArrayBasedStorage::Instance'
+ );
+
+ __PACKAGE__->meta->add_attribute('foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ # now you can just use the class as normal
+
+=head1 DESCRIPTION
+
+This is a proof of concept using the Instance sub-protocol
+which uses ARRAY refs to store the instance data.
+
+This is very similar now to the InsideOutClass example, and
+in fact, they both share the exact same test suite, with
+the only difference being the Instance metaclass they use.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 SEE ALSO
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+
+package # hide the package from PAUSE
+ AttributesWithHistory;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.05';
+
+use base 'Class::MOP::Attribute';
+
+# this is for an extra attribute constructor
+# option, which is to be able to create a
+# way for the class to access the history
+AttributesWithHistory->meta->add_attribute('history_accessor' => (
+ reader => 'history_accessor',
+ init_arg => 'history_accessor',
+ predicate => 'has_history_accessor',
+));
+
+# this is a place to store the actual
+# history of the attribute
+AttributesWithHistory->meta->add_attribute('_history' => (
+ accessor => '_history',
+ default => sub { {} },
+));
+
+sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' }
+
+AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub {
+ my ($self) = @_;
+ # and now add the history accessor
+ $self->associated_class->add_method(
+ $self->_process_accessors('history_accessor' => $self->history_accessor())
+ ) if $self->has_history_accessor();
+});
+
+package # hide the package from PAUSE
+ AttributesWithHistory::Method::Accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Method::Accessor';
+
+# generate the methods
+
+sub _generate_history_accessor_method {
+ my $attr_name = (shift)->associated_attribute->name;
+ eval qq{sub {
+ unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+ \}
+ \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\};
+ }};
+}
+
+sub _generate_accessor_method {
+ my $attr_name = (shift)->associated_attribute->name;
+ eval qq{sub {
+ if (scalar(\@_) == 2) {
+ unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+ \}
+ push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
+ \$_[0]->{'$attr_name'} = \$_[1];
+ }
+ \$_[0]->{'$attr_name'};
+ }};
+}
+
+sub _generate_writer_method {
+ my $attr_name = (shift)->associated_attribute->name;
+ eval qq{sub {
+ unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+ \}
+ push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
+ \$_[0]->{'$attr_name'} = \$_[1];
+ }};
+}
+
+1;
+
+=pod
+
+=head1 NAME
+
+AttributesWithHistory - An example attribute metaclass which keeps a history of changes
+
+=head1 SYSNOPSIS
+
+ package Foo;
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('foo' => (
+ accessor => 'foo',
+ history_accessor => 'get_foo_history',
+ )));
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ history_accessor => 'get_bar_history',
+ )));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+=head1 DESCRIPTION
+
+This is an example of an attribute metaclass which keeps a
+record of all the values it has been assigned. It stores the
+history as a field in the attribute meta-object, and will
+autogenerate a means of accessing that history for the class
+which these attributes are added too.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+
+package # hide from PAUSE
+ C3MethodDispatchOrder;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Algorithm::C3;
+
+our $VERSION = '0.03';
+
+use base 'Class::MOP::Class';
+
+my $_find_method = sub {
+ my ($class, $method) = @_;
+ foreach my $super ($class->class_precedence_list) {
+ return $super->meta->get_method($method)
+ if $super->meta->has_method($method);
+ }
+};
+
+C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub {
+ my $cont = shift;
+ my $meta = $cont->(@_);
+
+ # we need to look at $AUTOLOAD in the package where the coderef belongs
+ # if subname works, then it'll be where this AUTOLOAD method was installed
+ # otherwise, it'll be $C3MethodDispatchOrder::AUTOLOAD. get_code_info
+ # tells us where AUTOLOAD will look
+ my $autoload;
+ $autoload = sub {
+ my ($package) = Class::MOP::get_code_info($autoload);
+ my $label = ${ $package->meta->get_package_symbol('$AUTOLOAD') };
+ my $method_name = (split /\:\:/ => $label)[-1];
+ my $method = $_find_method->($_[0]->meta, $method_name);
+ (defined $method) || confess "Method ($method_name) not found";
+ goto &$method;
+ };
+
+ $meta->add_method('AUTOLOAD' => $autoload)
+ unless $meta->has_method('AUTOLOAD');
+
+ $meta->add_method('can' => sub {
+ $_find_method->($_[0]->meta, $_[1]);
+ }) unless $meta->has_method('can');
+
+ return $meta;
+});
+
+sub superclasses {
+ my $self = shift;
+
+ $self->add_package_symbol('@SUPERS' => [])
+ unless $self->has_package_symbol('@SUPERS');
+
+ if (@_) {
+ my @supers = @_;
+ @{$self->get_package_symbol('@SUPERS')} = @supers;
+ }
+ @{$self->get_package_symbol('@SUPERS')};
+}
+
+sub class_precedence_list {
+ my $self = shift;
+ return map {
+ $_->name;
+ } Algorithm::C3::merge($self, sub {
+ my $class = shift;
+ map { $_->meta } $class->superclasses;
+ });
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order
+
+=head1 SYNOPSIS
+
+ # a classic diamond inheritence graph
+ #
+ # <A>
+ # / \
+ # <B> <C>
+ # \ /
+ # <D>
+
+ package A;
+ use metaclass 'C3MethodDispatchOrder';
+
+ sub hello { return "Hello from A" }
+
+ package B;
+ use metaclass 'C3MethodDispatchOrder';
+ B->meta->superclasses('A');
+
+ package C;
+ use metaclass 'C3MethodDispatchOrder';
+ C->meta->superclasses('A');
+
+ sub hello { return "Hello from C" }
+
+ package D;
+ use metaclass 'C3MethodDispatchOrder';
+ D->meta->superclasses('B', 'C');
+
+ print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A
+
+ # later in other code ...
+
+ print D->hello; # print 'Hello from C' instead of the normal 'Hello from A'
+
+=head1 DESCRIPTION
+
+This is an example of how you could change the method dispatch order of a
+class using L<Class::MOP>. Using the L<Algorithm::C3> module, this repleces
+the normal depth-first left-to-right perl dispatch order with the C3 method
+dispatch order (see the L<Algorithm::C3> or L<Class::C3> docs for more
+information about this).
+
+This example could be used as a template for other method dispatch orders
+as well, all that is required is to write a the C<class_precedence_list> method
+which will return a linearized list of classes to dispatch along.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
--- /dev/null
+
+package # hide the package from PAUSE
+ ClassEncapsulatedAttributes;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.06';
+
+use base 'Class::MOP::Class';
+
+sub initialize {
+ (shift)->SUPER::initialize(@_,
+ # use the custom attribute metaclass here
+ 'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute',
+ );
+}
+
+sub construct_instance {
+ my ($class, %params) = @_;
+
+ my $meta_instance = $class->get_meta_instance;
+ my $instance = $meta_instance->create_instance();
+
+ # initialize *ALL* attributes, including masked ones (as opposed to applicable)
+ foreach my $current_class ($class->class_precedence_list()) {
+ my $meta = $current_class->meta;
+ foreach my $attr_name ($meta->get_attribute_list()) {
+ my $attr = $meta->get_attribute($attr_name);
+ $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+ }
+ }
+
+ return $instance;
+}
+
+package # hide the package from PAUSE
+ ClassEncapsulatedAttributes::Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.04';
+
+use base 'Class::MOP::Attribute';
+
+# alter the way parameters are specified
+sub initialize_instance_slot {
+ my ($self, $meta_instance, $instance, $params) = @_;
+ # if the attr has an init_arg, use that, otherwise,
+ # use the attributes name itself as the init_arg
+ my $init_arg = $self->init_arg();
+ # try to fetch the init arg from the %params ...
+ my $class = $self->associated_class;
+ my $val;
+ $val = $params->{$class->name}->{$init_arg}
+ if exists $params->{$class->name} &&
+ exists ${$params->{$class->name}}{$init_arg};
+ # if nothing was in the %params, we can use the
+ # attribute's default value (if it has one)
+ if (!defined $val && $self->has_default) {
+ $val = $self->default($instance);
+ }
+
+ # now add this to the instance structure
+ $meta_instance->set_slot_value($instance, $self->name, $val);
+}
+
+sub name {
+ my $self = shift;
+ return ($self->associated_class->name . '::' . $self->SUPER::name)
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use metaclass 'ClassEncapsulatedAttributes';
+
+ Foo->meta->add_attribute('foo' => (
+ accessor => 'Foo_foo',
+ default => 'init in FOO'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ # duplicate the attribute name here
+ Bar->meta->add_attribute('foo' => (
+ accessor => 'Bar_foo',
+ default => 'init in BAR'
+ ));
+
+ # ... later in other code ...
+
+ my $bar = Bar->new();
+ prints $bar->Bar_foo(); # init in BAR
+ prints $bar->Foo_foo(); # init in FOO
+
+ # and ...
+
+ my $bar = Bar->new(
+ 'Foo' => { 'foo' => 'Foo::foo' },
+ 'Bar' => { 'foo' => 'Bar::foo' }
+ );
+
+ prints $bar->Bar_foo(); # Foo::foo
+ prints $bar->Foo_foo(); # Bar::foo
+
+=head1 DESCRIPTION
+
+This is an example metaclass which encapsulates a class's
+attributes on a per-class basis. This means that there is no
+possibility of name clashes with inherited attributes. This
+is similar to how C++ handles its data members.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Yuval "nothingmuch" Kogman for the idea for this example.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+
+package # hide the package from PAUSE
+ InsideOutClass::Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+use Carp 'confess';
+use Scalar::Util 'refaddr';
+
+use base 'Class::MOP::Attribute';
+
+sub initialize_instance_slot {
+ my ($self, $meta_instance, $instance, $params) = @_;
+ my $init_arg = $self->init_arg;
+ # try to fetch the init arg from the %params ...
+ my $val;
+ $val = $params->{$init_arg} if exists $params->{$init_arg};
+ # if nothing was in the %params, we can use the
+ # attribute's default value (if it has one)
+ if (!defined $val && defined $self->default) {
+ $val = $self->default($instance);
+ }
+ my $_meta_instance = $self->associated_class->get_meta_instance;
+ $_meta_instance->initialize_slot($instance, $self->name);
+ $_meta_instance->set_slot_value($instance, $self->name, $val);
+}
+
+sub accessor_metaclass { 'InsideOutClass::Method::Accessor' }
+
+package # hide the package from PAUSE
+ InsideOutClass::Method::Accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Carp 'confess';
+use Scalar::Util 'refaddr';
+
+use base 'Class::MOP::Method::Accessor';
+
+## Method generation helpers
+
+sub _generate_accessor_method {
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
+ return sub {
+ my $meta_instance = $meta_class->get_meta_instance;
+ $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
+ $meta_instance->get_slot_value($_[0], $attr_name);
+ };
+}
+
+sub _generate_reader_method {
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
+ return sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ $meta_class->get_meta_instance
+ ->get_slot_value($_[0], $attr_name);
+ };
+}
+
+sub _generate_writer_method {
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
+ return sub {
+ $meta_class->get_meta_instance
+ ->set_slot_value($_[0], $attr_name, $_[1]);
+ };
+}
+
+sub _generate_predicate_method {
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
+ return sub {
+ defined $meta_class->get_meta_instance
+ ->get_slot_value($_[0], $attr_name) ? 1 : 0;
+ };
+}
+
+package # hide the package from PAUSE
+ InsideOutClass::Instance;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Carp 'confess';
+use Scalar::Util 'refaddr';
+
+use base 'Class::MOP::Instance';
+
+sub create_instance {
+ my ($self, $class) = @_;
+ bless \(my $instance), $self->_class_name;
+}
+
+sub get_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance};
+}
+
+sub set_slot_value {
+ my ($self, $instance, $slot_name, $value) = @_;
+ $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value;
+}
+
+sub initialize_slot {
+ my ($self, $instance, $slot_name) = @_;
+ $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {})
+ unless $self->associated_metaclass->has_package_symbol('%' . $slot_name);
+ $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef;
+}
+
+sub is_slot_initialized {
+ my ($self, $instance, $slot_name) = @_;
+ return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name);
+ return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InsideOutClass - A set of example metaclasses which implement the Inside-Out technique
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use metaclass (
+ ':attribute_metaclass' => 'InsideOutClass::Attribute',
+ ':instance_metaclass' => 'InsideOutClass::Instance'
+ );
+
+ __PACKAGE__->meta->add_attribute('foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ # now you can just use the class as normal
+
+=head1 DESCRIPTION
+
+This is a set of example metaclasses which implement the Inside-Out
+class technique. What follows is a brief explaination of the code
+found in this module.
+
+We must create a subclass of B<Class::MOP::Instance> and override
+the slot operations. This requires
+overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and
+C<initialize_slot>, as well as their inline counterparts. Additionally we
+overload C<add_slot> in order to initialize the global hash containing the
+actual slot values.
+
+And that is pretty much all. Of course I am ignoring need for
+inside-out objects to be C<DESTROY>-ed, and some other details as
+well (threading, etc), but this is an example. A real implementation is left as
+an exercise to the reader.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+
+package # hide the package from PAUSE
+ InstanceCountingClass;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.03';
+
+use base 'Class::MOP::Class';
+
+InstanceCountingClass->meta->add_attribute('count' => (
+ reader => 'get_count',
+ default => 0
+));
+
+InstanceCountingClass->meta->add_before_method_modifier('_construct_instance' => sub {
+ my ($class) = @_;
+ $class->{'count'}++;
+});
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InstanceCountingClass - An example metaclass which counts instances
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use metaclass 'InstanceCountingClass';
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ # ... meanwhile, somewhere in the code
+
+ my $foo = Foo->new();
+ print Foo->meta->get_count(); # prints 1
+
+ my $foo2 = Foo->new();
+ print Foo->meta->get_count(); # prints 2
+
+ # ... etc etc etc
+
+=head1 DESCRIPTION
+
+This is a classic example of a metaclass which keeps a count of each
+instance which is created.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+
+package # hide the package from PAUSE
+ LazyClass::Attribute;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.05';
+
+use base 'Class::MOP::Attribute';
+
+sub initialize_instance_slot {
+ my ($self, $meta_instance, $instance, $params) = @_;
+
+ # if the attr has an init_arg, use that, otherwise,
+ # use the attributes name itself as the init_arg
+ my $init_arg = $self->init_arg();
+
+ if ( exists $params->{$init_arg} ) {
+ my $val = $params->{$init_arg};
+ $meta_instance->set_slot_value($instance, $self->name, $val);
+ }
+}
+
+sub accessor_metaclass { 'LazyClass::Method::Accessor' }
+
+package # hide the package from PAUSE
+ LazyClass::Method::Accessor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Method::Accessor';
+
+sub _generate_accessor_method {
+ my $attr = (shift)->associated_attribute;
+
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->get_meta_instance;
+
+ sub {
+ if (scalar(@_) == 2) {
+ $meta_instance->set_slot_value($_[0], $attr_name, $_[1]);
+ }
+ else {
+ unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
+ my $value = $attr->has_default ? $attr->default($_[0]) : undef;
+ $meta_instance->set_slot_value($_[0], $attr_name, $value);
+ }
+
+ $meta_instance->get_slot_value($_[0], $attr_name);
+ }
+ };
+}
+
+sub _generate_reader_method {
+ my $attr = (shift)->associated_attribute;
+
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->get_meta_instance;
+
+ sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+
+ unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
+ my $value = $attr->has_default ? $attr->default($_[0]) : undef;
+ $meta_instance->set_slot_value($_[0], $attr_name, $value);
+ }
+
+ $meta_instance->get_slot_value($_[0], $attr_name);
+ };
+}
+
+package # hide the package from PAUSE
+ LazyClass::Instance;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Instance';
+
+sub initialize_all_slots {}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+LazyClass - An example metaclass with lazy initialization
+
+=head1 SYNOPSIS
+
+ package BinaryTree;
+
+ use metaclass (
+ ':attribute_metaclass' => 'LazyClass::Attribute',
+ ':instance_metaclass' => 'LazyClass::Instance',
+ );
+
+ BinaryTree->meta->add_attribute('node' => (
+ accessor => 'node',
+ init_arg => ':node'
+ ));
+
+ BinaryTree->meta->add_attribute('left' => (
+ reader => 'left',
+ default => sub { BinaryTree->new() }
+ ));
+
+ BinaryTree->meta->add_attribute('right' => (
+ reader => 'right',
+ default => sub { BinaryTree->new() }
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ # ... later in code
+
+ my $btree = BinaryTree->new();
+ # ... $btree is an empty hash, no keys are initialized yet
+
+=head1 DESCRIPTION
+
+This is an example metclass in which all attributes are created
+lazily. This means that no entries are made in the instance HASH
+until the last possible moment.
+
+The example above of a binary tree is a good use for such a
+metaclass because it allows the class to be space efficient
+without complicating the programing of it. This would also be
+ideal for a class which has a large amount of attributes,
+several of which are optional.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+
+package # hide the package from PAUSE
+ Perl6Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+use base 'Class::MOP::Attribute';
+
+Perl6Attribute->meta->add_around_method_modifier('new' => sub {
+ my $cont = shift;
+ my ($class, $attribute_name, %options) = @_;
+
+ # extract the sigil and accessor name
+ my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/);
+
+ # pass the accessor name
+ $options{accessor} = $accessor_name;
+
+ # create a default value based on the sigil
+ $options{default} = sub { [] } if ($sigil eq '@');
+ $options{default} = sub { {} } if ($sigil eq '%');
+
+ $cont->($class, $attribute_name, %options);
+});
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl6Attribute - An example attribute metaclass for Perl 6 style attributes
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
+ Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));
+ Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+=head1 DESCRIPTION
+
+This is an attribute metaclass which implements Perl 6 style
+attributes, including the auto-generating accessors.
+
+This code is very simple, we only need to subclass
+C<Class::MOP::Attribute> and override C<&new>. Then we just
+pre-process the attribute name, and create the accessor name
+and default value based on it.
+
+More advanced features like the C<handles> trait (see
+L<Perl6::Bible/A12>) can be accomplished as well doing the
+same pre-processing approach. This is left as an exercise to
+the reader though (if you do it, please send me a patch
+though, and will update this).
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
--- /dev/null
+
+package Class::MOP;
+
+use strict;
+use warnings;
+
+use 5.008;
+
+use MRO::Compat;
+
+use Carp 'confess';
+use Scalar::Util 'weaken', 'isweak', 'reftype', 'blessed';
+use Data::OptList;
+use Try::Tiny;
+
+use Class::MOP::Mixin::AttributeCore;
+use Class::MOP::Mixin::HasAttributes;
+use Class::MOP::Mixin::HasMethods;
+use Class::MOP::Class;
+use Class::MOP::Attribute;
+use Class::MOP::Method;
+
+BEGIN {
+ *IS_RUNNING_ON_5_10 = ($] < 5.009_005)
+ ? sub () { 0 }
+ : sub () { 1 };
+
+ # this is either part of core or set up appropriately by MRO::Compat
+ *check_package_cache_flag = \&mro::get_pkg_gen;
+}
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+XSLoader::load(
+ 'Moose',
+ $Moose::{VERSION} ? $Moose::{VERSION}
+ : $ENV{_XS_VERSION} ? $ENV{_XS_VERSION}
+ : ()
+);
+
+{
+ # Metaclasses are singletons, so we cache them here.
+ # there is no need to worry about destruction though
+ # because they should die only when the program dies.
+ # After all, do package definitions even get reaped?
+ # Anonymous classes manage their own destruction.
+ my %METAS;
+
+ sub get_all_metaclasses { %METAS }
+ sub get_all_metaclass_instances { values %METAS }
+ sub get_all_metaclass_names { keys %METAS }
+ sub get_metaclass_by_name { $METAS{$_[0]} }
+ sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] }
+ sub weaken_metaclass { weaken($METAS{$_[0]}) }
+ sub metaclass_is_weak { isweak($METAS{$_[0]}) }
+ sub does_metaclass_exist { exists $METAS{$_[0]} && defined $METAS{$_[0]} }
+ sub remove_metaclass_by_name { delete $METAS{$_[0]}; return }
+
+ # This handles instances as well as class names
+ sub class_of {
+ return unless defined $_[0];
+ my $class = blessed($_[0]) || $_[0];
+ return $METAS{$class};
+ }
+
+ # NOTE:
+ # We only cache metaclasses, meaning instances of
+ # Class::MOP::Class. We do not cache instance of
+ # Class::MOP::Package or Class::MOP::Module. Mostly
+ # because I don't yet see a good reason to do so.
+}
+
+sub _class_to_pmfile {
+ my $class = shift;
+
+ my $file = $class . '.pm';
+ $file =~ s{::}{/}g;
+
+ return $file;
+}
+
+sub load_first_existing_class {
+ my $classes = Data::OptList::mkopt(\@_)
+ or return;
+
+ foreach my $class (@{ $classes }) {
+ my $name = $class->[0];
+ unless ( _is_valid_class_name($name) ) {
+ my $display = defined($name) ? $name : 'undef';
+ confess "Invalid class name ($display)";
+ }
+ }
+
+ my $found;
+ my %exceptions;
+
+ for my $class (@{ $classes }) {
+ my ($name, $options) = @{ $class };
+
+ if ($options) {
+ return $name if is_class_loaded($name, $options);
+ if (is_class_loaded($name)) {
+ # we already know it's loaded and too old, but we call
+ # ->VERSION anyway to generate the exception for us
+ $name->VERSION($options->{-version});
+ }
+ }
+ else {
+ return $name if is_class_loaded($name);
+ }
+
+ my $file = _class_to_pmfile($name);
+ return $name if try {
+ local $SIG{__DIE__};
+ require $file;
+ $name->VERSION($options->{-version})
+ if defined $options->{-version};
+ return 1;
+ }
+ catch {
+ unless (/^Can't locate \Q$file\E in \@INC/) {
+ confess "Couldn't load class ($name) because: $_";
+ }
+
+ return;
+ };
+ }
+
+ if ( @{ $classes } > 1 ) {
+ my @list = map { $_->[0] } @{ $classes };
+ confess "Can't locate any of @list in \@INC (\@INC contains: @INC).";
+ } else {
+ confess "Can't locate " . _class_to_pmfile($classes->[0]->[0]) . " in \@INC (\@INC contains: @INC).";
+ }
+}
+
+sub load_class {
+ load_first_existing_class($_[0], ref $_[1] ? $_[1] : ());
+
+ # This is done to avoid breaking code which checked the return value. Said
+ # code is dumb. The return value was _always_ true, since it dies on
+ # failure!
+ return 1;
+}
+
+sub _is_valid_class_name {
+ my $class = shift;
+
+ return 0 if ref($class);
+ return 0 unless defined($class);
+ return 0 unless length($class);
+
+ return 1 if $class =~ /^\w+(?:::\w+)*$/;
+
+ return 0;
+}
+
+## ----------------------------------------------------------------------------
+## Setting up our environment ...
+## ----------------------------------------------------------------------------
+## Class::MOP needs to have a few things in the global perl environment so
+## that it can operate effectively. Those things are done here.
+## ----------------------------------------------------------------------------
+
+# ... nothing yet actually ;)
+
+## ----------------------------------------------------------------------------
+## Bootstrapping
+## ----------------------------------------------------------------------------
+## The code below here is to bootstrap our MOP with itself. This is also
+## sometimes called "tying the knot". By doing this, we make it much easier
+## to extend the MOP through subclassing and such since now you can use the
+## MOP itself to extend itself.
+##
+## Yes, I know, thats weird and insane, but it's a good thing, trust me :)
+## ----------------------------------------------------------------------------
+
+# We need to add in the meta-attributes here so that
+# any subclass of Class::MOP::* will be able to
+# inherit them using _construct_instance
+
+## --------------------------------------------------------
+## Class::MOP::Mixin::HasMethods
+
+Class::MOP::Mixin::HasMethods->meta->add_attribute(
+ Class::MOP::Attribute->new('_methods' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ '_method_map' => \&Class::MOP::Mixin::HasMethods::_method_map
+ },
+ default => sub { {} }
+ ))
+);
+
+Class::MOP::Mixin::HasMethods->meta->add_attribute(
+ Class::MOP::Attribute->new('method_metaclass' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass
+ },
+ default => 'Class::MOP::Method',
+ ))
+);
+
+Class::MOP::Mixin::HasMethods->meta->add_attribute(
+ Class::MOP::Attribute->new('wrapped_method_metaclass' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass
+ },
+ default => 'Class::MOP::Method::Wrapped',
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Mixin::HasMethods
+
+Class::MOP::Mixin::HasAttributes->meta->add_attribute(
+ Class::MOP::Attribute->new('attributes' => (
+ reader => {
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
+ # we just alias the original method
+ # rather than re-produce it here
+ '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map
+ },
+ default => sub { {} }
+ ))
+);
+
+Class::MOP::Mixin::HasAttributes->meta->add_attribute(
+ Class::MOP::Attribute->new('attribute_metaclass' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass
+ },
+ default => 'Class::MOP::Attribute',
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Package
+
+Class::MOP::Package->meta->add_attribute(
+ Class::MOP::Attribute->new('package' => (
+ reader => {
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
+ # we just alias the original method
+ # rather than re-produce it here
+ 'name' => \&Class::MOP::Package::name
+ },
+ ))
+);
+
+Class::MOP::Package->meta->add_attribute(
+ Class::MOP::Attribute->new('namespace' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'namespace' => \&Class::MOP::Package::namespace
+ },
+ init_arg => undef,
+ default => sub { \undef }
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Module
+
+# NOTE:
+# yeah this is kind of stretching things a bit,
+# but truthfully the version should be an attribute
+# of the Module, the weirdness comes from having to
+# stick to Perl 5 convention and store it in the
+# $VERSION package variable. Basically if you just
+# squint at it, it will look how you want it to look.
+# Either as a package variable, or as a attribute of
+# the metaclass, isn't abstraction great :)
+
+Class::MOP::Module->meta->add_attribute(
+ Class::MOP::Attribute->new('version' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'version' => \&Class::MOP::Module::version
+ },
+ init_arg => undef,
+ default => sub { \undef }
+ ))
+);
+
+# NOTE:
+# By following the same conventions as version here,
+# we are opening up the possibility that people can
+# use the $AUTHORITY in non-Class::MOP modules as
+# well.
+
+Class::MOP::Module->meta->add_attribute(
+ Class::MOP::Attribute->new('authority' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'authority' => \&Class::MOP::Module::authority
+ },
+ init_arg => undef,
+ default => sub { \undef }
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Class
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('superclasses' => (
+ accessor => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'superclasses' => \&Class::MOP::Class::superclasses
+ },
+ init_arg => undef,
+ default => sub { \undef }
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('instance_metaclass' => (
+ reader => {
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
+ # we just alias the original method
+ # rather than re-produce it here
+ 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass
+ },
+ default => 'Class::MOP::Instance',
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('immutable_trait' => (
+ reader => {
+ 'immutable_trait' => \&Class::MOP::Class::immutable_trait
+ },
+ default => "Class::MOP::Class::Immutable::Trait",
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('constructor_name' => (
+ reader => {
+ 'constructor_name' => \&Class::MOP::Class::constructor_name,
+ },
+ default => "new",
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('constructor_class' => (
+ reader => {
+ 'constructor_class' => \&Class::MOP::Class::constructor_class,
+ },
+ default => "Class::MOP::Method::Constructor",
+ ))
+);
+
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('destructor_class' => (
+ reader => {
+ 'destructor_class' => \&Class::MOP::Class::destructor_class,
+ },
+ ))
+);
+
+# NOTE:
+# we don't actually need to tie the knot with
+# Class::MOP::Class here, it is actually handled
+# within Class::MOP::Class itself in the
+# _construct_class_instance method.
+
+## --------------------------------------------------------
+## Class::MOP::Mixin::AttributeCore
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('name' => (
+ reader => {
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
+ # we just alias the original method
+ # rather than re-produce it here
+ 'name' => \&Class::MOP::Mixin::AttributeCore::name
+ }
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('accessor' => (
+ reader => { 'accessor' => \&Class::MOP::Mixin::AttributeCore::accessor },
+ predicate => { 'has_accessor' => \&Class::MOP::Mixin::AttributeCore::has_accessor },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('reader' => (
+ reader => { 'reader' => \&Class::MOP::Mixin::AttributeCore::reader },
+ predicate => { 'has_reader' => \&Class::MOP::Mixin::AttributeCore::has_reader },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('initializer' => (
+ reader => { 'initializer' => \&Class::MOP::Mixin::AttributeCore::initializer },
+ predicate => { 'has_initializer' => \&Class::MOP::Mixin::AttributeCore::has_initializer },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('definition_context' => (
+ reader => { 'definition_context' => \&Class::MOP::Mixin::AttributeCore::definition_context },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('writer' => (
+ reader => { 'writer' => \&Class::MOP::Mixin::AttributeCore::writer },
+ predicate => { 'has_writer' => \&Class::MOP::Mixin::AttributeCore::has_writer },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('predicate' => (
+ reader => { 'predicate' => \&Class::MOP::Mixin::AttributeCore::predicate },
+ predicate => { 'has_predicate' => \&Class::MOP::Mixin::AttributeCore::has_predicate },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('clearer' => (
+ reader => { 'clearer' => \&Class::MOP::Mixin::AttributeCore::clearer },
+ predicate => { 'has_clearer' => \&Class::MOP::Mixin::AttributeCore::has_clearer },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('builder' => (
+ reader => { 'builder' => \&Class::MOP::Mixin::AttributeCore::builder },
+ predicate => { 'has_builder' => \&Class::MOP::Mixin::AttributeCore::has_builder },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('init_arg' => (
+ reader => { 'init_arg' => \&Class::MOP::Mixin::AttributeCore::init_arg },
+ predicate => { 'has_init_arg' => \&Class::MOP::Mixin::AttributeCore::has_init_arg },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('default' => (
+ # default has a custom 'reader' method ...
+ predicate => { 'has_default' => \&Class::MOP::Mixin::AttributeCore::has_default },
+ ))
+);
+
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('insertion_order' => (
+ reader => { 'insertion_order' => \&Class::MOP::Mixin::AttributeCore::insertion_order },
+ writer => { '_set_insertion_order' => \&Class::MOP::Mixin::AttributeCore::_set_insertion_order },
+ predicate => { 'has_insertion_order' => \&Class::MOP::Mixin::AttributeCore::has_insertion_order },
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Attribute
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('associated_class' => (
+ reader => {
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
+ # we just alias the original method
+ # rather than re-produce it here
+ 'associated_class' => \&Class::MOP::Attribute::associated_class
+ }
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('associated_methods' => (
+ reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods },
+ default => sub { [] }
+ ))
+);
+
+Class::MOP::Attribute->meta->add_method('clone' => sub {
+ my $self = shift;
+ $self->meta->clone_object($self, @_);
+});
+
+## --------------------------------------------------------
+## Class::MOP::Method
+Class::MOP::Method->meta->add_attribute(
+ Class::MOP::Attribute->new('body' => (
+ reader => { 'body' => \&Class::MOP::Method::body },
+ ))
+);
+
+Class::MOP::Method->meta->add_attribute(
+ Class::MOP::Attribute->new('associated_metaclass' => (
+ reader => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass },
+ ))
+);
+
+Class::MOP::Method->meta->add_attribute(
+ Class::MOP::Attribute->new('package_name' => (
+ reader => { 'package_name' => \&Class::MOP::Method::package_name },
+ ))
+);
+
+Class::MOP::Method->meta->add_attribute(
+ Class::MOP::Attribute->new('name' => (
+ reader => { 'name' => \&Class::MOP::Method::name },
+ ))
+);
+
+Class::MOP::Method->meta->add_attribute(
+ Class::MOP::Attribute->new('original_method' => (
+ reader => { 'original_method' => \&Class::MOP::Method::original_method },
+ writer => { '_set_original_method' => \&Class::MOP::Method::_set_original_method },
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Method::Wrapped
+
+# NOTE:
+# the way this item is initialized, this
+# really does not follow the standard
+# practices of attributes, but we put
+# it here for completeness
+Class::MOP::Method::Wrapped->meta->add_attribute(
+ Class::MOP::Attribute->new('modifier_table')
+);
+
+## --------------------------------------------------------
+## Class::MOP::Method::Generated
+
+Class::MOP::Method::Generated->meta->add_attribute(
+ Class::MOP::Attribute->new('is_inline' => (
+ reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline },
+ default => 0,
+ ))
+);
+
+Class::MOP::Method::Generated->meta->add_attribute(
+ Class::MOP::Attribute->new('definition_context' => (
+ reader => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context },
+ ))
+);
+
+
+## --------------------------------------------------------
+## Class::MOP::Method::Inlined
+
+Class::MOP::Method::Inlined->meta->add_attribute(
+ Class::MOP::Attribute->new('_expected_method_class' => (
+ reader => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class },
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Method::Accessor
+
+Class::MOP::Method::Accessor->meta->add_attribute(
+ Class::MOP::Attribute->new('attribute' => (
+ reader => {
+ 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
+ },
+ ))
+);
+
+Class::MOP::Method::Accessor->meta->add_attribute(
+ Class::MOP::Attribute->new('accessor_type' => (
+ reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type },
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Method::Constructor
+
+Class::MOP::Method::Constructor->meta->add_attribute(
+ Class::MOP::Attribute->new('options' => (
+ reader => {
+ 'options' => \&Class::MOP::Method::Constructor::options
+ },
+ default => sub { +{} }
+ ))
+);
+
+Class::MOP::Method::Constructor->meta->add_attribute(
+ Class::MOP::Attribute->new('associated_metaclass' => (
+ init_arg => "metaclass", # FIXME alias and rename
+ reader => {
+ 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass
+ },
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Instance
+
+# NOTE:
+# these don't yet do much of anything, but are just
+# included for completeness
+
+Class::MOP::Instance->meta->add_attribute(
+ Class::MOP::Attribute->new('associated_metaclass',
+ reader => { associated_metaclass => \&Class::MOP::Instance::associated_metaclass },
+ ),
+);
+
+Class::MOP::Instance->meta->add_attribute(
+ Class::MOP::Attribute->new('_class_name',
+ init_arg => undef,
+ reader => { _class_name => \&Class::MOP::Instance::_class_name },
+ #lazy => 1, # not yet supported by Class::MOP but out our version does it anyway
+ #default => sub { $_[0]->associated_metaclass->name },
+ ),
+);
+
+Class::MOP::Instance->meta->add_attribute(
+ Class::MOP::Attribute->new('attributes',
+ reader => { attributes => \&Class::MOP::Instance::get_all_attributes },
+ ),
+);
+
+Class::MOP::Instance->meta->add_attribute(
+ Class::MOP::Attribute->new('slots',
+ reader => { slots => \&Class::MOP::Instance::slots },
+ ),
+);
+
+Class::MOP::Instance->meta->add_attribute(
+ Class::MOP::Attribute->new('slot_hash',
+ reader => { slot_hash => \&Class::MOP::Instance::slot_hash },
+ ),
+);
+
+## --------------------------------------------------------
+## Class::MOP::Object
+
+# need to replace the meta method there with a real meta method object
+Class::MOP::Object->meta->_add_meta_method('meta');
+
+## --------------------------------------------------------
+## Class::MOP::Mixin
+
+# need to replace the meta method there with a real meta method object
+Class::MOP::Mixin->meta->_add_meta_method('meta');
+
+require Class::MOP::Deprecated unless our $no_deprecated;
+
+# we need the meta instance of the meta instance to be created now, in order
+# for the constructor to be able to use it
+Class::MOP::Instance->meta->get_meta_instance;
+
+# pretend the add_method never happenned. it hasn't yet affected anything
+undef Class::MOP::Instance->meta->{_package_cache_flag};
+
+## --------------------------------------------------------
+## Now close all the Class::MOP::* classes
+
+# NOTE: we don't need to inline the the accessors this only lengthens
+# the compile time of the MOP, and gives us no actual benefits.
+
+$_->meta->make_immutable(
+ inline_constructor => 0,
+ constructor_name => "_new",
+ inline_accessors => 0,
+) for qw/
+ Class::MOP::Package
+ Class::MOP::Module
+ Class::MOP::Class
+
+ Class::MOP::Attribute
+ Class::MOP::Method
+ Class::MOP::Instance
+
+ Class::MOP::Object
+
+ Class::MOP::Method::Generated
+ Class::MOP::Method::Inlined
+
+ Class::MOP::Method::Accessor
+ Class::MOP::Method::Constructor
+ Class::MOP::Method::Wrapped
+
+ Class::MOP::Method::Meta
+/;
+
+$_->meta->make_immutable(
+ inline_constructor => 0,
+ constructor_name => undef,
+ inline_accessors => 0,
+) for qw/
+ Class::MOP::Mixin
+ Class::MOP::Mixin::AttributeCore
+ Class::MOP::Mixin::HasAttributes
+ Class::MOP::Mixin::HasMethods
+/;
+
+1;
+
+# ABSTRACT: A Meta Object Protocol for Perl 5
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This module is a fully functioning meta object protocol for the
+Perl 5 object system. It makes no attempt to change the behavior or
+characteristics of the Perl 5 object system, only to create a
+protocol for its manipulation and introspection.
+
+That said, it does attempt to create the tools for building a rich set
+of extensions to the Perl 5 object system. Every attempt has been made
+to abide by the spirit of the Perl 5 object system that we all know
+and love.
+
+This documentation is sparse on conceptual details. We suggest looking
+at the items listed in the L<SEE ALSO> section for more
+information. In particular the book "The Art of the Meta Object
+Protocol" was very influential in the development of this system.
+
+=head2 What is a Meta Object Protocol?
+
+A meta object protocol is an API to an object system.
+
+To be more specific, it abstracts the components of an object system
+(classes, object, methods, object attributes, etc.). These
+abstractions can then be used to inspect and manipulate the object
+system which they describe.
+
+It can be said that there are two MOPs for any object system; the
+implicit MOP and the explicit MOP. The implicit MOP handles things
+like method dispatch or inheritance, which happen automatically as
+part of how the object system works. The explicit MOP typically
+handles the introspection/reflection features of the object system.
+
+All object systems have implicit MOPs. Without one, they would not
+work. Explicit MOPs are much less common, and depending on the
+language can vary from restrictive (Reflection in Java or C#) to wide
+open (CLOS is a perfect example).
+
+=head2 Yet Another Class Builder! Why?
+
+This is B<not> a class builder so much as a I<class builder
+B<builder>>. The intent is that an end user will not use this module
+directly, but instead this module is used by module authors to build
+extensions and features onto the Perl 5 object system.
+
+This system is used by L<Moose>, which supplies a powerful class
+builder system built entirely on top of C<Class::MOP>.
+
+=head2 Who is this module for?
+
+This module is for anyone who has ever created or wanted to create a
+module for the Class:: namespace. The tools which this module provides
+make doing complex Perl 5 wizardry simpler, by removing such barriers
+as the need to hack symbol tables, or understand the fine details of
+method dispatch.
+
+=head2 What changes do I have to make to use this module?
+
+This module was designed to be as unintrusive as possible. Many of its
+features are accessible without B<any> change to your existing
+code. It is meant to be a compliment to your existing code and not an
+intrusion on your code base. Unlike many other B<Class::> modules,
+this module B<does not> require you subclass it, or even that you
+C<use> it in within your module's package.
+
+The only features which requires additions to your code are the
+attribute handling and instance construction features, and these are
+both completely optional features. The only reason for this is because
+Perl 5's object system does not actually have these features built
+in. More information about this feature can be found below.
+
+=head2 About Performance
+
+It is a common misconception that explicit MOPs are a performance hit.
+This is not a universal truth, it is a side-effect of some specific
+implementations. For instance, using Java reflection is slow because
+the JVM cannot take advantage of any compiler optimizations, and the
+JVM has to deal with much more runtime type information as well.
+
+Reflection in C# is marginally better as it was designed into the
+language and runtime (the CLR). In contrast, CLOS (the Common Lisp
+Object System) was built to support an explicit MOP, and so
+performance is tuned for it.
+
+This library in particular does its absolute best to avoid putting
+B<any> drain at all upon your code's performance. In fact, by itself
+it does nothing to affect your existing code. So you only pay for what
+you actually use.
+
+=head2 About Metaclass compatibility
+
+This module makes sure that all metaclasses created are both upwards
+and downwards compatible. The topic of metaclass compatibility is
+highly esoteric and is something only encountered when doing deep and
+involved metaclass hacking. There are two basic kinds of metaclass
+incompatibility; upwards and downwards.
+
+Upwards metaclass compatibility means that the metaclass of a
+given class is either the same as (or a subclass of) all of the
+class's ancestors.
+
+Downward metaclass compatibility means that the metaclasses of a
+given class's ancestors are all either the same as (or a subclass
+of) that metaclass.
+
+Here is a diagram showing a set of two classes (C<A> and C<B>) and
+two metaclasses (C<Meta::A> and C<Meta::B>) which have correct
+metaclass compatibility both upwards and downwards.
+
+ +---------+ +---------+
+ | Meta::A |<----| Meta::B | <....... (instance of )
+ +---------+ +---------+ <------- (inherits from)
+ ^ ^
+ : :
+ +---------+ +---------+
+ | A |<----| B |
+ +---------+ +---------+
+
+In actuality, I<all> of a class's metaclasses must be compatible,
+not just the class metaclass. That includes the instance, attribute,
+and method metaclasses, as well as the constructor and destructor
+classes.
+
+C<Class::MOP> will attempt to fix some simple types of
+incompatibilities. If all the metaclasses for the parent class are
+I<subclasses> of the child's metaclasses then we can simply replace
+the child's metaclasses with the parent's. In addition, if the child
+is missing a metaclass that the parent has, we can also just make the
+child use the parent's metaclass.
+
+As I said this is a highly esoteric topic and one you will only run
+into if you do a lot of subclassing of L<Class::MOP::Class>. If you
+are interested in why this is an issue see the paper I<Uniform and
+safe metaclass composition> linked to in the L<SEE ALSO> section of
+this document.
+
+=head2 Using custom metaclasses
+
+Always use the L<metaclass> pragma when using a custom metaclass, this
+will ensure the proper initialization order and not accidentally
+create an incorrect type of metaclass for you. This is a very rare
+problem, and one which can only occur if you are doing deep metaclass
+programming. So in other words, don't worry about it.
+
+Note that if you're using L<Moose> we encourage you to I<not> use
+L<metaclass> pragma, and instead use L<Moose::Util::MetaRole> to apply
+roles to a class's metaclasses. This topic is covered at length in
+various L<Moose::Cookbook> recipes.
+
+=head1 PROTOCOLS
+
+The meta-object protocol is divided into 4 main sub-protocols:
+
+=head2 The Class protocol
+
+This provides a means of manipulating and introspecting a Perl 5
+class. It handles symbol table hacking for you, and provides a rich
+set of methods that go beyond simple package introspection.
+
+See L<Class::MOP::Class> for more details.
+
+=head2 The Attribute protocol
+
+This provides a consistent representation for an attribute of a Perl 5
+class. Since there are so many ways to create and handle attributes in
+Perl 5 OO, the Attribute protocol provide as much of a unified
+approach as possible. Of course, you are always free to extend this
+protocol by subclassing the appropriate classes.
+
+See L<Class::MOP::Attribute> for more details.
+
+=head2 The Method protocol
+
+This provides a means of manipulating and introspecting methods in the
+Perl 5 object system. As with attributes, there are many ways to
+approach this topic, so we try to keep it pretty basic, while still
+making it possible to extend the system in many ways.
+
+See L<Class::MOP::Method> for more details.
+
+=head2 The Instance protocol
+
+This provides a layer of abstraction for creating object instances.
+Since the other layers use this protocol, it is relatively easy to
+change the type of your instances from the default hash reference to
+some other type of reference. Several examples are provided in the
+F<examples/> directory included in this distribution.
+
+See L<Class::MOP::Instance> for more details.
+
+=head1 FUNCTIONS
+
+Note that this module does not export any constants or functions.
+
+=head2 Constants
+
+=over 4
+
+=item I<Class::MOP::IS_RUNNING_ON_5_10>
+
+We set this constant depending on what version perl we are on, this
+allows us to take advantage of new 5.10 features and stay backwards
+compatible.
+
+=back
+
+=head2 Utility functions
+
+Note that these are all called as B<functions, not methods>.
+
+=over 4
+
+=item B<Class::MOP::load_class($class_name, \%options?)>
+
+This will load the specified C<$class_name>, if it is not already
+loaded (as reported by C<is_class_loaded>). This function can be used
+in place of tricks like C<eval "use $module"> or using C<require>
+unconditionally.
+
+If the module cannot be loaded, an exception is thrown.
+
+You can pass a hash reference with options as second argument. The
+only option currently recognised is C<-version>, which will ensure
+that the loaded class has at least the required version.
+
+See also L</Class Loading Options>.
+
+For historical reasons, this function explicitly returns a true value.
+
+=item B<Class::MOP::is_class_loaded($class_name, \%options?)>
+
+Returns a boolean indicating whether or not C<$class_name> has been
+loaded.
+
+This does a basic check of the symbol table to try and determine as
+best it can if the C<$class_name> is loaded, it is probably correct
+about 99% of the time, but it can be fooled into reporting false
+positives. In particular, loading any of the core L<IO> modules will
+cause most of the rest of the core L<IO> modules to falsely report
+having been loaded, due to the way the base L<IO> module works.
+
+You can pass a hash reference with options as second argument. The
+only option currently recognised is C<-version>, which will ensure
+that the loaded class has at least the required version.
+
+See also L</Class Loading Options>.
+
+=item B<Class::MOP::get_code_info($code)>
+
+This function returns two values, the name of the package the C<$code>
+is from and the name of the C<$code> itself. This is used by several
+elements of the MOP to determine where a given C<$code> reference is
+from.
+
+=item B<Class::MOP::class_of($instance_or_class_name)>
+
+This will return the metaclass of the given instance or class name. If the
+class lacks a metaclass, no metaclass will be initialized, and C<undef> will be
+returned.
+
+=item B<Class::MOP::check_package_cache_flag($pkg)>
+
+B<NOTE: DO NOT USE THIS FUNCTION, IT IS FOR INTERNAL USE ONLY!>
+
+This will return an integer that is managed by L<Class::MOP::Class> to
+determine if a module's symbol table has been altered.
+
+In Perl 5.10 or greater, this flag is package specific. However in
+versions prior to 5.10, this will use the C<PL_sub_generation>
+variable which is not package specific.
+
+=item B<Class::MOP::load_first_existing_class(@class_names)>
+
+=item B<Class::MOP::load_first_existing_class($classA, \%optionsA?, $classB, ...)>
+
+B<NOTE: DO NOT USE THIS FUNCTION, IT IS FOR INTERNAL USE ONLY!>
+
+Given a list of class names, this function will attempt to load each
+one in turn.
+
+If it finds a class it can load, it will return that class' name. If
+none of the classes can be loaded, it will throw an exception.
+
+Additionally, you can pass a hash reference with options after each
+class name. Currently, only C<-version> is recognised and will ensure
+that the loaded class has at least the required version. If the class
+version is not sufficient, an exception will be raised.
+
+See also L</Class Loading Options>.
+
+=back
+
+=head2 Metaclass cache functions
+
+Class::MOP holds a cache of metaclasses. The following are functions
+(B<not methods>) which can be used to access that cache. It is not
+recommended that you mess with these. Bad things could happen, but if
+you are brave and willing to risk it: go for it!
+
+=over 4
+
+=item B<Class::MOP::get_all_metaclasses>
+
+This will return a hash of all the metaclass instances that have
+been cached by L<Class::MOP::Class>, keyed by the package name.
+
+=item B<Class::MOP::get_all_metaclass_instances>
+
+This will return a list of all the metaclass instances that have
+been cached by L<Class::MOP::Class>.
+
+=item B<Class::MOP::get_all_metaclass_names>
+
+This will return a list of all the metaclass names that have
+been cached by L<Class::MOP::Class>.
+
+=item B<Class::MOP::get_metaclass_by_name($name)>
+
+This will return a cached L<Class::MOP::Class> instance, or nothing
+if no metaclass exists with that C<$name>.
+
+=item B<Class::MOP::store_metaclass_by_name($name, $meta)>
+
+This will store a metaclass in the cache at the supplied C<$key>.
+
+=item B<Class::MOP::weaken_metaclass($name)>
+
+In rare cases (e.g. anonymous metaclasses) it is desirable to
+store a weakened reference in the metaclass cache. This
+function will weaken the reference to the metaclass stored
+in C<$name>.
+
+=item B<Class::MOP::metaclass_is_weak($name)>
+
+Returns true if the metaclass for C<$name> has been weakened
+(via C<weaken_metaclass>).
+
+=item B<Class::MOP::does_metaclass_exist($name)>
+
+This will return true of there exists a metaclass stored in the
+C<$name> key, and return false otherwise.
+
+=item B<Class::MOP::remove_metaclass_by_name($name)>
+
+This will remove the metaclass stored in the C<$name> key.
+
+=back
+
+=head2 Class Loading Options
+
+=over 4
+
+=item -version
+
+Can be used to pass a minimum required version that will be checked
+against the class version after it was loaded.
+
+=back
+
+=head1 SEE ALSO
+
+=head2 Books
+
+There are very few books out on Meta Object Protocols and Metaclasses
+because it is such an esoteric topic. The following books are really
+the only ones I have found. If you know of any more, B<I<please>>
+email me and let me know, I would love to hear about them.
+
+=over 4
+
+=item I<The Art of the Meta Object Protocol>
+
+=item I<Advances in Object-Oriented Metalevel Architecture and Reflection>
+
+=item I<Putting MetaClasses to Work>
+
+=item I<Smalltalk: The Language>
+
+=back
+
+=head2 Papers
+
+=over 4
+
+=item "Uniform and safe metaclass composition"
+
+An excellent paper by the people who brought us the original Traits paper.
+This paper is on how Traits can be used to do safe metaclass composition,
+and offers an excellent introduction section which delves into the topic of
+metaclass compatibility.
+
+L<http://www.iam.unibe.ch/~scg/Archive/Papers/Duca05ySafeMetaclassTrait.pdf>
+
+=item "Safe Metaclass Programming"
+
+This paper seems to precede the above paper, and propose a mix-in based
+approach as opposed to the Traits based approach. Both papers have similar
+information on the metaclass compatibility problem space.
+
+L<http://citeseer.ist.psu.edu/37617.html>
+
+=back
+
+=head2 Prior Art
+
+=over 4
+
+=item The Perl 6 MetaModel work in the Pugs project
+
+=over 4
+
+=item L<http://svn.openfoundry.org/pugs/misc/Perl-MetaModel/>
+
+=item L<http://github.com/perl6/p5-modules/tree/master/Perl6-ObjectSpace/>
+
+=back
+
+=back
+
+=head2 Articles
+
+=over 4
+
+=item CPAN Module Review of Class::MOP
+
+L<http://www.oreillynet.com/onlamp/blog/2006/06/cpan_module_review_classmop.html>
+
+=back
+
+=head1 SIMILAR MODULES
+
+As I have said above, this module is a class-builder-builder, so it is
+not the same thing as modules like L<Class::Accessor> and
+L<Class::MethodMaker>. That being said there are very few modules on CPAN
+with similar goals to this module. The one I have found which is most
+like this module is L<Class::Meta>, although it's philosophy and the MOP it
+creates are very different from this modules.
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception.
+
+Please report any bugs to C<bug-class-mop@rt.cpan.org>, or through the
+web interface at L<http://rt.cpan.org>.
+
+You can also discuss feature requests or possible bugs on the Moose
+mailing list (moose@perl.org) or on IRC at
+L<irc://irc.perl.org/#moose>.
+
+=head1 ACKNOWLEDGEMENTS
+
+=over 4
+
+=item Rob Kinyon
+
+Thanks to Rob for actually getting the development of this module kick-started.
+
+=back
+
+=cut
--- /dev/null
+
+package Class::MOP::Attribute;
+
+use strict;
+use warnings;
+
+use Class::MOP::Method::Accessor;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore';
+
+# NOTE: (meta-circularity)
+# This method will be replaced in the
+# boostrap section of Class::MOP, by
+# a new version which uses the
+# &Class::MOP::Class::construct_instance
+# method to build an attribute meta-object
+# which itself is described with attribute
+# meta-objects.
+# - Ain't meta-circularity grand? :)
+sub new {
+ my ( $class, @args ) = @_;
+
+ unshift @args, "name" if @args % 2 == 1;
+ my %options = @args;
+
+ my $name = $options{name};
+
+ (defined $name)
+ || confess "You must provide a name for the attribute";
+
+ $options{init_arg} = $name
+ if not exists $options{init_arg};
+ if(exists $options{builder}){
+ confess("builder must be a defined scalar value which is a method name")
+ if ref $options{builder} || !(defined $options{builder});
+ confess("Setting both default and builder is not allowed.")
+ if exists $options{default};
+ } else {
+ ($class->is_default_a_coderef(\%options))
+ || confess("References are not allowed as default values, you must ".
+ "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
+ if exists $options{default} && ref $options{default};
+ }
+ if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) {
+ confess("A required attribute must have either 'init_arg', 'builder', or 'default'");
+ }
+
+ $class->_new(\%options);
+}
+
+sub _new {
+ my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $options = @_ == 1 ? $_[0] : {@_};
+
+ bless {
+ 'name' => $options->{name},
+ 'accessor' => $options->{accessor},
+ 'reader' => $options->{reader},
+ 'writer' => $options->{writer},
+ 'predicate' => $options->{predicate},
+ 'clearer' => $options->{clearer},
+ 'builder' => $options->{builder},
+ 'init_arg' => $options->{init_arg},
+ exists $options->{default}
+ ? ('default' => $options->{default})
+ : (),
+ 'initializer' => $options->{initializer},
+ 'definition_context' => $options->{definition_context},
+ # keep a weakened link to the
+ # class we are associated with
+ 'associated_class' => undef,
+ # and a list of the methods
+ # associated with this attr
+ 'associated_methods' => [],
+ # this let's us keep track of
+ # our order inside the associated
+ # class
+ 'insertion_order' => undef,
+ }, $class;
+}
+
+# NOTE:
+# this is a primative (and kludgy) clone operation
+# for now, it will be replaced in the Class::MOP
+# bootstrap with a proper one, however we know
+# that this one will work fine for now.
+sub clone {
+ my $self = shift;
+ my %options = @_;
+ (blessed($self))
+ || confess "Can only clone an instance";
+ return bless { %{$self}, %options } => ref($self);
+}
+
+sub initialize_instance_slot {
+ my ($self, $meta_instance, $instance, $params) = @_;
+ my $init_arg = $self->{'init_arg'};
+
+ # try to fetch the init arg from the %params ...
+
+ # if nothing was in the %params, we can use the
+ # attribute's default value (if it has one)
+ if(defined $init_arg and exists $params->{$init_arg}){
+ $self->_set_initial_slot_value(
+ $meta_instance,
+ $instance,
+ $params->{$init_arg},
+ );
+ }
+ elsif (exists $self->{'default'}) {
+ $self->_set_initial_slot_value(
+ $meta_instance,
+ $instance,
+ $self->default($instance),
+ );
+ }
+ elsif (defined( my $builder = $self->{'builder'})) {
+ if ($builder = $instance->can($builder)) {
+ $self->_set_initial_slot_value(
+ $meta_instance,
+ $instance,
+ $instance->$builder,
+ );
+ }
+ else {
+ confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'");
+ }
+ }
+}
+
+sub _set_initial_slot_value {
+ my ($self, $meta_instance, $instance, $value) = @_;
+
+ my $slot_name = $self->name;
+
+ return $meta_instance->set_slot_value($instance, $slot_name, $value)
+ unless $self->has_initializer;
+
+ my $callback = $self->_make_initializer_writer_callback(
+ $meta_instance, $instance, $slot_name
+ );
+
+ my $initializer = $self->initializer;
+
+ # most things will just want to set a value, so make it first arg
+ $instance->$initializer($value, $callback, $self);
+}
+
+sub _make_initializer_writer_callback {
+ my $self = shift;
+ my ($meta_instance, $instance, $slot_name) = @_;
+
+ return sub {
+ $meta_instance->set_slot_value($instance, $slot_name, $_[0]);
+ };
+}
+
+sub get_read_method {
+ my $self = shift;
+ my $reader = $self->reader || $self->accessor;
+ # normal case ...
+ return $reader unless ref $reader;
+ # the HASH ref case
+ my ($name) = %$reader;
+ return $name;
+}
+
+sub get_write_method {
+ my $self = shift;
+ my $writer = $self->writer || $self->accessor;
+ # normal case ...
+ return $writer unless ref $writer;
+ # the HASH ref case
+ my ($name) = %$writer;
+ return $name;
+}
+
+sub get_read_method_ref {
+ my $self = shift;
+ if ((my $reader = $self->get_read_method) && $self->associated_class) {
+ return $self->associated_class->get_method($reader);
+ }
+ else {
+ my $code = sub { $self->get_value(@_) };
+ if (my $class = $self->associated_class) {
+ return $class->method_metaclass->wrap(
+ $code,
+ package_name => $class->name,
+ name => '__ANON__'
+ );
+ }
+ else {
+ return $code;
+ }
+ }
+}
+
+sub get_write_method_ref {
+ my $self = shift;
+ if ((my $writer = $self->get_write_method) && $self->associated_class) {
+ return $self->associated_class->get_method($writer);
+ }
+ else {
+ my $code = sub { $self->set_value(@_) };
+ if (my $class = $self->associated_class) {
+ return $class->method_metaclass->wrap(
+ $code,
+ package_name => $class->name,
+ name => '__ANON__'
+ );
+ }
+ else {
+ return $code;
+ }
+ }
+}
+
+# slots
+
+sub slots { (shift)->name }
+
+# class association
+
+sub attach_to_class {
+ my ($self, $class) = @_;
+ (blessed($class) && $class->isa('Class::MOP::Class'))
+ || confess "You must pass a Class::MOP::Class instance (or a subclass)";
+ weaken($self->{'associated_class'} = $class);
+}
+
+sub detach_from_class {
+ my $self = shift;
+ $self->{'associated_class'} = undef;
+}
+
+# method association
+
+sub associate_method {
+ my ($self, $method) = @_;
+ push @{$self->{'associated_methods'}} => $method;
+}
+
+## Slot management
+
+sub set_initial_value {
+ my ($self, $instance, $value) = @_;
+ $self->_set_initial_slot_value(
+ Class::MOP::Class->initialize(ref($instance))->get_meta_instance,
+ $instance,
+ $value
+ );
+}
+
+sub set_value { shift->set_raw_value(@_) }
+
+sub set_raw_value {
+ my $self = shift;
+ my ($instance, $value) = @_;
+
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->set_slot_value($instance, $self->name, $value);
+}
+
+sub _inline_set_value {
+ my $self = shift;
+ return $self->_inline_instance_set(@_) . ';';
+}
+
+sub _inline_instance_set {
+ my $self = shift;
+ my ($instance, $value) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_set_slot_value($instance, $self->name, $value);
+}
+
+sub get_value { shift->get_raw_value(@_) }
+
+sub get_raw_value {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->get_slot_value($instance, $self->name);
+}
+
+sub _inline_get_value {
+ my $self = shift;
+ return $self->_inline_instance_get(@_) . ';';
+}
+
+sub _inline_instance_get {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_get_slot_value($instance, $self->name);
+}
+
+sub has_value {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->is_slot_initialized($instance, $self->name);
+}
+
+sub _inline_has_value {
+ my $self = shift;
+ return $self->_inline_instance_has(@_) . ';';
+}
+
+sub _inline_instance_has {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_is_slot_initialized($instance, $self->name);
+}
+
+sub clear_value {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->deinitialize_slot($instance, $self->name);
+}
+
+sub _inline_clear_value {
+ my $self = shift;
+ return $self->_inline_instance_clear(@_) . ';';
+}
+
+sub _inline_instance_clear {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_deinitialize_slot($instance, $self->name);
+}
+
+## load em up ...
+
+sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
+
+sub _process_accessors {
+ my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
+
+ my $method_ctx;
+
+ if ( my $ctx = $self->definition_context ) {
+ $method_ctx = { %$ctx };
+ }
+
+ if (ref($accessor)) {
+ (ref($accessor) eq 'HASH')
+ || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
+ my ($name, $method) = %{$accessor};
+ $method = $self->accessor_metaclass->wrap(
+ $method,
+ package_name => $self->associated_class->name,
+ name => $name,
+ definition_context => $method_ctx,
+ );
+ $self->associate_method($method);
+ return ($name, $method);
+ }
+ else {
+ my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
+ my $method;
+ try {
+ if ( $method_ctx ) {
+ my $desc = "accessor $accessor";
+ if ( $accessor ne $self->name ) {
+ $desc .= " of attribute " . $self->name;
+ }
+
+ $method_ctx->{description} = $desc;
+ }
+
+ $method = $self->accessor_metaclass->new(
+ attribute => $self,
+ is_inline => $inline_me,
+ accessor_type => $type,
+ package_name => $self->associated_class->name,
+ name => $accessor,
+ definition_context => $method_ctx,
+ );
+ }
+ catch {
+ confess "Could not create the '$type' method for " . $self->name . " because : $_";
+ };
+ $self->associate_method($method);
+ return ($accessor, $method);
+ }
+}
+
+sub install_accessors {
+ my $self = shift;
+ my $inline = shift;
+ my $class = $self->associated_class;
+
+ $class->add_method(
+ $self->_process_accessors('accessor' => $self->accessor(), $inline)
+ ) if $self->has_accessor();
+
+ $class->add_method(
+ $self->_process_accessors('reader' => $self->reader(), $inline)
+ ) if $self->has_reader();
+
+ $class->add_method(
+ $self->_process_accessors('writer' => $self->writer(), $inline)
+ ) if $self->has_writer();
+
+ $class->add_method(
+ $self->_process_accessors('predicate' => $self->predicate(), $inline)
+ ) if $self->has_predicate();
+
+ $class->add_method(
+ $self->_process_accessors('clearer' => $self->clearer(), $inline)
+ ) if $self->has_clearer();
+
+ return;
+}
+
+{
+ my $_remove_accessor = sub {
+ my ($accessor, $class) = @_;
+ if (ref($accessor) && ref($accessor) eq 'HASH') {
+ ($accessor) = keys %{$accessor};
+ }
+ my $method = $class->get_method($accessor);
+ $class->remove_method($accessor)
+ if (ref($method) && $method->isa('Class::MOP::Method::Accessor'));
+ };
+
+ sub remove_accessors {
+ my $self = shift;
+ # TODO:
+ # we really need to make sure to remove from the
+ # associates methods here as well. But this is
+ # such a slimly used method, I am not worried
+ # about it right now.
+ $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor();
+ $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader();
+ $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer();
+ $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
+ $_remove_accessor->($self->clearer(), $self->associated_class()) if $self->has_clearer();
+ return;
+ }
+
+}
+
+1;
+
+# ABSTRACT: Attribute Meta Object
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+ Class::MOP::Attribute->new(
+ foo => (
+ accessor => 'foo', # dual purpose get/set accessor
+ predicate => 'has_foo', # predicate check for defined-ness
+ init_arg => '-foo', # class->new will look for a -foo key
+ default => 'BAR IS BAZ!' # if no -foo key is provided, use this
+ )
+ );
+
+ Class::MOP::Attribute->new(
+ bar => (
+ reader => 'bar', # getter
+ writer => 'set_bar', # setter
+ predicate => 'has_bar', # predicate check for defined-ness
+ init_arg => ':bar', # class->new will look for a :bar key
+ # no default value means it is undef
+ )
+ );
+
+=head1 DESCRIPTION
+
+The Attribute Protocol is almost entirely an invention of
+C<Class::MOP>. Perl 5 does not have a consistent notion of
+attributes. There are so many ways in which this is done, and very few
+(if any) are easily discoverable by this module.
+
+With that said, this module attempts to inject some order into this
+chaos, by introducing a consistent API which can be used to create
+object attributes.
+
+=head1 METHODS
+
+=head2 Creation
+
+=over 4
+
+=item B<< Class::MOP::Attribute->new($name, ?%options) >>
+
+An attribute must (at the very least), have a C<$name>. All other
+C<%options> are added as key-value pairs.
+
+=over 8
+
+=item * init_arg
+
+This is a string value representing the expected key in an
+initialization hash. For instance, if we have an C<init_arg> value of
+C<-foo>, then the following code will Just Work.
+
+ MyClass->meta->new_object( -foo => 'Hello There' );
+
+If an init_arg is not assigned, it will automatically use the
+attribute's name. If C<init_arg> is explicitly set to C<undef>, the
+attribute cannot be specified during initialization.
+
+=item * builder
+
+This provides the name of a method that will be called to initialize
+the attribute. This method will be called on the object after it is
+constructed. It is expected to return a valid value for the attribute.
+
+=item * default
+
+This can be used to provide an explicit default for initializing the
+attribute. If the default you provide is a subroutine reference, then
+this reference will be called I<as a method> on the object.
+
+If the value is a simple scalar (string or number), then it can be
+just passed as is. However, if you wish to initialize it with a HASH
+or ARRAY ref, then you need to wrap that inside a subroutine
+reference:
+
+ Class::MOP::Attribute->new(
+ 'foo' => (
+ default => sub { [] },
+ )
+ );
+
+ # or ...
+
+ Class::MOP::Attribute->new(
+ 'foo' => (
+ default => sub { {} },
+ )
+ );
+
+If you wish to initialize an attribute with a subroutine reference
+itself, then you need to wrap that in a subroutine as well:
+
+ Class::MOP::Attribute->new(
+ 'foo' => (
+ default => sub {
+ sub { print "Hello World" }
+ },
+ )
+ );
+
+And lastly, if the value of your attribute is dependent upon some
+other aspect of the instance structure, then you can take advantage of
+the fact that when the C<default> value is called as a method:
+
+ Class::MOP::Attribute->new(
+ 'object_identity' => (
+ default => sub { Scalar::Util::refaddr( $_[0] ) },
+ )
+ );
+
+Note that there is no guarantee that attributes are initialized in any
+particular order, so you cannot rely on the value of some other
+attribute when generating the default.
+
+=item * initializer
+
+This option can be either a method name or a subroutine
+reference. This method will be called when setting the attribute's
+value in the constructor. Unlike C<default> and C<builder>, the
+initializer is only called when a value is provided to the
+constructor. The initializer allows you to munge this value during
+object construction.
+
+The initializer is called as a method with three arguments. The first
+is the value that was passed to the constructor. The second is a
+subroutine reference that can be called to actually set the
+attribute's value, and the last is the associated
+C<Class::MOP::Attribute> object.
+
+This contrived example shows an initializer that sets the attribute to
+twice the given value.
+
+ Class::MOP::Attribute->new(
+ 'doubled' => (
+ initializer => sub {
+ my ( $self, $value, $set, $attr ) = @_;
+ $set->( $value * 2 );
+ },
+ )
+ );
+
+Since an initializer can be a method name, you can easily make
+attribute initialization use the writer:
+
+ Class::MOP::Attribute->new(
+ 'some_attr' => (
+ writer => 'some_attr',
+ initializer => 'some_attr',
+ )
+ );
+
+Your writer will need to examine C<@_> and determine under which
+context it is being called.
+
+=back
+
+The C<accessor>, C<reader>, C<writer>, C<predicate> and C<clearer>
+options all accept the same parameters. You can provide the name of
+the method, in which case an appropriate default method will be
+generated for you. Or instead you can also provide hash reference
+containing exactly one key (the method name) and one value. The value
+should be a subroutine reference, which will be installed as the
+method itself.
+
+=over 8
+
+=item * accessor
+
+An C<accessor> is a standard Perl-style read/write accessor. It will
+return the value of the attribute, and if a value is passed as an
+argument, it will assign that value to the attribute.
+
+Note that C<undef> is a legitimate value, so this will work:
+
+ $object->set_something(undef);
+
+=item * reader
+
+This is a basic read-only accessor. It returns the value of the
+attribute.
+
+=item * writer
+
+This is a basic write accessor, it accepts a single argument, and
+assigns that value to the attribute.
+
+Note that C<undef> is a legitimate value, so this will work:
+
+ $object->set_something(undef);
+
+=item * predicate
+
+The predicate method returns a boolean indicating whether or not the
+attribute has been explicitly set.
+
+Note that the predicate returns true even if the attribute was set to
+a false value (C<0> or C<undef>).
+
+=item * clearer
+
+This method will uninitialize the attribute. After an attribute is
+cleared, its C<predicate> will return false.
+
+=item * definition_context
+
+Mostly, this exists as a hook for the benefit of Moose.
+
+This option should be a hash reference containing several keys which
+will be used when inlining the attribute's accessors. The keys should
+include C<line>, the line number where the attribute was created, and
+either C<file> or C<description>.
+
+This information will ultimately be used when eval'ing inlined
+accessor code so that error messages report a useful line and file
+name.
+
+=back
+
+=item B<< $attr->clone(%options) >>
+
+This clones the attribute. Any options you provide will override the
+settings of the original attribute. You can change the name of the new
+attribute by passing a C<name> key in C<%options>.
+
+=back
+
+=head2 Informational
+
+These are all basic read-only accessors for the values passed into
+the constructor.
+
+=over 4
+
+=item B<< $attr->name >>
+
+Returns the attribute's name.
+
+=item B<< $attr->accessor >>
+
+=item B<< $attr->reader >>
+
+=item B<< $attr->writer >>
+
+=item B<< $attr->predicate >>
+
+=item B<< $attr->clearer >>
+
+The C<accessor>, C<reader>, C<writer>, C<predicate>, and C<clearer>
+methods all return exactly what was passed to the constructor, so it
+can be either a string containing a method name, or a hash reference.
+
+=item B<< $attr->initializer >>
+
+Returns the initializer as passed to the constructor, so this may be
+either a method name or a subroutine reference.
+
+=item B<< $attr->init_arg >>
+
+=item B<< $attr->is_default_a_coderef >>
+
+=item B<< $attr->default($instance) >>
+
+The C<$instance> argument is optional. If you don't pass it, the
+return value for this method is exactly what was passed to the
+constructor, either a simple scalar or a subroutine reference.
+
+If you I<do> pass an C<$instance> and the default is a subroutine
+reference, then the reference is called as a method on the
+C<$instance> and the generated value is returned.
+
+=item B<< $attr->slots >>
+
+Return a list of slots required by the attribute. This is usually just
+one, the name of the attribute.
+
+A slot is the name of the hash key used to store the attribute in an
+object instance.
+
+=item B<< $attr->get_read_method >>
+
+=item B<< $attr->get_write_method >>
+
+Returns the name of a method suitable for reading or writing the value
+of the attribute in the associated class.
+
+If an attribute is read- or write-only, then these methods can return
+C<undef> as appropriate.
+
+=item B<< $attr->has_read_method >>
+
+=item B<< $attr->has_write_method >>
+
+This returns a boolean indicating whether the attribute has a I<named>
+read or write method.
+
+=item B<< $attr->get_read_method_ref >>
+
+=item B<< $attr->get_write_method_ref >>
+
+Returns the subroutine reference of a method suitable for reading or
+writing the attribute's value in the associated class. These methods
+always return a subroutine reference, regardless of whether or not the
+attribute is read- or write-only.
+
+=item B<< $attr->insertion_order >>
+
+If this attribute has been inserted into a class, this returns a zero
+based index regarding the order of insertion.
+
+=back
+
+=head2 Informational predicates
+
+These are all basic predicate methods for the values passed into C<new>.
+
+=over 4
+
+=item B<< $attr->has_accessor >>
+
+=item B<< $attr->has_reader >>
+
+=item B<< $attr->has_writer >>
+
+=item B<< $attr->has_predicate >>
+
+=item B<< $attr->has_clearer >>
+
+=item B<< $attr->has_initializer >>
+
+=item B<< $attr->has_init_arg >>
+
+This will be I<false> if the C<init_arg> was set to C<undef>.
+
+=item B<< $attr->has_default >>
+
+This will be I<false> if the C<default> was set to C<undef>, since
+C<undef> is the default C<default> anyway.
+
+=item B<< $attr->has_builder >>
+
+=item B<< $attr->has_insertion_order >>
+
+This will be I<false> if this attribute has not be inserted into a class
+
+=back
+
+=head2 Value management
+
+These methods are basically "back doors" to the instance, and can be
+used to bypass the regular accessors, but still stay within the MOP.
+
+These methods are not for general use, and should only be used if you
+really know what you are doing.
+
+=over 4
+
+=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
+
+This method is used internally to initialize the attribute's slot in
+the object C<$instance>.
+
+The C<$params> is a hash reference of the values passed to the object
+constructor.
+
+It's unlikely that you'll need to call this method yourself.
+
+=item B<< $attr->set_value($instance, $value) >>
+
+Sets the value without going through the accessor. Note that this
+works even with read-only attributes.
+
+=item B<< $attr->set_raw_value($instance, $value) >>
+
+Sets the value with no side effects such as a trigger.
+
+This doesn't actually apply to Class::MOP attributes, only to subclasses.
+
+=item B<< $attr->set_initial_value($instance, $value) >>
+
+Sets the value without going through the accessor. This method is only
+called when the instance is first being initialized.
+
+=item B<< $attr->get_value($instance) >>
+
+Returns the value without going through the accessor. Note that this
+works even with write-only accessors.
+
+=item B<< $attr->get_raw_value($instance) >>
+
+Returns the value without any side effects such as lazy attributes.
+
+Doesn't actually apply to Class::MOP attributes, only to subclasses.
+
+=item B<< $attr->has_value($instance) >>
+
+Return a boolean indicating whether the attribute has been set in
+C<$instance>. This how the default C<predicate> method works.
+
+=item B<< $attr->clear_value($instance) >>
+
+This will clear the attribute's value in C<$instance>. This is what
+the default C<clearer> calls.
+
+Note that this works even if the attribute does not have any
+associated read, write or clear methods.
+
+=back
+
+=head2 Class association
+
+These methods allow you to manage the attributes association with
+the class that contains it. These methods should not be used
+lightly, nor are they very magical, they are mostly used internally
+and by metaclass instances.
+
+=over 4
+
+=item B<< $attr->associated_class >>
+
+This returns the C<Class::MOP::Class> with which this attribute is
+associated, if any.
+
+=item B<< $attr->attach_to_class($metaclass) >>
+
+This method stores a weakened reference to the C<$metaclass> object
+internally.
+
+This method does not remove the attribute from its old class,
+nor does it create any accessors in the new class.
+
+It is probably best to use the L<Class::MOP::Class> C<add_attribute>
+method instead.
+
+=item B<< $attr->detach_from_class >>
+
+This method removes the associate metaclass object from the attribute
+it has one.
+
+This method does not remove the attribute itself from the class, or
+remove its accessors.
+
+It is probably best to use the L<Class::MOP::Class>
+C<remove_attribute> method instead.
+
+=back
+
+=head2 Attribute Accessor generation
+
+=over 4
+
+=item B<< $attr->accessor_metaclass >>
+
+Accessor methods are generated using an accessor metaclass. By
+default, this is L<Class::MOP::Method::Accessor>. This method returns
+the name of the accessor metaclass that this attribute uses.
+
+=item B<< $attr->associate_method($method) >>
+
+This associates a L<Class::MOP::Method> object with the
+attribute. Typically, this is called internally when an attribute
+generates its accessors.
+
+=item B<< $attr->associated_methods >>
+
+This returns the list of methods which have been associated with the
+attribute.
+
+=item B<< $attr->install_accessors >>
+
+This method generates and installs code the attributes various
+accessors. It is typically called from the L<Class::MOP::Class>
+C<add_attribute> method.
+
+=item B<< $attr->remove_accessors >>
+
+This method removes all of the accessors associated with the
+attribute.
+
+This does not currently remove methods from the list returned by
+C<associated_methods>.
+
+=item B<< $attr->inline_get >>
+
+=item B<< $attr->inline_set >>
+
+=item B<< $attr->inline_has >>
+
+=item B<< $attr->inline_clear >>
+
+These methods return a code snippet suitable for inlining the relevant
+operation. They expect strings containing variable names to be used in the
+inlining, like C<'$self'> or C<'$_[1]'>.
+
+=back
+
+=head2 Introspection
+
+=over 4
+
+=item B<< Class::MOP::Attribute->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+It should also be noted that L<Class::MOP> will actually bootstrap
+this module by installing a number of attribute meta-objects into its
+metaclass.
+
+=back
+
+=cut
+
+
--- /dev/null
+
+package Class::MOP::Class;
+
+use strict;
+use warnings;
+
+use Class::MOP::Instance;
+use Class::MOP::Method::Wrapped;
+use Class::MOP::Method::Accessor;
+use Class::MOP::Method::Constructor;
+use Class::MOP::MiniTrait;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'reftype', 'weaken';
+use Sub::Name 'subname';
+use Devel::GlobalDestruction 'in_global_destruction';
+use Try::Tiny;
+use List::MoreUtils 'all';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Module',
+ 'Class::MOP::Mixin::HasAttributes',
+ 'Class::MOP::Mixin::HasMethods';
+
+# Creation
+
+sub initialize {
+ my $class = shift;
+
+ my $package_name;
+
+ if ( @_ % 2 ) {
+ $package_name = shift;
+ } else {
+ my %options = @_;
+ $package_name = $options{package};
+ }
+
+ ($package_name && !ref($package_name))
+ || confess "You must pass a package name and it cannot be blessed";
+
+ return Class::MOP::get_metaclass_by_name($package_name)
+ || $class->_construct_class_instance(package => $package_name, @_);
+}
+
+sub reinitialize {
+ my ( $class, @args ) = @_;
+ unshift @args, "package" if @args % 2;
+ my %options = @args;
+ my $old_metaclass = blessed($options{package})
+ ? $options{package}
+ : Class::MOP::get_metaclass_by_name($options{package});
+ $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name)
+ if !exists $options{weaken}
+ && blessed($old_metaclass)
+ && $old_metaclass->isa('Class::MOP::Class');
+ $old_metaclass->_remove_generated_metaobjects
+ if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
+ my $new_metaclass = $class->SUPER::reinitialize(%options);
+ $new_metaclass->_restore_metaobjects_from($old_metaclass)
+ if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
+ return $new_metaclass;
+}
+
+# NOTE: (meta-circularity)
+# this is a special form of _construct_instance
+# (see below), which is used to construct class
+# meta-object instances for any Class::MOP::*
+# class. All other classes will use the more
+# normal &construct_instance.
+sub _construct_class_instance {
+ my $class = shift;
+ my $options = @_ == 1 ? $_[0] : {@_};
+ my $package_name = $options->{package};
+ (defined $package_name && $package_name)
+ || confess "You must pass a package name";
+ # NOTE:
+ # return the metaclass if we have it cached,
+ # and it is still defined (it has not been
+ # reaped by DESTROY yet, which can happen
+ # annoyingly enough during global destruction)
+
+ if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
+ return $meta;
+ }
+
+ $class
+ = ref $class
+ ? $class->_real_ref_name
+ : $class;
+
+ # now create the metaclass
+ my $meta;
+ if ($class eq 'Class::MOP::Class') {
+ $meta = $class->_new($options);
+ }
+ else {
+ # NOTE:
+ # it is safe to use meta here because
+ # class will always be a subclass of
+ # Class::MOP::Class, which defines meta
+ $meta = $class->meta->_construct_instance($options)
+ }
+
+ # and check the metaclass compatibility
+ $meta->_check_metaclass_compatibility();
+
+ Class::MOP::store_metaclass_by_name($package_name, $meta);
+
+ # NOTE:
+ # we need to weaken any anon classes
+ # so that they can call DESTROY properly
+ Class::MOP::weaken_metaclass($package_name) if $options->{weaken};
+
+ $meta;
+}
+
+sub _real_ref_name {
+ my $self = shift;
+
+ # NOTE: we need to deal with the possibility of class immutability here,
+ # and then get the name of the class appropriately
+ return $self->is_immutable
+ ? $self->_get_mutable_metaclass_name()
+ : ref $self;
+}
+
+sub _new {
+ my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $options = @_ == 1 ? $_[0] : {@_};
+
+ return bless {
+ # inherited from Class::MOP::Package
+ 'package' => $options->{package},
+
+ # NOTE:
+ # since the following attributes will
+ # actually be loaded from the symbol
+ # table, and actually bypass the instance
+ # entirely, we can just leave these things
+ # listed here for reference, because they
+ # should not actually have a value associated
+ # with the slot.
+ 'namespace' => \undef,
+ 'methods' => {},
+
+ # inherited from Class::MOP::Module
+ 'version' => \undef,
+ 'authority' => \undef,
+
+ # defined in Class::MOP::Class
+ 'superclasses' => \undef,
+
+ 'attributes' => {},
+ 'attribute_metaclass' =>
+ ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
+ 'method_metaclass' =>
+ ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
+ 'wrapped_method_metaclass' => (
+ $options->{'wrapped_method_metaclass'}
+ || 'Class::MOP::Method::Wrapped'
+ ),
+ 'instance_metaclass' =>
+ ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
+ 'immutable_trait' => (
+ $options->{'immutable_trait'}
+ || 'Class::MOP::Class::Immutable::Trait'
+ ),
+ 'constructor_name' => ( $options->{constructor_name} || 'new' ),
+ 'constructor_class' => (
+ $options->{constructor_class} || 'Class::MOP::Method::Constructor'
+ ),
+ 'destructor_class' => $options->{destructor_class},
+ }, $class;
+}
+
+## Metaclass compatibility
+{
+ my %base_metaclass = (
+ attribute_metaclass => 'Class::MOP::Attribute',
+ method_metaclass => 'Class::MOP::Method',
+ wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
+ instance_metaclass => 'Class::MOP::Instance',
+ constructor_class => 'Class::MOP::Method::Constructor',
+ destructor_class => 'Class::MOP::Method::Destructor',
+ );
+
+ sub _base_metaclasses { %base_metaclass }
+}
+
+sub _check_metaclass_compatibility {
+ my $self = shift;
+
+ my @superclasses = $self->superclasses
+ or return;
+
+ $self->_fix_metaclass_incompatibility(@superclasses);
+
+ my %base_metaclass = $self->_base_metaclasses;
+
+ # this is always okay ...
+ return
+ if ref($self) eq 'Class::MOP::Class'
+ && all {
+ my $meta = $self->$_;
+ !defined($meta) || $meta eq $base_metaclass{$_};
+ }
+ keys %base_metaclass;
+
+ for my $superclass (@superclasses) {
+ $self->_check_class_metaclass_compatibility($superclass);
+ }
+
+ for my $metaclass_type ( keys %base_metaclass ) {
+ next unless defined $self->$metaclass_type;
+ for my $superclass (@superclasses) {
+ $self->_check_single_metaclass_compatibility( $metaclass_type,
+ $superclass );
+ }
+ }
+}
+
+sub _check_class_metaclass_compatibility {
+ my $self = shift;
+ my ( $superclass_name ) = @_;
+
+ if (!$self->_class_metaclass_is_compatible($superclass_name)) {
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
+
+ my $super_meta_type = $super_meta->_real_ref_name;
+
+ confess "The metaclass of " . $self->name . " ("
+ . (ref($self)) . ")" . " is not compatible with "
+ . "the metaclass of its superclass, "
+ . $superclass_name . " (" . ($super_meta_type) . ")";
+ }
+}
+
+sub _class_metaclass_is_compatible {
+ my $self = shift;
+ my ( $superclass_name ) = @_;
+
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+ || return 1;
+
+ my $super_meta_name = $super_meta->_real_ref_name;
+
+ return $self->_is_compatible_with($super_meta_name);
+}
+
+sub _check_single_metaclass_compatibility {
+ my $self = shift;
+ my ( $metaclass_type, $superclass_name ) = @_;
+
+ if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
+ my $metaclass_type_name = $metaclass_type;
+ $metaclass_type_name =~ s/_(?:meta)?class$//;
+ $metaclass_type_name =~ s/_/ /g;
+ confess "The $metaclass_type_name metaclass for "
+ . $self->name . " (" . ($self->$metaclass_type)
+ . ")" . " is not compatible with the "
+ . "$metaclass_type_name metaclass of its "
+ . "superclass, $superclass_name ("
+ . ($super_meta->$metaclass_type) . ")";
+ }
+}
+
+sub _single_metaclass_is_compatible {
+ my $self = shift;
+ my ( $metaclass_type, $superclass_name ) = @_;
+
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+ || return 1;
+
+ # for instance, Moose::Meta::Class has a error_class attribute, but
+ # Class::MOP::Class doesn't - this shouldn't be an error
+ return 1 unless $super_meta->can($metaclass_type);
+ # for instance, Moose::Meta::Class has a destructor_class, but
+ # Class::MOP::Class doesn't - this shouldn't be an error
+ return 1 unless defined $super_meta->$metaclass_type;
+ # if metaclass is defined in superclass but not here, it's not compatible
+ # this is a really odd case
+ return 0 unless defined $self->$metaclass_type;
+
+ return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
+}
+
+sub _fix_metaclass_incompatibility {
+ my $self = shift;
+ my @supers = map { Class::MOP::Class->initialize($_) } @_;
+
+ my $necessary = 0;
+ for my $super (@supers) {
+ $necessary = 1
+ if $self->_can_fix_metaclass_incompatibility($super);
+ }
+ return unless $necessary;
+
+ for my $super (@supers) {
+ if (!$self->_class_metaclass_is_compatible($super->name)) {
+ $self->_fix_class_metaclass_incompatibility($super);
+ }
+ }
+
+ my %base_metaclass = $self->_base_metaclasses;
+ for my $metaclass_type (keys %base_metaclass) {
+ for my $super (@supers) {
+ if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
+ $self->_fix_single_metaclass_incompatibility(
+ $metaclass_type, $super
+ );
+ }
+ }
+ }
+}
+
+sub _can_fix_metaclass_incompatibility {
+ my $self = shift;
+ my ($super_meta) = @_;
+
+ return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
+
+ my %base_metaclass = $self->_base_metaclasses;
+ for my $metaclass_type (keys %base_metaclass) {
+ return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
+ }
+
+ return;
+}
+
+sub _class_metaclass_can_be_made_compatible {
+ my $self = shift;
+ my ($super_meta) = @_;
+
+ return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
+}
+
+sub _single_metaclass_can_be_made_compatible {
+ my $self = shift;
+ my ($super_meta, $metaclass_type) = @_;
+
+ my $specific_meta = $self->$metaclass_type;
+
+ return unless $super_meta->can($metaclass_type);
+ my $super_specific_meta = $super_meta->$metaclass_type;
+
+ # for instance, Moose::Meta::Class has a destructor_class, but
+ # Class::MOP::Class doesn't - this shouldn't be an error
+ return unless defined $super_specific_meta;
+
+ # if metaclass is defined in superclass but not here, it's fixable
+ # this is a really odd case
+ return 1 unless defined $specific_meta;
+
+ return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
+}
+
+sub _fix_class_metaclass_incompatibility {
+ my $self = shift;
+ my ( $super_meta ) = @_;
+
+ if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
+ ($self->is_pristine)
+ || confess "Can't fix metaclass incompatibility for "
+ . $self->name
+ . " because it is not pristine.";
+
+ my $super_meta_name = $super_meta->_real_ref_name;
+
+ $self->_make_compatible_with($super_meta_name);
+ }
+}
+
+sub _fix_single_metaclass_incompatibility {
+ my $self = shift;
+ my ( $metaclass_type, $super_meta ) = @_;
+
+ if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
+ ($self->is_pristine)
+ || confess "Can't fix metaclass incompatibility for "
+ . $self->name
+ . " because it is not pristine.";
+
+ my $new_metaclass = $self->$metaclass_type
+ ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
+ : $super_meta->$metaclass_type;
+ $self->{$metaclass_type} = $new_metaclass;
+ }
+}
+
+sub _restore_metaobjects_from {
+ my $self = shift;
+ my ($old_meta) = @_;
+
+ $self->_restore_metamethods_from($old_meta);
+ $self->_restore_metaattributes_from($old_meta);
+}
+
+sub _remove_generated_metaobjects {
+ my $self = shift;
+
+ for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
+ $attr->remove_accessors;
+ }
+}
+
+## ANON classes
+
+{
+ # NOTE:
+ # this should be sufficient, if you have a
+ # use case where it is not, write a test and
+ # I will change it.
+ my $ANON_CLASS_SERIAL = 0;
+
+ # NOTE:
+ # we need a sufficiently annoying prefix
+ # this should suffice for now, this is
+ # used in a couple of places below, so
+ # need to put it up here for now.
+ my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
+
+ sub is_anon_class {
+ my $self = shift;
+ no warnings 'uninitialized';
+ $self->name =~ /^$ANON_CLASS_PREFIX/o;
+ }
+
+ sub create_anon_class {
+ my ($class, %options) = @_;
+ $options{weaken} = 1 unless exists $options{weaken};
+ my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
+ return $class->create($package_name, %options);
+ }
+
+ # NOTE:
+ # this will only get called for
+ # anon-classes, all other calls
+ # are assumed to occur during
+ # global destruction and so don't
+ # really need to be handled explicitly
+ sub DESTROY {
+ my $self = shift;
+
+ return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+
+ no warnings 'uninitialized';
+ my $name = $self->name;
+ return unless $name =~ /^$ANON_CLASS_PREFIX/o;
+
+ # Moose does a weird thing where it replaces the metaclass for
+ # class when fixing metaclass incompatibility. In that case,
+ # we don't want to clean out the namespace now. We can detect
+ # that because Moose will explicitly update the singleton
+ # cache in Class::MOP.
+ my $current_meta = Class::MOP::get_metaclass_by_name($name);
+ return if $current_meta ne $self;
+
+ my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
+ no strict 'refs';
+ @{$name . '::ISA'} = ();
+ %{$name . '::'} = ();
+ delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+
+ Class::MOP::remove_metaclass_by_name($name);
+ }
+
+}
+
+# creating classes with MOP ...
+
+sub create {
+ my ( $class, @args ) = @_;
+
+ unshift @args, 'package' if @args % 2 == 1;
+
+ my (%options) = @args;
+ my $package_name = $options{package};
+
+ (ref $options{superclasses} eq 'ARRAY')
+ || confess "You must pass an ARRAY ref of superclasses"
+ if exists $options{superclasses};
+
+ (ref $options{attributes} eq 'ARRAY')
+ || confess "You must pass an ARRAY ref of attributes"
+ if exists $options{attributes};
+
+ (ref $options{methods} eq 'HASH')
+ || confess "You must pass a HASH ref of methods"
+ if exists $options{methods};
+
+ $options{meta_name} = 'meta'
+ unless exists $options{meta_name};
+
+ my (%initialize_options) = @args;
+ delete @initialize_options{qw(
+ package
+ superclasses
+ attributes
+ methods
+ meta_name
+ version
+ authority
+ )};
+ my $meta = $class->initialize( $package_name => %initialize_options );
+
+ $meta->_instantiate_module( $options{version}, $options{authority} );
+
+ $meta->_add_meta_method($options{meta_name})
+ if defined $options{meta_name};
+
+ $meta->superclasses(@{$options{superclasses}})
+ if exists $options{superclasses};
+ # NOTE:
+ # process attributes first, so that they can
+ # install accessors, but locally defined methods
+ # can then overwrite them. It is maybe a little odd, but
+ # I think this should be the order of things.
+ if (exists $options{attributes}) {
+ foreach my $attr (@{$options{attributes}}) {
+ $meta->add_attribute($attr);
+ }
+ }
+ if (exists $options{methods}) {
+ foreach my $method_name (keys %{$options{methods}}) {
+ $meta->add_method($method_name, $options{methods}->{$method_name});
+ }
+ }
+ return $meta;
+}
+
+# Instance Construction & Cloning
+
+sub new_object {
+ my $class = shift;
+
+ # NOTE:
+ # we need to protect the integrity of the
+ # Class::MOP::Class singletons here, so we
+ # delegate this to &construct_class_instance
+ # which will deal with the singletons
+ return $class->_construct_class_instance(@_)
+ if $class->name->isa('Class::MOP::Class');
+ return $class->_construct_instance(@_);
+}
+
+sub _construct_instance {
+ my $class = shift;
+ my $params = @_ == 1 ? $_[0] : {@_};
+ my $meta_instance = $class->get_meta_instance();
+ # FIXME:
+ # the code below is almost certainly incorrect
+ # but this is foreign inheritance, so we might
+ # have to kludge it in the end.
+ my $instance;
+ if (my $instance_class = blessed($params->{__INSTANCE__})) {
+ ($instance_class eq $class->name)
+ || confess "Objects passed as the __INSTANCE__ parameter must "
+ . "already be blessed into the correct class, but "
+ . "$params->{__INSTANCE__} is not a " . $class->name;
+ $instance = $params->{__INSTANCE__};
+ }
+ elsif (exists $params->{__INSTANCE__}) {
+ confess "The __INSTANCE__ parameter must be a blessed reference, not "
+ . $params->{__INSTANCE__};
+ }
+ else {
+ $instance = $meta_instance->create_instance();
+ }
+ foreach my $attr ($class->get_all_attributes()) {
+ $attr->initialize_instance_slot($meta_instance, $instance, $params);
+ }
+ if (Class::MOP::metaclass_is_weak($class->name)) {
+ $meta_instance->_set_mop_slot($instance, $class);
+ }
+ return $instance;
+}
+
+sub _inline_new_object {
+ my $self = shift;
+
+ return (
+ 'my $class = shift;',
+ '$class = Scalar::Util::blessed($class) || $class;',
+ $self->_inline_fallback_constructor('$class'),
+ $self->_inline_params('$params', '$class'),
+ $self->_inline_generate_instance('$instance', '$class'),
+ $self->_inline_slot_initializers,
+ $self->_inline_preserve_weak_metaclasses,
+ $self->_inline_extra_init,
+ 'return $instance',
+ );
+}
+
+sub _inline_fallback_constructor {
+ my $self = shift;
+ my ($class) = @_;
+ return (
+ 'return ' . $self->_generate_fallback_constructor($class),
+ 'if ' . $class . ' ne \'' . $self->name . '\';',
+ );
+}
+
+sub _generate_fallback_constructor {
+ my $self = shift;
+ my ($class) = @_;
+ return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)',
+}
+
+sub _inline_params {
+ my $self = shift;
+ my ($params, $class) = @_;
+ return (
+ 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};',
+ );
+}
+
+sub _inline_generate_instance {
+ my $self = shift;
+ my ($inst, $class) = @_;
+ return (
+ 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';',
+ );
+}
+
+sub _inline_create_instance {
+ my $self = shift;
+
+ return $self->get_meta_instance->inline_create_instance(@_);
+}
+
+sub _inline_slot_initializers {
+ my $self = shift;
+
+ my $idx = 0;
+
+ return map { $self->_inline_slot_initializer($_, $idx++) }
+ sort { $a->name cmp $b->name } $self->get_all_attributes;
+}
+
+sub _inline_slot_initializer {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ if (defined(my $init_arg = $attr->init_arg)) {
+ my @source = (
+ 'if (exists $params->{\'' . $init_arg . '\'}) {',
+ $self->_inline_init_attr_from_constructor($attr, $idx),
+ '}',
+ );
+ if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
+ push @source, (
+ 'else {',
+ @default,
+ '}',
+ );
+ }
+ return @source;
+ }
+ elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
+ return (
+ '{',
+ @default,
+ '}',
+ );
+ }
+ else {
+ return ();
+ }
+}
+
+sub _inline_init_attr_from_constructor {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ my @initial_value = $attr->_inline_set_value(
+ '$instance', '$params->{\'' . $attr->init_arg . '\'}',
+ );
+
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
+
+ return @initial_value;
+}
+
+sub _inline_init_attr_from_default {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ my $default = $self->_inline_default_value($attr, $idx);
+ return unless $default;
+
+ my @initial_value = $attr->_inline_set_value('$instance', $default);
+
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
+
+ return @initial_value;
+}
+
+sub _inline_default_value {
+ my $self = shift;
+ my ($attr, $index) = @_;
+
+ if ($attr->has_default) {
+ # NOTE:
+ # default values can either be CODE refs
+ # in which case we need to call them. Or
+ # they can be scalars (strings/numbers)
+ # in which case we can just deal with them
+ # in the code we eval.
+ if ($attr->is_default_a_coderef) {
+ return '$defaults->[' . $index . ']->($instance)';
+ }
+ else {
+ return '$defaults->[' . $index . ']';
+ }
+ }
+ elsif ($attr->has_builder) {
+ return '$instance->' . $attr->builder;
+ }
+ else {
+ return;
+ }
+}
+
+sub _inline_preserve_weak_metaclasses {
+ my $self = shift;
+ if (Class::MOP::metaclass_is_weak($self->name)) {
+ return (
+ $self->_inline_set_mop_slot(
+ '$instance', 'Class::MOP::class_of($class)'
+ ) . ';'
+ );
+ }
+ else {
+ return ();
+ }
+}
+
+sub _inline_extra_init { }
+
+
+sub get_meta_instance {
+ my $self = shift;
+ $self->{'_meta_instance'} ||= $self->_create_meta_instance();
+}
+
+sub _create_meta_instance {
+ my $self = shift;
+
+ my $instance = $self->instance_metaclass->new(
+ associated_metaclass => $self,
+ attributes => [ $self->get_all_attributes() ],
+ );
+
+ $self->add_meta_instance_dependencies()
+ if $instance->is_dependent_on_superclasses();
+
+ return $instance;
+}
+
+sub _inline_rebless_instance {
+ my $self = shift;
+
+ return $self->get_meta_instance->inline_rebless_instance_structure(@_);
+}
+
+sub _inline_get_mop_slot {
+ my $self = shift;
+
+ return $self->get_meta_instance->_inline_get_mop_slot(@_);
+}
+
+sub _inline_set_mop_slot {
+ my $self = shift;
+
+ return $self->get_meta_instance->_inline_set_mop_slot(@_);
+}
+
+sub _inline_clear_mop_slot {
+ my $self = shift;
+
+ return $self->get_meta_instance->_inline_clear_mop_slot(@_);
+}
+
+sub clone_object {
+ my $class = shift;
+ my $instance = shift;
+ (blessed($instance) && $instance->isa($class->name))
+ || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
+
+ # NOTE:
+ # we need to protect the integrity of the
+ # Class::MOP::Class singletons here, they
+ # should not be cloned.
+ return $instance if $instance->isa('Class::MOP::Class');
+ $class->_clone_instance($instance, @_);
+}
+
+sub _clone_instance {
+ my ($class, $instance, %params) = @_;
+ (blessed($instance))
+ || confess "You can only clone instances, ($instance) is not a blessed instance";
+ my $meta_instance = $class->get_meta_instance();
+ my $clone = $meta_instance->clone_instance($instance);
+ foreach my $attr ($class->get_all_attributes()) {
+ if ( defined( my $init_arg = $attr->init_arg ) ) {
+ if (exists $params{$init_arg}) {
+ $attr->set_value($clone, $params{$init_arg});
+ }
+ }
+ }
+ return $clone;
+}
+
+sub _force_rebless_instance {
+ my ($self, $instance, %params) = @_;
+ my $old_metaclass = Class::MOP::class_of($instance);
+
+ $old_metaclass->rebless_instance_away($instance, $self, %params)
+ if $old_metaclass;
+
+ my $meta_instance = $self->get_meta_instance;
+
+ if (Class::MOP::metaclass_is_weak($old_metaclass->name)) {
+ $meta_instance->_clear_mop_slot($instance);
+ }
+
+ # rebless!
+ # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
+ $meta_instance->rebless_instance_structure($_[1], $self);
+
+ $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
+
+ if (Class::MOP::metaclass_is_weak($self->name)) {
+ $meta_instance->_set_mop_slot($instance, $self);
+ }
+}
+
+sub rebless_instance {
+ my ($self, $instance, %params) = @_;
+ my $old_metaclass = Class::MOP::class_of($instance);
+
+ my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
+ $self->name->isa($old_class)
+ || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
+
+ $self->_force_rebless_instance($_[1], %params);
+
+ return $instance;
+}
+
+sub rebless_instance_back {
+ my ( $self, $instance ) = @_;
+ my $old_metaclass = Class::MOP::class_of($instance);
+
+ my $old_class
+ = $old_metaclass ? $old_metaclass->name : blessed($instance);
+ $old_class->isa( $self->name )
+ || confess
+ "You may rebless only into a superclass of ($old_class), of which ("
+ . $self->name
+ . ") isn't.";
+
+ $self->_force_rebless_instance($_[1]);
+
+ return $instance;
+}
+
+sub rebless_instance_away {
+ # this intentionally does nothing, it is just a hook
+}
+
+sub _fixup_attributes_after_rebless {
+ my $self = shift;
+ my ($instance, $rebless_from, %params) = @_;
+ my $meta_instance = $self->get_meta_instance;
+
+ for my $attr ( $rebless_from->get_all_attributes ) {
+ next if $self->find_attribute_by_name( $attr->name );
+ $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
+ }
+
+ foreach my $attr ( $self->get_all_attributes ) {
+ if ( $attr->has_value($instance) ) {
+ if ( defined( my $init_arg = $attr->init_arg ) ) {
+ $params{$init_arg} = $attr->get_value($instance)
+ unless exists $params{$init_arg};
+ }
+ else {
+ $attr->set_value($instance, $attr->get_value($instance));
+ }
+ }
+ }
+
+ foreach my $attr ($self->get_all_attributes) {
+ $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+ }
+}
+
+sub _attach_attribute {
+ my ($self, $attribute) = @_;
+ $attribute->attach_to_class($self);
+}
+
+sub _post_add_attribute {
+ my ( $self, $attribute ) = @_;
+
+ $self->invalidate_meta_instances;
+
+ # invalidate package flag here
+ try {
+ local $SIG{__DIE__};
+ $attribute->install_accessors;
+ }
+ catch {
+ $self->remove_attribute( $attribute->name );
+ die $_;
+ };
+}
+
+sub remove_attribute {
+ my $self = shift;
+
+ my $removed_attribute = $self->SUPER::remove_attribute(@_)
+ or return;
+
+ $self->invalidate_meta_instances;
+
+ $removed_attribute->remove_accessors;
+ $removed_attribute->detach_from_class;
+
+ return$removed_attribute;
+}
+
+sub find_attribute_by_name {
+ my ( $self, $attr_name ) = @_;
+
+ foreach my $class ( $self->linearized_isa ) {
+ # fetch the meta-class ...
+ my $meta = Class::MOP::Class->initialize($class);
+ return $meta->get_attribute($attr_name)
+ if $meta->has_attribute($attr_name);
+ }
+
+ return;
+}
+
+sub get_all_attributes {
+ my $self = shift;
+ my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
+ reverse $self->linearized_isa;
+ return values %attrs;
+}
+
+# Inheritance
+
+sub superclasses {
+ my $self = shift;
+
+ my $isa = $self->get_or_add_package_symbol('@ISA');
+
+ if (@_) {
+ my @supers = @_;
+ @{$isa} = @supers;
+
+ # NOTE:
+ # on 5.8 and below, we need to call
+ # a method to get Perl to detect
+ # a cycle in the class hierarchy
+ my $class = $self->name;
+ $class->isa($class);
+
+ # NOTE:
+ # we need to check the metaclass
+ # compatibility here so that we can
+ # be sure that the superclass is
+ # not potentially creating an issues
+ # we don't know about
+
+ $self->_check_metaclass_compatibility();
+ $self->_superclasses_updated();
+ }
+
+ return @{$isa};
+}
+
+sub _superclasses_updated {
+ my $self = shift;
+ $self->update_meta_instance_dependencies();
+ # keep strong references to all our parents, so they don't disappear if
+ # they are anon classes and don't have any direct instances
+ $self->_superclass_metas(
+ map { Class::MOP::class_of($_) } $self->superclasses
+ );
+}
+
+sub _superclass_metas {
+ my $self = shift;
+ $self->{_superclass_metas} = [@_];
+}
+
+sub subclasses {
+ my $self = shift;
+ my $super_class = $self->name;
+
+ return @{ $super_class->mro::get_isarev() };
+}
+
+sub direct_subclasses {
+ my $self = shift;
+ my $super_class = $self->name;
+
+ return grep {
+ grep {
+ $_ eq $super_class
+ } Class::MOP::Class->initialize($_)->superclasses
+ } $self->subclasses;
+}
+
+sub linearized_isa {
+ return @{ mro::get_linear_isa( (shift)->name ) };
+}
+
+sub class_precedence_list {
+ my $self = shift;
+ my $name = $self->name;
+
+ unless (Class::MOP::IS_RUNNING_ON_5_10()) {
+ # NOTE:
+ # We need to check for circular inheritance here
+ # if we are are not on 5.10, cause 5.8 detects it
+ # late. This will do nothing if all is well, and
+ # blow up otherwise. Yes, it's an ugly hack, better
+ # suggestions are welcome.
+ # - SL
+ ($name || return)->isa('This is a test for circular inheritance')
+ }
+
+ # if our mro is c3, we can
+ # just grab the linear_isa
+ if (mro::get_mro($name) eq 'c3') {
+ return @{ mro::get_linear_isa($name) }
+ }
+ else {
+ # NOTE:
+ # we can't grab the linear_isa for dfs
+ # since it has all the duplicates
+ # already removed.
+ return (
+ $name,
+ map {
+ Class::MOP::Class->initialize($_)->class_precedence_list()
+ } $self->superclasses()
+ );
+ }
+}
+
+## Methods
+
+{
+ my $fetch_and_prepare_method = sub {
+ my ($self, $method_name) = @_;
+ my $wrapped_metaclass = $self->wrapped_method_metaclass;
+ # fetch it locally
+ my $method = $self->get_method($method_name);
+ # if we dont have local ...
+ unless ($method) {
+ # try to find the next method
+ $method = $self->find_next_method_by_name($method_name);
+ # die if it does not exist
+ (defined $method)
+ || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
+ # and now make sure to wrap it
+ # even if it is already wrapped
+ # because we need a new sub ref
+ $method = $wrapped_metaclass->wrap($method,
+ package_name => $self->name,
+ name => $method_name,
+ );
+ }
+ else {
+ # now make sure we wrap it properly
+ $method = $wrapped_metaclass->wrap($method,
+ package_name => $self->name,
+ name => $method_name,
+ ) unless $method->isa($wrapped_metaclass);
+ }
+ $self->add_method($method_name => $method);
+ return $method;
+ };
+
+ sub add_before_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && length $method_name)
+ || confess "You must pass in a method name";
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_before_modifier(
+ subname(':before' => $method_modifier)
+ );
+ }
+
+ sub add_after_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && length $method_name)
+ || confess "You must pass in a method name";
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_after_modifier(
+ subname(':after' => $method_modifier)
+ );
+ }
+
+ sub add_around_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && length $method_name)
+ || confess "You must pass in a method name";
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_around_modifier(
+ subname(':around' => $method_modifier)
+ );
+ }
+
+ # NOTE:
+ # the methods above used to be named like this:
+ # ${pkg}::${method}:(before|after|around)
+ # but this proved problematic when using one modifier
+ # to wrap multiple methods (something which is likely
+ # to happen pretty regularly IMO). So instead of naming
+ # it like this, I have chosen to just name them purely
+ # with their modifier names, like so:
+ # :(before|after|around)
+ # The fact is that in a stack trace, it will be fairly
+ # evident from the context what method they are attached
+ # to, and so don't need the fully qualified name.
+}
+
+sub find_method_by_name {
+ my ($self, $method_name) = @_;
+ (defined $method_name && length $method_name)
+ || confess "You must define a method name to find";
+ foreach my $class ($self->linearized_isa) {
+ my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
+ return $method if defined $method;
+ }
+ return;
+}
+
+sub get_all_methods {
+ my $self = shift;
+
+ my %methods;
+ for my $class ( reverse $self->linearized_isa ) {
+ my $meta = Class::MOP::Class->initialize($class);
+
+ $methods{ $_->name } = $_ for $meta->_get_local_methods;
+ }
+
+ return values %methods;
+}
+
+sub get_all_method_names {
+ my $self = shift;
+ my %uniq;
+ return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
+}
+
+sub find_all_methods_by_name {
+ my ($self, $method_name) = @_;
+ (defined $method_name && length $method_name)
+ || confess "You must define a method name to find";
+ my @methods;
+ foreach my $class ($self->linearized_isa) {
+ # fetch the meta-class ...
+ my $meta = Class::MOP::Class->initialize($class);
+ push @methods => {
+ name => $method_name,
+ class => $class,
+ code => $meta->get_method($method_name)
+ } if $meta->has_method($method_name);
+ }
+ return @methods;
+}
+
+sub find_next_method_by_name {
+ my ($self, $method_name) = @_;
+ (defined $method_name && length $method_name)
+ || confess "You must define a method name to find";
+ my @cpl = $self->linearized_isa;
+ shift @cpl; # discard ourselves
+ foreach my $class (@cpl) {
+ my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
+ return $method if defined $method;
+ }
+ return;
+}
+
+sub update_meta_instance_dependencies {
+ my $self = shift;
+
+ if ( $self->{meta_instance_dependencies} ) {
+ return $self->add_meta_instance_dependencies;
+ }
+}
+
+sub add_meta_instance_dependencies {
+ my $self = shift;
+
+ $self->remove_meta_instance_dependencies;
+
+ my @attrs = $self->get_all_attributes();
+
+ my %seen;
+ my @classes = grep { not $seen{ $_->name }++ }
+ map { $_->associated_class } @attrs;
+
+ foreach my $class (@classes) {
+ $class->add_dependent_meta_instance($self);
+ }
+
+ $self->{meta_instance_dependencies} = \@classes;
+}
+
+sub remove_meta_instance_dependencies {
+ my $self = shift;
+
+ if ( my $classes = delete $self->{meta_instance_dependencies} ) {
+ foreach my $class (@$classes) {
+ $class->remove_dependent_meta_instance($self);
+ }
+
+ return $classes;
+ }
+
+ return;
+
+}
+
+sub add_dependent_meta_instance {
+ my ( $self, $metaclass ) = @_;
+ push @{ $self->{dependent_meta_instances} }, $metaclass;
+}
+
+sub remove_dependent_meta_instance {
+ my ( $self, $metaclass ) = @_;
+ my $name = $metaclass->name;
+ @$_ = grep { $_->name ne $name } @$_
+ for $self->{dependent_meta_instances};
+}
+
+sub invalidate_meta_instances {
+ my $self = shift;
+ $_->invalidate_meta_instance()
+ for $self, @{ $self->{dependent_meta_instances} };
+}
+
+sub invalidate_meta_instance {
+ my $self = shift;
+ undef $self->{_meta_instance};
+}
+
+# check if we can reinitialize
+sub is_pristine {
+ my $self = shift;
+
+ # if any local attr is defined
+ return if $self->get_attribute_list;
+
+ # or any non-declared methods
+ for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
+ return if $method->isa("Class::MOP::Method::Generated");
+ # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
+ }
+
+ return 1;
+}
+
+## Class closing
+
+sub is_mutable { 1 }
+sub is_immutable { 0 }
+
+sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
+
+sub _immutable_options {
+ my ( $self, @args ) = @_;
+
+ return (
+ inline_accessors => 1,
+ inline_constructor => 1,
+ inline_destructor => 0,
+ debug => 0,
+ immutable_trait => $self->immutable_trait,
+ constructor_name => $self->constructor_name,
+ constructor_class => $self->constructor_class,
+ destructor_class => $self->destructor_class,
+ @args,
+ );
+}
+
+sub make_immutable {
+ my ( $self, @args ) = @_;
+
+ if ( $self->is_mutable ) {
+ $self->_initialize_immutable( $self->_immutable_options(@args) );
+ $self->_rebless_as_immutable(@args);
+ return $self;
+ }
+ else {
+ return;
+ }
+}
+
+sub make_mutable {
+ my $self = shift;
+
+ if ( $self->is_immutable ) {
+ my @args = $self->immutable_options;
+ $self->_rebless_as_mutable();
+ $self->_remove_inlined_code(@args);
+ delete $self->{__immutable};
+ return $self;
+ }
+ else {
+ return;
+ }
+}
+
+sub _rebless_as_immutable {
+ my ( $self, @args ) = @_;
+
+ $self->{__immutable}{original_class} = ref $self;
+
+ bless $self => $self->_immutable_metaclass(@args);
+}
+
+sub _immutable_metaclass {
+ my ( $self, %args ) = @_;
+
+ if ( my $class = $args{immutable_metaclass} ) {
+ return $class;
+ }
+
+ my $trait = $args{immutable_trait} = $self->immutable_trait
+ || confess "no immutable trait specified for $self";
+
+ my $meta = $self->meta;
+ my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
+
+ my $class_name;
+
+ if ( $meta_attr and $trait eq $meta_attr->default ) {
+ # if the trait is the same as the default we try and pick a
+ # predictable name for the immutable metaclass
+ $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
+ }
+ else {
+ $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
+ $trait, 'ForMetaClass', ref($self);
+ }
+
+ return $class_name
+ if Class::MOP::is_class_loaded($class_name);
+
+ # If the metaclass is a subclass of CMOP::Class which has had
+ # metaclass roles applied (via Moose), then we want to make sure
+ # that we preserve that anonymous class (see Fey::ORM for an
+ # example of where this matters).
+ my $meta_name = $meta->_real_ref_name;
+
+ my $immutable_meta = $meta_name->create(
+ $class_name,
+ superclasses => [ ref $self ],
+ );
+
+ Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
+
+ $immutable_meta->make_immutable(
+ inline_constructor => 0,
+ inline_accessors => 0,
+ );
+
+ return $class_name;
+}
+
+sub _remove_inlined_code {
+ my $self = shift;
+
+ $self->remove_method( $_->name ) for $self->_inlined_methods;
+
+ delete $self->{__immutable}{inlined_methods};
+}
+
+sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
+
+sub _add_inlined_method {
+ my ( $self, $method ) = @_;
+
+ push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
+}
+
+sub _initialize_immutable {
+ my ( $self, %args ) = @_;
+
+ $self->{__immutable}{options} = \%args;
+ $self->_install_inlined_code(%args);
+}
+
+sub _install_inlined_code {
+ my ( $self, %args ) = @_;
+
+ # FIXME
+ $self->_inline_accessors(%args) if $args{inline_accessors};
+ $self->_inline_constructor(%args) if $args{inline_constructor};
+ $self->_inline_destructor(%args) if $args{inline_destructor};
+}
+
+sub _rebless_as_mutable {
+ my $self = shift;
+
+ bless $self, $self->_get_mutable_metaclass_name;
+
+ return $self;
+}
+
+sub _inline_accessors {
+ my $self = shift;
+
+ foreach my $attr_name ( $self->get_attribute_list ) {
+ $self->get_attribute($attr_name)->install_accessors(1);
+ }
+}
+
+sub _inline_constructor {
+ my ( $self, %args ) = @_;
+
+ my $name = $args{constructor_name};
+ # A class may not even have a constructor, and that's okay.
+ return unless defined $name;
+
+ if ( $self->has_method($name) && !$args{replace_constructor} ) {
+ my $class = $self->name;
+ warn "Not inlining a constructor for $class since it defines"
+ . " its own constructor.\n"
+ . "If you are certain you don't need to inline your"
+ . " constructor, specify inline_constructor => 0 in your"
+ . " call to $class->meta->make_immutable\n";
+ return;
+ }
+
+ my $constructor_class = $args{constructor_class};
+
+ Class::MOP::load_class($constructor_class);
+
+ my $constructor = $constructor_class->new(
+ options => \%args,
+ metaclass => $self,
+ is_inline => 1,
+ package_name => $self->name,
+ name => $name,
+ );
+
+ if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
+ $self->add_method( $name => $constructor );
+ $self->_add_inlined_method($constructor);
+ }
+}
+
+sub _inline_destructor {
+ my ( $self, %args ) = @_;
+
+ ( exists $args{destructor_class} && defined $args{destructor_class} )
+ || confess "The 'inline_destructor' option is present, but "
+ . "no destructor class was specified";
+
+ if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
+ my $class = $self->name;
+ warn "Not inlining a destructor for $class since it defines"
+ . " its own destructor.\n";
+ return;
+ }
+
+ my $destructor_class = $args{destructor_class};
+
+ Class::MOP::load_class($destructor_class);
+
+ return unless $destructor_class->is_needed($self);
+
+ my $destructor = $destructor_class->new(
+ options => \%args,
+ metaclass => $self,
+ package_name => $self->name,
+ name => 'DESTROY'
+ );
+
+ if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
+ $self->add_method( 'DESTROY' => $destructor );
+ $self->_add_inlined_method($destructor);
+ }
+}
+
+1;
+
+# ABSTRACT: Class Meta Object
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+ # assuming that class Foo
+ # has been defined, you can
+
+ # use this for introspection ...
+
+ # add a method to Foo ...
+ Foo->meta->add_method( 'bar' => sub {...} )
+
+ # get a list of all the classes searched
+ # the method dispatcher in the correct order
+ Foo->meta->class_precedence_list()
+
+ # remove a method from Foo
+ Foo->meta->remove_method('bar');
+
+ # or use this to actually create classes ...
+
+ Class::MOP::Class->create(
+ 'Bar' => (
+ version => '0.01',
+ superclasses => ['Foo'],
+ attributes => [
+ Class::MOP::Attribute->new('$bar'),
+ Class::MOP::Attribute->new('$baz'),
+ ],
+ methods => {
+ calculate_bar => sub {...},
+ construct_baz => sub {...}
+ }
+ )
+ );
+
+=head1 DESCRIPTION
+
+The Class Protocol is the largest and most complex part of the
+Class::MOP meta-object protocol. It controls the introspection and
+manipulation of Perl 5 classes, and it can create them as well. The
+best way to understand what this module can do is to read the
+documentation for each of its methods.
+
+=head1 INHERITANCE
+
+C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
+
+=head1 METHODS
+
+=head2 Class construction
+
+These methods all create new C<Class::MOP::Class> objects. These
+objects can represent existing classes or they can be used to create
+new classes from scratch.
+
+The metaclass object for a given class is a singleton. If you attempt
+to create a metaclass for the same class twice, you will just get the
+existing object.
+
+=over 4
+
+=item B<< Class::MOP::Class->create($package_name, %options) >>
+
+This method creates a new C<Class::MOP::Class> object with the given
+package name. It accepts a number of options:
+
+=over 8
+
+=item * version
+
+An optional version number for the newly created package.
+
+=item * authority
+
+An optional authority for the newly created package.
+
+=item * superclasses
+
+An optional array reference of superclass names.
+
+=item * methods
+
+An optional hash reference of methods for the class. The keys of the
+hash reference are method names and values are subroutine references.
+
+=item * attributes
+
+An optional array reference of L<Class::MOP::Attribute> objects.
+
+=item * meta_name
+
+Specifies the name to install the C<meta> method for this class under.
+If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
+given, no meta method will be installed.
+
+=item * weaken
+
+If true, the metaclass that is stored in the global cache will be a
+weak reference.
+
+Classes created in this way are destroyed once the metaclass they are
+attached to goes out of scope, and will be removed from Perl's internal
+symbol table.
+
+All instances of a class with a weakened metaclass keep a special
+reference to the metaclass object, which prevents the metaclass from
+going out of scope while any instances exist.
+
+This only works if the instance is based on a hash reference, however.
+
+=back
+
+=item B<< Class::MOP::Class->create_anon_class(%options) >>
+
+This method works just like C<< Class::MOP::Class->create >> but it
+creates an "anonymous" class. In fact, the class does have a name, but
+that name is a unique name generated internally by this module.
+
+It accepts the same C<superclasses>, C<methods>, and C<attributes>
+parameters that C<create> accepts.
+
+Anonymous classes default to C<< weaken => 1 >>, although this can be
+overridden.
+
+=item B<< Class::MOP::Class->initialize($package_name, %options) >>
+
+This method will initialize a C<Class::MOP::Class> object for the
+named package. Unlike C<create>, this method I<will not> create a new
+class.
+
+The purpose of this method is to retrieve a C<Class::MOP::Class>
+object for introspecting an existing class.
+
+If an existing C<Class::MOP::Class> object exists for the named
+package, it will be returned, and any options provided will be
+ignored!
+
+If the object does not yet exist, it will be created.
+
+The valid options that can be passed to this method are
+C<attribute_metaclass>, C<method_metaclass>,
+C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
+optional, and default to the appropriate class in the C<Class::MOP>
+distribution.
+
+=back
+
+=head2 Object instance construction and cloning
+
+These methods are all related to creating and/or cloning object
+instances.
+
+=over 4
+
+=item B<< $metaclass->clone_object($instance, %params) >>
+
+This method clones an existing object instance. Any parameters you
+provide are will override existing attribute values in the object.
+
+This is a convenience method for cloning an object instance, then
+blessing it into the appropriate package.
+
+You could implement a clone method in your class, using this method:
+
+ sub clone {
+ my ($self, %params) = @_;
+ $self->meta->clone_object($self, %params);
+ }
+
+=item B<< $metaclass->rebless_instance($instance, %params) >>
+
+This method changes the class of C<$instance> to the metaclass's class.
+
+You can only rebless an instance into a subclass of its current
+class. If you pass any additional parameters, these will be treated
+like constructor parameters and used to initialize the object's
+attributes. Any existing attributes that are already set will be
+overwritten.
+
+Before reblessing the instance, this method will call
+C<rebless_instance_away> on the instance's current metaclass. This method
+will be passed the instance, the new metaclass, and any parameters
+specified to C<rebless_instance>. By default, C<rebless_instance_away>
+does nothing; it is merely a hook.
+
+=item B<< $metaclass->rebless_instance_back($instance) >>
+
+Does the same thing as C<rebless_instance>, except that you can only
+rebless an instance into one of its superclasses. Any attributes that
+do not exist in the superclass will be deinitialized.
+
+This is a much more dangerous operation than C<rebless_instance>,
+especially when multiple inheritance is involved, so use this carefully!
+
+=item B<< $metaclass->new_object(%params) >>
+
+This method is used to create a new object of the metaclass's
+class. Any parameters you provide are used to initialize the
+instance's attributes. A special C<__INSTANCE__> key can be passed to
+provide an already generated instance, rather than having Class::MOP
+generate it for you. This is mostly useful for using Class::MOP with
+foreign classes which generate instances using their own constructors.
+
+=item B<< $metaclass->instance_metaclass >>
+
+Returns the class name of the instance metaclass. See
+L<Class::MOP::Instance> for more information on the instance
+metaclass.
+
+=item B<< $metaclass->get_meta_instance >>
+
+Returns an instance of the C<instance_metaclass> to be used in the
+construction of a new instance of the class.
+
+=back
+
+=head2 Informational predicates
+
+These are a few predicate methods for asking information about the
+class itself.
+
+=over 4
+
+=item B<< $metaclass->is_anon_class >>
+
+This returns true if the class was created by calling C<<
+Class::MOP::Class->create_anon_class >>.
+
+=item B<< $metaclass->is_mutable >>
+
+This returns true if the class is still mutable.
+
+=item B<< $metaclass->is_immutable >>
+
+This returns true if the class has been made immutable.
+
+=item B<< $metaclass->is_pristine >>
+
+A class is I<not> pristine if it has non-inherited attributes or if it
+has any generated methods.
+
+=back
+
+=head2 Inheritance Relationships
+
+=over 4
+
+=item B<< $metaclass->superclasses(@superclasses) >>
+
+This is a read-write accessor which represents the superclass
+relationships of the metaclass's class.
+
+This is basically sugar around getting and setting C<@ISA>.
+
+=item B<< $metaclass->class_precedence_list >>
+
+This returns a list of all of the class's ancestor classes. The
+classes are returned in method dispatch order.
+
+=item B<< $metaclass->linearized_isa >>
+
+This returns a list based on C<class_precedence_list> but with all
+duplicates removed.
+
+=item B<< $metaclass->subclasses >>
+
+This returns a list of all subclasses for this class, even indirect
+subclasses.
+
+=item B<< $metaclass->direct_subclasses >>
+
+This returns a list of immediate subclasses for this class, which does not
+include indirect subclasses.
+
+=back
+
+=head2 Method introspection and creation
+
+These methods allow you to introspect a class's methods, as well as
+add, remove, or change methods.
+
+Determining what is truly a method in a Perl 5 class requires some
+heuristics (aka guessing).
+
+Methods defined outside the package with a fully qualified name (C<sub
+Package::name { ... }>) will be included. Similarly, methods named
+with a fully qualified name using L<Sub::Name> are also included.
+
+However, we attempt to ignore imported functions.
+
+Ultimately, we are using heuristics to determine what truly is a
+method in a class, and these heuristics may get the wrong answer in
+some edge cases. However, for most "normal" cases the heuristics work
+correctly.
+
+=over 4
+
+=item B<< $metaclass->get_method($method_name) >>
+
+This will return a L<Class::MOP::Method> for the specified
+C<$method_name>. If the class does not have the specified method, it
+returns C<undef>
+
+=item B<< $metaclass->has_method($method_name) >>
+
+Returns a boolean indicating whether or not the class defines the
+named method. It does not include methods inherited from parent
+classes.
+
+=item B<< $metaclass->get_method_list >>
+
+This will return a list of method I<names> for all methods defined in
+this class.
+
+=item B<< $metaclass->add_method($method_name, $method) >>
+
+This method takes a method name and a subroutine reference, and adds
+the method to the class.
+
+The subroutine reference can be a L<Class::MOP::Method>, and you are
+strongly encouraged to pass a meta method object instead of a code
+reference. If you do so, that object gets stored as part of the
+class's method map directly. If not, the meta information will have to
+be recreated later, and may be incorrect.
+
+If you provide a method object, this method will clone that object if
+the object's package name does not match the class name. This lets us
+track the original source of any methods added from other classes
+(notably Moose roles).
+
+=item B<< $metaclass->remove_method($method_name) >>
+
+Remove the named method from the class. This method returns the
+L<Class::MOP::Method> object for the method.
+
+=item B<< $metaclass->method_metaclass >>
+
+Returns the class name of the method metaclass, see
+L<Class::MOP::Method> for more information on the method metaclass.
+
+=item B<< $metaclass->wrapped_method_metaclass >>
+
+Returns the class name of the wrapped method metaclass, see
+L<Class::MOP::Method::Wrapped> for more information on the wrapped
+method metaclass.
+
+=item B<< $metaclass->get_all_methods >>
+
+This will traverse the inheritance hierarchy and return a list of all
+the L<Class::MOP::Method> objects for this class and its parents.
+
+=item B<< $metaclass->find_method_by_name($method_name) >>
+
+This will return a L<Class::MOP::Method> for the specified
+C<$method_name>. If the class does not have the specified method, it
+returns C<undef>
+
+Unlike C<get_method>, this method I<will> look for the named method in
+superclasses.
+
+=item B<< $metaclass->get_all_method_names >>
+
+This will return a list of method I<names> for all of this class's
+methods, including inherited methods.
+
+=item B<< $metaclass->find_all_methods_by_name($method_name) >>
+
+This method looks for the named method in the class and all of its
+parents. It returns every matching method it finds in the inheritance
+tree, so it returns a list of methods.
+
+Each method is returned as a hash reference with three keys. The keys
+are C<name>, C<class>, and C<code>. The C<code> key has a
+L<Class::MOP::Method> object as its value.
+
+The list of methods is distinct.
+
+=item B<< $metaclass->find_next_method_by_name($method_name) >>
+
+This method returns the first method in any superclass matching the
+given name. It is effectively the method that C<SUPER::$method_name>
+would dispatch to.
+
+=back
+
+=head2 Attribute introspection and creation
+
+Because Perl 5 does not have a core concept of attributes in classes,
+we can only return information about attributes which have been added
+via this class's methods. We cannot discover information about
+attributes which are defined in terms of "regular" Perl 5 methods.
+
+=over 4
+
+=item B<< $metaclass->get_attribute($attribute_name) >>
+
+This will return a L<Class::MOP::Attribute> for the specified
+C<$attribute_name>. If the class does not have the specified
+attribute, it returns C<undef>.
+
+NOTE that get_attribute does not search superclasses, for that you
+need to use C<find_attribute_by_name>.
+
+=item B<< $metaclass->has_attribute($attribute_name) >>
+
+Returns a boolean indicating whether or not the class defines the
+named attribute. It does not include attributes inherited from parent
+classes.
+
+=item B<< $metaclass->get_attribute_list >>
+
+This will return a list of attributes I<names> for all attributes
+defined in this class. Note that this operates on the current class
+only, it does not traverse the inheritance hierarchy.
+
+=item B<< $metaclass->get_all_attributes >>
+
+This will traverse the inheritance hierarchy and return a list of all
+the L<Class::MOP::Attribute> objects for this class and its parents.
+
+=item B<< $metaclass->find_attribute_by_name($attribute_name) >>
+
+This will return a L<Class::MOP::Attribute> for the specified
+C<$attribute_name>. If the class does not have the specified
+attribute, it returns C<undef>.
+
+Unlike C<get_attribute>, this attribute I<will> look for the named
+attribute in superclasses.
+
+=item B<< $metaclass->add_attribute(...) >>
+
+This method accepts either an existing L<Class::MOP::Attribute>
+object or parameters suitable for passing to that class's C<new>
+method.
+
+The attribute provided will be added to the class.
+
+Any accessor methods defined by the attribute will be added to the
+class when the attribute is added.
+
+If an attribute of the same name already exists, the old attribute
+will be removed first.
+
+=item B<< $metaclass->remove_attribute($attribute_name) >>
+
+This will remove the named attribute from the class, and
+L<Class::MOP::Attribute> object.
+
+Removing an attribute also removes any accessor methods defined by the
+attribute.
+
+However, note that removing an attribute will only affect I<future>
+object instances created for this class, not existing instances.
+
+=item B<< $metaclass->attribute_metaclass >>
+
+Returns the class name of the attribute metaclass for this class. By
+default, this is L<Class::MOP::Attribute>.
+
+=back
+
+=head2 Class Immutability
+
+Making a class immutable "freezes" the class definition. You can no
+longer call methods which alter the class, such as adding or removing
+methods or attributes.
+
+Making a class immutable lets us optimize the class by inlining some
+methods, and also allows us to optimize some methods on the metaclass
+object itself.
+
+After immutabilization, the metaclass object will cache most informational
+methods that returns information about methods or attributes. Methods which
+would alter the class, such as C<add_attribute> and C<add_method>, will
+throw an error on an immutable metaclass object.
+
+The immutabilization system in L<Moose> takes much greater advantage
+of the inlining features than Class::MOP itself does.
+
+=over 4
+
+=item B<< $metaclass->make_immutable(%options) >>
+
+This method will create an immutable transformer and use it to make
+the class and its metaclass object immutable.
+
+This method accepts the following options:
+
+=over 8
+
+=item * inline_accessors
+
+=item * inline_constructor
+
+=item * inline_destructor
+
+These are all booleans indicating whether the specified method(s)
+should be inlined.
+
+By default, accessors and the constructor are inlined, but not the
+destructor.
+
+=item * immutable_trait
+
+The name of a class which will be used as a parent class for the
+metaclass object being made immutable. This "trait" implements the
+post-immutability functionality of the metaclass (but not the
+transformation itself).
+
+This defaults to L<Class::MOP::Class::Immutable::Trait>.
+
+=item * constructor_name
+
+This is the constructor method name. This defaults to "new".
+
+=item * constructor_class
+
+The name of the method metaclass for constructors. It will be used to
+generate the inlined constructor. This defaults to
+"Class::MOP::Method::Constructor".
+
+=item * replace_constructor
+
+This is a boolean indicating whether an existing constructor should be
+replaced when inlining a constructor. This defaults to false.
+
+=item * destructor_class
+
+The name of the method metaclass for destructors. It will be used to
+generate the inlined destructor. This defaults to
+"Class::MOP::Method::Denstructor".
+
+=item * replace_destructor
+
+This is a boolean indicating whether an existing destructor should be
+replaced when inlining a destructor. This defaults to false.
+
+=back
+
+=item B<< $metaclass->immutable_options >>
+
+Returns a hash of the options used when making the class immutable, including
+both defaults and anything supplied by the user in the call to C<<
+$metaclass->make_immutable >>. This is useful if you need to temporarily make
+a class mutable and then restore immutability as it was before.
+
+=item B<< $metaclass->make_mutable >>
+
+Calling this method reverse the immutabilization transformation.
+
+=back
+
+=head2 Method Modifiers
+
+Method modifiers are hooks which allow a method to be wrapped with
+I<before>, I<after> and I<around> method modifiers. Every time a
+method is called, its modifiers are also called.
+
+A class can modify its own methods, as well as methods defined in
+parent classes.
+
+=head3 How method modifiers work?
+
+Method modifiers work by wrapping the original method and then
+replacing it in the class's symbol table. The wrappers will handle
+calling all the modifiers in the appropriate order and preserving the
+calling context for the original method.
+
+The return values of C<before> and C<after> modifiers are
+ignored. This is because their purpose is B<not> to filter the input
+and output of the primary method (this is done with an I<around>
+modifier).
+
+This may seem like an odd restriction to some, but doing this allows
+for simple code to be added at the beginning or end of a method call
+without altering the function of the wrapped method or placing any
+extra responsibility on the code of the modifier.
+
+Of course if you have more complex needs, you can use the C<around>
+modifier which allows you to change both the parameters passed to the
+wrapped method, as well as its return value.
+
+Before and around modifiers are called in last-defined-first-called
+order, while after modifiers are called in first-defined-first-called
+order. So the call tree might looks something like this:
+
+ before 2
+ before 1
+ around 2
+ around 1
+ primary
+ around 1
+ around 2
+ after 1
+ after 2
+
+=head3 What is the performance impact?
+
+Of course there is a performance cost associated with method
+modifiers, but we have made every effort to make that cost directly
+proportional to the number of modifier features you use.
+
+The wrapping method does its best to B<only> do as much work as it
+absolutely needs to. In order to do this we have moved some of the
+performance costs to set-up time, where they are easier to amortize.
+
+All this said, our benchmarks have indicated the following:
+
+ simple wrapper with no modifiers 100% slower
+ simple wrapper with simple before modifier 400% slower
+ simple wrapper with simple after modifier 450% slower
+ simple wrapper with simple around modifier 500-550% slower
+ simple wrapper with all 3 modifiers 1100% slower
+
+These numbers may seem daunting, but you must remember, every feature
+comes with some cost. To put things in perspective, just doing a
+simple C<AUTOLOAD> which does nothing but extract the name of the
+method called and return it costs about 400% over a normal method
+call.
+
+=over 4
+
+=item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
+
+This wraps the specified method with the supplied subroutine
+reference. The modifier will be called as a method itself, and will
+receive the same arguments as are passed to the method.
+
+When the modifier exits, the wrapped method will be called.
+
+The return value of the modifier will be ignored.
+
+=item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
+
+This wraps the specified method with the supplied subroutine
+reference. The modifier will be called as a method itself, and will
+receive the same arguments as are passed to the method.
+
+When the wrapped methods exits, the modifier will be called.
+
+The return value of the modifier will be ignored.
+
+=item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
+
+This wraps the specified method with the supplied subroutine
+reference.
+
+The first argument passed to the modifier will be a subroutine
+reference to the wrapped method. The second argument is the object,
+and after that come any arguments passed when the method is called.
+
+The around modifier can choose to call the original method, as well as
+what arguments to pass if it does so.
+
+The return value of the modifier is what will be seen by the caller.
+
+=back
+
+=head2 Introspection
+
+=over 4
+
+=item B<< Class::MOP::Class->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+It should also be noted that L<Class::MOP> will actually bootstrap
+this module by installing a number of attribute meta-objects into its
+metaclass.
+
+=back
+
+=cut
--- /dev/null
+package Class::MOP::Class::Immutable::Trait;
+
+use strict;
+use warnings;
+
+use MRO::Compat;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+# the original class of the metaclass instance
+sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} }
+
+sub is_mutable { 0 }
+sub is_immutable { 1 }
+
+sub _immutable_metaclass { ref $_[1] }
+
+sub superclasses {
+ my $orig = shift;
+ my $self = shift;
+ confess "This method is read-only" if @_;
+ $self->$orig;
+}
+
+sub _immutable_cannot_call {
+ my $name = shift;
+ Carp::confess "The '$name' method cannot be called on an immutable instance";
+}
+
+for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) {
+ no strict 'refs';
+ *{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) };
+}
+
+sub class_precedence_list {
+ my $orig = shift;
+ my $self = shift;
+ @{ $self->{__immutable}{class_precedence_list}
+ ||= [ $self->$orig ] };
+}
+
+sub linearized_isa {
+ my $orig = shift;
+ my $self = shift;
+ @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] };
+}
+
+sub get_all_methods {
+ my $orig = shift;
+ my $self = shift;
+ @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] };
+}
+
+sub get_all_method_names {
+ my $orig = shift;
+ my $self = shift;
+ @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] };
+}
+
+sub get_all_attributes {
+ my $orig = shift;
+ my $self = shift;
+ @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] };
+}
+
+sub get_meta_instance {
+ my $orig = shift;
+ my $self = shift;
+ $self->{__immutable}{get_meta_instance} ||= $self->$orig;
+}
+
+sub _method_map {
+ my $orig = shift;
+ my $self = shift;
+ $self->{__immutable}{_method_map} ||= $self->$orig;
+}
+
+1;
+
+# ABSTRACT: Implements immutability for metaclass objects
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This class provides a pseudo-trait that is applied to immutable metaclass
+objects. In reality, it is simply a parent class.
+
+It implements caching and read-only-ness for various metaclass methods.
+
+=cut
+
--- /dev/null
+package Class::MOP::Deprecated;
+
+use strict;
+use warnings;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Package::DeprecationManager -deprecations => {
+ 'Class::MOP::HAVE_ISAREV' => '0.93',
+ 'Class::MOP::subname' => '0.93',
+ 'Class::MOP::in_global_destruction' => '0.93',
+
+ 'Class::MOP::Package::get_method_map' => '0.93',
+
+ 'Class::MOP::Class::construct_class_instance' => '0.93',
+ 'Class::MOP::Class::check_metaclass_compatibility' => '0.93',
+ 'Class::MOP::Class::create_meta_instance' => '0.93',
+ 'Class::MOP::Class::clone_instance' => '0.93',
+ 'Class::MOP::Class::alias_method' => '0.93',
+ 'Class::MOP::Class::compute_all_applicable_methods' => '0.93',
+ 'Class::MOP::Class::compute_all_applicable_attributes' => '0.93',
+ 'Class::MOP::Class::get_attribute_map' => '0.95',
+
+ 'Class::MOP::Instance::bless_instance_structure' => '0.93',
+
+ 'Class::MOP::Attribute::process_accessors' => '0.93',
+
+ 'Class::MOP::Method::Accessor::initialize_body' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_accessor_method' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_reader_method' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_writer_method' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_predicate_method' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_clearer_method' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_accessor_method_inline' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_reader_method_inline' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_writer_method_inline' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_clearer_method_inline' => '0.93',
+ 'Class::MOP::Method::Accessor::generate_predicate_method_inline' =>
+ '0.93',
+
+ 'Class::MOP::Method::Constructor::meta_instance' => '0.93',
+ 'Class::MOP::Method::Constructor::attributes' => '0.93',
+ 'Class::MOP::Method::Constructor::initialize_body' => '0.93',
+ 'Class::MOP::Method::Constructor::generate_constructor_method' => '0.93',
+ 'Class::MOP::Method::Constructor::generate_constructor_method_inline' =>
+ '0.93',
+};
+
+
+package
+ Class::MOP;
+
+sub HAVE_ISAREV () {
+ Class::MOP::Deprecated::deprecated(
+ "Class::MOP::HAVE_ISAREV is deprecated and will be removed in a future release. It has always returned 1 anyway."
+ );
+ return 1;
+}
+
+sub subname {
+ Class::MOP::Deprecated::deprecated(
+ "Class::MOP::subname is deprecated. Please use Sub::Name directly.");
+ require Sub::Name;
+ goto \&Sub::Name::subname;
+}
+
+sub in_global_destruction {
+ Class::MOP::Deprecated::deprecated(
+ "Class::MOP::in_global_destruction is deprecated. Please use Devel::GlobalDestruction directly."
+ );
+ require Devel::GlobalDestruction;
+ goto \&Devel::GlobalDestruction::in_global_destruction;
+}
+
+package
+ Class::MOP::Package;
+
+use Scalar::Util qw( blessed );
+
+sub get_method_map {
+ Class::MOP::Deprecated::deprecated(
+ 'The get_method_map method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ my $self = shift;
+
+ return { map { $_->name => $_ } $self->_get_local_methods };
+}
+
+package
+ Class::MOP::Module;
+
+package
+ Class::MOP::Class;
+
+sub construct_class_instance {
+ Class::MOP::Deprecated::deprecated(
+ 'The construct_class_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_construct_class_instance(@_);
+}
+
+sub check_metaclass_compatibility {
+ Class::MOP::Deprecated::deprecated(
+ 'The check_metaclass_compatibility method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_check_metaclass_compatibility(@_);
+}
+
+sub construct_instance {
+ Class::MOP::Deprecated::deprecated(
+ 'The construct_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_construct_instance(@_);
+}
+
+sub create_meta_instance {
+ Class::MOP::Deprecated::deprecated(
+ 'The create_meta_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_create_meta_instance(@_);
+}
+
+sub clone_instance {
+ Class::MOP::Deprecated::deprecated(
+ 'The clone_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_clone_instance(@_);
+}
+
+sub alias_method {
+ Class::MOP::Deprecated::deprecated(
+ "The alias_method method is deprecated. Use add_method instead.\n");
+
+ shift->add_method(@_);
+}
+
+sub compute_all_applicable_methods {
+ Class::MOP::Deprecated::deprecated(
+ 'The compute_all_applicable_methods method is deprecated.'
+ . " Use get_all_methods instead.\n" );
+
+ return map {
+ {
+ name => $_->name,
+ class => $_->package_name,
+ code => $_, # sigh, overloading
+ },
+ } shift->get_all_methods(@_);
+}
+
+sub compute_all_applicable_attributes {
+ Class::MOP::Deprecated::deprecated(
+ 'The compute_all_applicable_attributes method has been deprecated.'
+ . " Use get_all_attributes instead.\n" );
+
+ shift->get_all_attributes(@_);
+}
+
+sub get_attribute_map {
+ Class::MOP::Deprecated::deprecated(
+ "The get_attribute_map method has been deprecated.\n");
+
+ shift->_attribute_map(@_);
+}
+
+package
+ Class::MOP::Instance;
+
+sub bless_instance_structure {
+ Class::MOP::Deprecated::deprecated(
+ 'The bless_instance_structure method is deprecated.'
+ . " It will be removed in a future release.\n" );
+
+ my ( $self, $instance_structure ) = @_;
+ bless $instance_structure, $self->_class_name;
+}
+
+package
+ Class::MOP::Attribute;
+
+sub process_accessors {
+ Class::MOP::Deprecated::deprecated(
+ 'The process_accessors method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_process_accessors(@_);
+}
+
+package
+ Class::MOP::Method::Accessor;
+
+sub initialize_body {
+ Class::MOP::Deprecated::deprecated(
+ 'The initialize_body method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_initialize_body;
+}
+
+sub generate_accessor_method {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_accessor_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_accessor_method;
+}
+
+sub generate_reader_method {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_reader_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_reader_method;
+}
+
+sub generate_writer_method {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_writer_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_writer_method;
+}
+
+sub generate_predicate_method {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_predicate_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_predicate_method;
+}
+
+sub generate_clearer_method {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_clearer_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_clearer_method;
+}
+
+sub generate_accessor_method_inline {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_accessor_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_accessor_method_inline;
+}
+
+sub generate_reader_method_inline {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_reader_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_reader_method_inline;
+}
+
+sub generate_writer_method_inline {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_writer_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_writer_method_inline;
+}
+
+sub generate_predicate_method_inline {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_predicate_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_predicate_method_inline;
+}
+
+sub generate_clearer_method_inline {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_clearer_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_clearer_method_inline;
+}
+
+package
+ Class::MOP::Method::Constructor;
+
+sub meta_instance {
+ Class::MOP::Deprecated::deprecated(
+ 'The meta_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_meta_instance;
+}
+
+sub attributes {
+ Class::MOP::Deprecated::deprecated(
+ 'The attributes method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+
+ return shift->_attributes;
+}
+
+sub initialize_body {
+ Class::MOP::Deprecated::deprecated(
+ 'The initialize_body method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_initialize_body;
+}
+
+sub generate_constructor_method {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_constructor_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_constructor_method;
+}
+
+sub generate_constructor_method_inline {
+ Class::MOP::Deprecated::deprecated(
+ 'The generate_constructor_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n"
+ );
+ shift->_generate_constructor_method_inline;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Deprecated - Manages deprecation warnings for Class::MOP
+
+=head1 DESCRIPTION
+
+ use Class::MOP::Deprecated -api_version => $version;
+
+=head1 FUNCTIONS
+
+This module manages deprecation warnings for features that have been
+deprecated in Class::MOP.
+
+If you specify C<< -api_version => $version >>, you can use deprecated features
+without warnings. Note that this special treatment is limited to the package
+that loads C<Class::MOP::Deprecated>.
+
+=cut
--- /dev/null
+
+package Class::MOP::Instance;
+
+use strict;
+use warnings;
+
+use Scalar::Util 'weaken', 'blessed';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Object';
+
+# make this not a valid method name, to avoid (most) attribute conflicts
+my $RESERVED_MOP_SLOT = '<<MOP>>';
+
+sub BUILDARGS {
+ my ($class, @args) = @_;
+
+ if ( @args == 1 ) {
+ unshift @args, "associated_metaclass";
+ } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) {
+ # compat mode
+ my ( $meta, @attrs ) = @args;
+ @args = ( associated_metaclass => $meta, attributes => \@attrs );
+ }
+
+ my %options = @args;
+ # FIXME lazy_build
+ $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ];
+ $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build
+
+ return \%options;
+}
+
+sub new {
+ my $class = shift;
+ my $options = $class->BUILDARGS(@_);
+
+ # FIXME replace with a proper constructor
+ my $instance = $class->_new(%$options);
+
+ # FIXME weak_ref => 1,
+ weaken($instance->{'associated_metaclass'});
+
+ return $instance;
+}
+
+sub _new {
+ my $class = shift;
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $params = @_ == 1 ? $_[0] : {@_};
+ return bless {
+ # NOTE:
+ # I am not sure that it makes
+ # sense to pass in the meta
+ # The ideal would be to just
+ # pass in the class name, but
+ # that is placing too much of
+ # an assumption on bless(),
+ # which is *probably* a safe
+ # assumption,.. but you can
+ # never tell <:)
+ 'associated_metaclass' => $params->{associated_metaclass},
+ 'attributes' => $params->{attributes},
+ 'slots' => $params->{slots},
+ 'slot_hash' => $params->{slot_hash},
+ } => $class;
+}
+
+sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
+
+sub create_instance {
+ my $self = shift;
+ bless {}, $self->_class_name;
+}
+
+sub clone_instance {
+ my ($self, $instance) = @_;
+ bless { %$instance }, $self->_class_name;
+}
+
+# operations on meta instance
+
+sub get_all_slots {
+ my $self = shift;
+ return @{$self->{'slots'}};
+}
+
+sub get_all_attributes {
+ my $self = shift;
+ return @{$self->{attributes}};
+}
+
+sub is_valid_slot {
+ my ($self, $slot_name) = @_;
+ exists $self->{'slot_hash'}->{$slot_name};
+}
+
+# operations on created instances
+
+sub get_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ $instance->{$slot_name};
+}
+
+sub set_slot_value {
+ my ($self, $instance, $slot_name, $value) = @_;
+ $instance->{$slot_name} = $value;
+}
+
+sub initialize_slot {
+ my ($self, $instance, $slot_name) = @_;
+ return;
+}
+
+sub deinitialize_slot {
+ my ( $self, $instance, $slot_name ) = @_;
+ delete $instance->{$slot_name};
+}
+
+sub initialize_all_slots {
+ my ($self, $instance) = @_;
+ foreach my $slot_name ($self->get_all_slots) {
+ $self->initialize_slot($instance, $slot_name);
+ }
+}
+
+sub deinitialize_all_slots {
+ my ($self, $instance) = @_;
+ foreach my $slot_name ($self->get_all_slots) {
+ $self->deinitialize_slot($instance, $slot_name);
+ }
+}
+
+sub is_slot_initialized {
+ my ($self, $instance, $slot_name, $value) = @_;
+ exists $instance->{$slot_name};
+}
+
+sub weaken_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ weaken $instance->{$slot_name};
+}
+
+sub strengthen_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
+}
+
+sub rebless_instance_structure {
+ my ($self, $instance, $metaclass) = @_;
+
+ # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
+ bless $_[1], $metaclass->name;
+}
+
+sub is_dependent_on_superclasses {
+ return; # for meta instances that require updates on inherited slot changes
+}
+
+sub _get_mop_slot {
+ my ($self, $instance) = @_;
+ $self->get_slot_value($instance, $RESERVED_MOP_SLOT);
+}
+
+sub _set_mop_slot {
+ my ($self, $instance, $value) = @_;
+ $self->set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
+}
+
+sub _clear_mop_slot {
+ my ($self, $instance) = @_;
+ $self->deinitialize_slot($instance, $RESERVED_MOP_SLOT);
+}
+
+# inlinable operation snippets
+
+sub is_inlinable { 1 }
+
+sub inline_create_instance {
+ my ($self, $class_variable) = @_;
+ 'bless {} => ' . $class_variable;
+}
+
+sub inline_slot_access {
+ my ($self, $instance, $slot_name) = @_;
+ sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name);
+}
+
+sub inline_get_is_lvalue { 1 }
+
+sub inline_get_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ $self->inline_slot_access($instance, $slot_name);
+}
+
+sub inline_set_slot_value {
+ my ($self, $instance, $slot_name, $value) = @_;
+ $self->inline_slot_access($instance, $slot_name) . " = $value",
+}
+
+sub inline_initialize_slot {
+ my ($self, $instance, $slot_name) = @_;
+ return '';
+}
+
+sub inline_deinitialize_slot {
+ my ($self, $instance, $slot_name) = @_;
+ "delete " . $self->inline_slot_access($instance, $slot_name);
+}
+sub inline_is_slot_initialized {
+ my ($self, $instance, $slot_name) = @_;
+ "exists " . $self->inline_slot_access($instance, $slot_name);
+}
+
+sub inline_weaken_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
+}
+
+sub inline_strengthen_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
+}
+
+sub inline_rebless_instance_structure {
+ my ($self, $instance, $class_variable) = @_;
+ "bless $instance => $class_variable";
+}
+
+sub _inline_get_mop_slot {
+ my ($self, $instance) = @_;
+ $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT);
+}
+
+sub _inline_set_mop_slot {
+ my ($self, $instance, $value) = @_;
+ $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
+}
+
+sub _inline_clear_mop_slot {
+ my ($self, $instance) = @_;
+ $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT);
+}
+
+1;
+
+# ABSTRACT: Instance Meta Object
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+The Instance Protocol controls the creation of object instances, and
+the storage of attribute values in those instances.
+
+Using this API directly in your own code violates encapsulation, and
+we recommend that you use the appropriate APIs in L<Class::MOP::Class>
+and L<Class::MOP::Attribute> instead. Those APIs in turn call the
+methods in this class as appropriate.
+
+This class also participates in generating inlined code by providing
+snippets of code to access an object instance.
+
+=head1 METHODS
+
+=head2 Object construction
+
+=over 4
+
+=item B<< Class::MOP::Instance->new(%options) >>
+
+This method creates a new meta-instance object.
+
+It accepts the following keys in C<%options>:
+
+=over 8
+
+=item * associated_metaclass
+
+The L<Class::MOP::Class> object for which instances will be created.
+
+=item * attributes
+
+An array reference of L<Class::MOP::Attribute> objects. These are the
+attributes which can be stored in each instance.
+
+=back
+
+=back
+
+=head2 Creating and altering instances
+
+=over 4
+
+=item B<< $metainstance->create_instance >>
+
+This method returns a reference blessed into the associated
+metaclass's class.
+
+The default is to use a hash reference. Subclasses can override this.
+
+=item B<< $metainstance->clone_instance($instance) >>
+
+Given an instance, this method creates a new object by making
+I<shallow> clone of the original.
+
+=back
+
+=head2 Introspection
+
+=over 4
+
+=item B<< $metainstance->associated_metaclass >>
+
+This returns the L<Class::MOP::Class> object associated with the
+meta-instance object.
+
+=item B<< $metainstance->get_all_slots >>
+
+This returns a list of slot names stored in object instances. In
+almost all cases, slot names correspond directly attribute names.
+
+=item B<< $metainstance->is_valid_slot($slot_name) >>
+
+This will return true if C<$slot_name> is a valid slot name.
+
+=item B<< $metainstance->get_all_attributes >>
+
+This returns a list of attributes corresponding to the attributes
+passed to the constructor.
+
+=back
+
+=head2 Operations on Instance Structures
+
+It's important to understand that the meta-instance object is a
+different entity from the actual instances it creates. For this
+reason, any operations on the C<$instance_structure> always require
+that the object instance be passed to the method.
+
+=over 4
+
+=item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >>
+
+=item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >>
+
+=item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >>
+
+=item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >>
+
+=item B<< $metainstance->initialize_all_slots($instance_structure) >>
+
+=item B<< $metainstance->deinitialize_all_slots($instance_structure) >>
+
+=item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >>
+
+=item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >>
+
+=item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >>
+
+=item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >>
+
+The exact details of what each method does should be fairly obvious
+from the method name.
+
+=back
+
+=head2 Inlinable Instance Operations
+
+=over 4
+
+=item B<< $metainstance->is_inlinable >>
+
+This is a boolean that indicates whether or not slot access operations
+can be inlined. By default it is true, but subclasses can override
+this.
+
+=item B<< $metainstance->inline_create_instance($class_variable) >>
+
+This method expects a string that, I<when inlined>, will become a
+class name. This would literally be something like C<'$class'>, not an
+actual class name.
+
+It returns a snippet of code that creates a new object for the
+class. This is something like C< bless {}, $class_name >.
+
+=item B<< $metainstance->inline_get_is_lvalue >>
+
+Returns whether or not C<inline_get_slot_value> is a valid lvalue. This can be
+used to do extra optimizations when generating inlined methods.
+
+=item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >>
+
+=item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >>
+
+=item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >>
+
+=item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >>
+
+=item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >>
+
+=item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >>
+
+=item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >>
+
+=item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >>
+
+These methods all expect two arguments. The first is the name of a
+variable, than when inlined, will represent the object
+instance. Typically this will be a literal string like C<'$_[0]'>.
+
+The second argument is a slot name.
+
+The method returns a snippet of code that, when inlined, performs some
+operation on the instance.
+
+=item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >>
+
+This takes the name of a variable that will, when inlined, represent the object
+instance, and the name of a variable that will represent the class to rebless
+into, and returns code to rebless an instance into a class.
+
+=back
+
+=head2 Introspection
+
+=over 4
+
+=item B<< Class::MOP::Instance->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+It should also be noted that L<Class::MOP> will actually bootstrap
+this module by installing a number of attribute meta-objects into its
+metaclass.
+
+=back
+
+=cut
+
--- /dev/null
+
+package Class::MOP::Method;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'weaken', 'reftype', 'blessed';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Object';
+
+# NOTE:
+# if poked in the right way,
+# they should act like CODE refs.
+use overload '&{}' => sub { $_[0]->body }, fallback => 1;
+
+# construction
+
+sub wrap {
+ my ( $class, @args ) = @_;
+
+ unshift @args, 'body' if @args % 2 == 1;
+
+ my %params = @args;
+ my $code = $params{body};
+
+ if (blessed($code) && $code->isa(__PACKAGE__)) {
+ my $method = $code->clone;
+ delete $params{body};
+ Class::MOP::class_of($class)->rebless_instance($method, %params);
+ return $method;
+ }
+ elsif (!ref $code || 'CODE' ne reftype($code)) {
+ confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
+ }
+
+ ($params{package_name} && $params{name})
+ || confess "You must supply the package_name and name parameters";
+
+ my $self = $class->_new(\%params);
+
+ weaken($self->{associated_metaclass}) if $self->{associated_metaclass};
+
+ return $self;
+}
+
+sub _new {
+ my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $params = @_ == 1 ? $_[0] : {@_};
+
+ return bless {
+ 'body' => $params->{body},
+ 'associated_metaclass' => $params->{associated_metaclass},
+ 'package_name' => $params->{package_name},
+ 'name' => $params->{name},
+ 'original_method' => $params->{original_method},
+ } => $class;
+}
+
+## accessors
+
+sub associated_metaclass { shift->{'associated_metaclass'} }
+
+sub attach_to_class {
+ my ( $self, $class ) = @_;
+ $self->{associated_metaclass} = $class;
+ weaken($self->{associated_metaclass});
+}
+
+sub detach_from_class {
+ my $self = shift;
+ delete $self->{associated_metaclass};
+}
+
+sub fully_qualified_name {
+ my $self = shift;
+ $self->package_name . '::' . $self->name;
+}
+
+sub original_method { (shift)->{'original_method'} }
+
+sub _set_original_method { $_[0]->{'original_method'} = $_[1] }
+
+# It's possible that this could cause a loop if there is a circular
+# reference in here. That shouldn't ever happen in normal
+# circumstances, since original method only gets set when clone is
+# called. We _could_ check for such a loop, but it'd involve some sort
+# of package-lexical variable, and wouldn't be terribly subclassable.
+sub original_package_name {
+ my $self = shift;
+
+ $self->original_method
+ ? $self->original_method->original_package_name
+ : $self->package_name;
+}
+
+sub original_name {
+ my $self = shift;
+
+ $self->original_method
+ ? $self->original_method->original_name
+ : $self->name;
+}
+
+sub original_fully_qualified_name {
+ my $self = shift;
+
+ $self->original_method
+ ? $self->original_method->original_fully_qualified_name
+ : $self->fully_qualified_name;
+}
+
+sub execute {
+ my $self = shift;
+ $self->body->(@_);
+}
+
+# We used to go through use Class::MOP::Class->clone_instance to do this, but
+# this was awfully slow. This method may be called a number of times when
+# classes are loaded (especially during Moose role application), so it is
+# worth optimizing. - DR
+sub clone {
+ my $self = shift;
+
+ my $clone = bless { %{$self}, @_ }, blessed($self);
+
+ $clone->_set_original_method($self);
+
+ return $clone;
+}
+
+1;
+
+# ABSTRACT: Method Meta Object
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+The Method Protocol is very small, since methods in Perl 5 are just
+subroutines in a specific package. We provide a very basic
+introspection interface.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method->wrap($code, %options) >>
+
+This is the constructor. It accepts a method body in the form of
+either a code reference or a L<Class::MOP::Method> instance, followed
+by a hash of options.
+
+The options are:
+
+=over 8
+
+=item * name
+
+The method name (without a package name). This is required if C<$code>
+is a coderef.
+
+=item * package_name
+
+The package name for the method. This is required if C<$code> is a
+coderef.
+
+=item * associated_metaclass
+
+An optional L<Class::MOP::Class> object. This is the metaclass for the
+method's class.
+
+=back
+
+=item B<< $metamethod->clone(%params) >>
+
+This makes a shallow clone of the method object. In particular,
+subroutine reference itself is shared between all clones of a given
+method.
+
+When a method is cloned, the original method object will be available
+by calling C<original_method> on the clone.
+
+=item B<< $metamethod->body >>
+
+This returns a reference to the method's subroutine.
+
+=item B<< $metamethod->name >>
+
+This returns the method's name
+
+=item B<< $metamethod->package_name >>
+
+This returns the method's package name.
+
+=item B<< $metamethod->fully_qualified_name >>
+
+This returns the method's fully qualified name (package name and
+method name).
+
+=item B<< $metamethod->associated_metaclass >>
+
+This returns the L<Class::MOP::Class> object for the method, if one
+exists.
+
+=item B<< $metamethod->original_method >>
+
+If this method object was created as a clone of some other method
+object, this returns the object that was cloned.
+
+=item B<< $metamethod->original_name >>
+
+This returns the method's original name, wherever it was first
+defined.
+
+If this method is a clone of a clone (of a clone, etc.), this method
+returns the name from the I<first> method in the chain of clones.
+
+=item B<< $metamethod->original_package_name >>
+
+This returns the method's original package name, wherever it was first
+defined.
+
+If this method is a clone of a clone (of a clone, etc.), this method
+returns the package name from the I<first> method in the chain of
+clones.
+
+=item B<< $metamethod->original_fully_qualified_name >>
+
+This returns the method's original fully qualified name, wherever it
+was first defined.
+
+If this method is a clone of a clone (of a clone, etc.), this method
+returns the fully qualified name from the I<first> method in the chain
+of clones.
+
+=item B<< $metamethod->attach_to_class($metaclass) >>
+
+Given a L<Class::MOP::Class> object, this method sets the associated
+metaclass for the method. This will overwrite any existing associated
+metaclass.
+
+=item B<< $metamethod->detach_from_class >>
+
+Removes any associated metaclass object for the method.
+
+=item B<< $metamethod->execute(...) >>
+
+This executes the method. Any arguments provided will be passed on to
+the method itself.
+
+=item B<< Class::MOP::Method->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+It should also be noted that L<Class::MOP> will actually bootstrap
+this module by installing a number of attribute meta-objects into its
+metaclass.
+
+=back
+
+=cut
+
--- /dev/null
+
+package Class::MOP::Method::Accessor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method::Generated';
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+
+ (exists $options{attribute})
+ || confess "You must supply an attribute to construct with";
+
+ (exists $options{accessor_type})
+ || confess "You must supply an accessor_type to construct with";
+
+ (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
+ || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
+
+ ($options{package_name} && $options{name})
+ || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+
+ my $self = $class->_new(\%options);
+
+ # we don't want this creating
+ # a cycle in the code, if not
+ # needed
+ weaken($self->{'attribute'});
+
+ $self->_initialize_body;
+
+ return $self;
+}
+
+sub _new {
+ my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $params = @_ == 1 ? $_[0] : {@_};
+
+ return bless {
+ # inherited from Class::MOP::Method
+ body => $params->{body},
+ associated_metaclass => $params->{associated_metaclass},
+ package_name => $params->{package_name},
+ name => $params->{name},
+ original_method => $params->{original_method},
+
+ # inherit from Class::MOP::Generated
+ is_inline => $params->{is_inline} || 0,
+ definition_context => $params->{definition_context},
+
+ # defined in this class
+ attribute => $params->{attribute},
+ accessor_type => $params->{accessor_type},
+ } => $class;
+}
+
+## accessors
+
+sub associated_attribute { (shift)->{'attribute'} }
+sub accessor_type { (shift)->{'accessor_type'} }
+
+## factory
+
+sub _initialize_body {
+ my $self = shift;
+
+ my $method_name = join "_" => (
+ '_generate',
+ $self->accessor_type,
+ 'method',
+ ($self->is_inline ? 'inline' : ())
+ );
+
+ $self->{'body'} = $self->$method_name();
+}
+
+## generators
+
+sub _generate_accessor_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return sub {
+ if (@_ >= 2) {
+ $attr->set_value($_[0], $_[1]);
+ }
+ $attr->get_value($_[0]);
+ };
+}
+
+sub _generate_accessor_method_inline {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ 'if (@_ > 1) {',
+ $attr->_inline_set_value('$_[0]', '$_[1]'),
+ '}',
+ $attr->_inline_get_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline accessor because : $_";
+ };
+}
+
+sub _generate_reader_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return sub {
+ confess "Cannot assign a value to a read-only accessor"
+ if @_ > 1;
+ $attr->get_value($_[0]);
+ };
+}
+
+sub _generate_reader_method_inline {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ 'if (@_ > 1) {',
+ # XXX: this is a hack, but our error stuff is terrible
+ $self->_inline_throw_error(
+ '"Cannot assign a value to a read-only accessor"',
+ 'data => \@_'
+ ) . ';',
+ '}',
+ $attr->_inline_get_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline reader because : $_";
+ };
+}
+
+sub _inline_throw_error {
+ my $self = shift;
+ return 'confess ' . $_[0];
+}
+
+sub _generate_writer_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return sub {
+ $attr->set_value($_[0], $_[1]);
+ };
+}
+
+sub _generate_writer_method_inline {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ $attr->_inline_set_value('$_[0]', '$_[1]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline writer because : $_";
+ };
+}
+
+sub _generate_predicate_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return sub {
+ $attr->has_value($_[0])
+ };
+}
+
+sub _generate_predicate_method_inline {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ $attr->_inline_has_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline predicate because : $_";
+ };
+}
+
+sub _generate_clearer_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return sub {
+ $attr->clear_value($_[0])
+ };
+}
+
+sub _generate_clearer_method_inline {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ $attr->_inline_clear_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline clearer because : $_";
+ };
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for accessors
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+ use Class::MOP::Method::Accessor;
+
+ my $reader = Class::MOP::Method::Accessor->new(
+ attribute => $attribute,
+ is_inline => 1,
+ accessor_type => 'reader',
+ );
+
+ $reader->body->execute($instance); # call the reader method
+
+=head1 DESCRIPTION
+
+This is a subclass of C<Class::MOP::Method> which is used by
+C<Class::MOP::Attribute> to generate accessor code. It handles
+generation of readers, writers, predicates and clearers. For each type
+of method, it can either create a subroutine reference, or actually
+inline code by generating a string and C<eval>'ing it.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Accessor->new(%options) >>
+
+This returns a new C<Class::MOP::Method::Accessor> based on the
+C<%options> provided.
+
+=over 4
+
+=item * attribute
+
+This is the C<Class::MOP::Attribute> for which accessors are being
+generated. This option is required.
+
+=item * accessor_type
+
+This is a string which should be one of "reader", "writer",
+"accessor", "predicate", or "clearer". This is the type of method
+being generated. This option is required.
+
+=item * is_inline
+
+This indicates whether or not the accessor should be inlined. This
+defaults to false.
+
+=item * name
+
+The method name (without a package name). This is required.
+
+=item * package_name
+
+The package name for the method. This is required.
+
+=back
+
+=item B<< $metamethod->accessor_type >>
+
+Returns the accessor type which was passed to C<new>.
+
+=item B<< $metamethod->is_inline >>
+
+Returns a boolean indicating whether or not the accessor is inlined.
+
+=item B<< $metamethod->associated_attribute >>
+
+This returns the L<Class::MOP::Attribute> object which was passed to
+C<new>.
+
+=item B<< $metamethod->body >>
+
+The method itself is I<generated> when the accessor object is
+constructed.
+
+=back
+
+=cut
+
--- /dev/null
+
+package Class::MOP::Method::Constructor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method::Inlined';
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+
+ (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
+ || confess "You must pass a metaclass instance if you want to inline"
+ if $options{is_inline};
+
+ ($options{package_name} && $options{name})
+ || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+
+ my $self = $class->_new(\%options);
+
+ # we don't want this creating
+ # a cycle in the code, if not
+ # needed
+ weaken($self->{'associated_metaclass'});
+
+ $self->_initialize_body;
+
+ return $self;
+}
+
+sub _new {
+ my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $params = @_ == 1 ? $_[0] : {@_};
+
+ return bless {
+ # inherited from Class::MOP::Method
+ body => $params->{body},
+ # associated_metaclass => $params->{associated_metaclass}, # overriden
+ package_name => $params->{package_name},
+ name => $params->{name},
+ original_method => $params->{original_method},
+
+ # inherited from Class::MOP::Generated
+ is_inline => $params->{is_inline} || 0,
+ definition_context => $params->{definition_context},
+
+ # inherited from Class::MOP::Inlined
+ _expected_method_class => $params->{_expected_method_class},
+
+ # defined in this subclass
+ options => $params->{options} || {},
+ associated_metaclass => $params->{metaclass},
+ }, $class;
+}
+
+## accessors
+
+sub options { (shift)->{'options'} }
+sub associated_metaclass { (shift)->{'associated_metaclass'} }
+
+## cached values ...
+
+sub _attributes {
+ my $self = shift;
+ $self->{'attributes'} ||= [
+ sort { $a->name cmp $b->name }
+ $self->associated_metaclass->get_all_attributes
+ ]
+}
+
+## method
+
+sub _initialize_body {
+ my $self = shift;
+ my $method_name = '_generate_constructor_method';
+
+ $method_name .= '_inline' if $self->is_inline;
+
+ $self->{'body'} = $self->$method_name;
+}
+
+sub _eval_environment {
+ my $self = shift;
+ my $defaults = [map { $_->default } @{ $self->_attributes }];
+ return {
+ '$defaults' => \$defaults,
+ };
+}
+
+sub _generate_constructor_method {
+ return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
+}
+
+sub _generate_constructor_method_inline {
+ my $self = shift;
+
+ my $meta = $self->associated_metaclass;
+
+ my @source = (
+ 'sub {',
+ $meta->_inline_new_object,
+ '}',
+ );
+
+ warn join("\n", @source) if $self->options->{debug};
+
+ my $code = try {
+ $self->_compile_code(\@source);
+ }
+ catch {
+ my $source = join("\n", @source);
+ confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_";
+ };
+
+ return $code;
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for constructors
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+ use Class::MOP::Method::Constructor;
+
+ my $constructor = Class::MOP::Method::Constructor->new(
+ metaclass => $metaclass,
+ options => {
+ debug => 1, # this is all for now
+ },
+ );
+
+ # calling the constructor ...
+ $constructor->body->execute($metaclass->name, %params);
+
+=head1 DESCRIPTION
+
+This is a subclass of C<Class::MOP::Method> which generates
+constructor methods.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Constructor->new(%options) >>
+
+This creates a new constructor object. It accepts a hash reference of
+options.
+
+=over 8
+
+=item * metaclass
+
+This should be a L<Class::MOP::Class> object. It is required.
+
+=item * name
+
+The method name (without a package name). This is required.
+
+=item * package_name
+
+The package name for the method. This is required.
+
+=item * is_inline
+
+This indicates whether or not the constructor should be inlined. This
+defaults to false.
+
+=back
+
+=item B<< $metamethod->is_inline >>
+
+Returns a boolean indicating whether or not the constructor is
+inlined.
+
+=item B<< $metamethod->associated_metaclass >>
+
+This returns the L<Class::MOP::Class> object for the method.
+
+=back
+
+=cut
+
--- /dev/null
+
+package Class::MOP::Method::Generated;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Eval::Closure;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method';
+
+## accessors
+
+sub new {
+ confess __PACKAGE__ . " is an abstract base class, you must provide a constructor.";
+}
+
+sub _initialize_body {
+ confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class";
+}
+
+sub _generate_description {
+ my ( $self, $context ) = @_;
+ $context ||= $self->definition_context;
+
+ return "generated method (unknown origin)"
+ unless defined $context;
+
+ if (defined $context->{description}) {
+ return "$context->{description} "
+ . "(defined at $context->{file} line $context->{line})";
+ } else {
+ return "$context->{file} (line $context->{line})";
+ }
+}
+
+sub _compile_code {
+ my ( $self, @args ) = @_;
+ unshift @args, 'source' if @args % 2;
+ my %args = @args;
+
+ my $context = delete $args{context};
+ my $environment = $self->can('_eval_environment')
+ ? $self->_eval_environment
+ : {};
+
+ return eval_closure(
+ environment => $environment,
+ description => $self->_generate_description($context),
+ %args,
+ );
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method::Generated - Abstract base class for generated methods
+
+=head1 DESCRIPTION
+
+This is a C<Class::MOP::Method> subclass which is subclassed by
+C<Class::MOP::Method::Accessor> and
+C<Class::MOP::Method::Constructor>.
+
+It is not intended to be used directly.
+
+=cut
+
--- /dev/null
+package Class::MOP::Method::Inlined;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method::Generated';
+
+sub _uninlined_body {
+ my $self = shift;
+
+ my $super_method
+ = $self->associated_metaclass->find_next_method_by_name( $self->name )
+ or return;
+
+ if ( $super_method->isa(__PACKAGE__) ) {
+ return $super_method->_uninlined_body;
+ }
+ else {
+ return $super_method->body;
+ }
+}
+
+sub can_be_inlined {
+ my $self = shift;
+ my $metaclass = $self->associated_metaclass;
+ my $class = $metaclass->name;
+
+ # If we don't find an inherited method, this is a rather weird
+ # case where we have no method in the inheritance chain even
+ # though we're expecting one to be there
+ my $inherited_method
+ = $metaclass->find_next_method_by_name( $self->name );
+
+ if ( $inherited_method
+ && $inherited_method->isa('Class::MOP::Method::Wrapped') ) {
+ warn "Not inlining '"
+ . $self->name
+ . "' for $class since it "
+ . "has method modifiers which would be lost if it were inlined\n";
+
+ return 0;
+ }
+
+ my $expected_class = $self->_expected_method_class
+ or return 1;
+
+ # if we are shadowing a method we first verify that it is
+ # compatible with the definition we are replacing it with
+ my $expected_method = $expected_class->can( $self->name );
+
+ if ( ! $expected_method ) {
+ warn "Not inlining '"
+ . $self->name
+ . "' for $class since ${expected_class}::"
+ . $self->name
+ . " is not defined\n";
+
+ return 0;
+ }
+
+ my $actual_method = $class->can( $self->name )
+ or return 1;
+
+ # the method is what we wanted (probably Moose::Object::new)
+ return 1
+ if refaddr($expected_method) == refaddr($actual_method);
+
+ # otherwise we have to check that the actual method is an inlined
+ # version of what we're expecting
+ if ( $inherited_method->isa(__PACKAGE__) ) {
+ if ( $inherited_method->_uninlined_body
+ && refaddr( $inherited_method->_uninlined_body )
+ == refaddr($expected_method) ) {
+ return 1;
+ }
+ }
+ elsif ( refaddr( $inherited_method->body )
+ == refaddr($expected_method) ) {
+ return 1;
+ }
+
+ my $warning
+ = "Not inlining '"
+ . $self->name
+ . "' for $class since it is not"
+ . " inheriting the default ${expected_class}::"
+ . $self->name . "\n";
+
+ if ( $self->isa("Class::MOP::Method::Constructor") ) {
+
+ # FIXME kludge, refactor warning generation to a method
+ $warning
+ .= "If you are certain you don't need to inline your"
+ . " constructor, specify inline_constructor => 0 in your"
+ . " call to $class->meta->make_immutable\n";
+ }
+
+ warn $warning;
+
+ return 0;
+}
+
+1;
+
+# ABSTRACT: Method base class for methods which have been inlined
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This is a L<Class::MOP::Method::Generated> subclass for methods which
+can be inlined.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< $metamethod->can_be_inlined >>
+
+This method returns true if the method in question can be inlined in
+the associated metaclass.
+
+If it cannot be inlined, it spits out a warning and returns false.
+
+=back
+
+=cut
+
--- /dev/null
+
+package Class::MOP::Method::Meta;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0;
+
+use base 'Class::MOP::Method';
+
+sub _is_caller_mop_internal {
+ my $self = shift;
+ my ($caller) = @_;
+ return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/;
+}
+
+sub _generate_meta_method {
+ my $method_self = shift;
+ my $metaclass = shift;
+ sub {
+ # this will be compiled out if the env var wasn't set
+ if (DEBUG_NO_META) {
+ confess "'meta' method called by MOP internals"
+ # it's okay to call meta methods on metaclasses, since we
+ # explicitly ask for them
+ if !$_[0]->isa('Class::MOP::Object')
+ && !$_[0]->isa('Class::MOP::Mixin')
+ # it's okay if the test itself calls ->meta, we only care about
+ # if the mop internals call ->meta
+ && $method_self->_is_caller_mop_internal(scalar caller);
+ }
+ # we must re-initialize so that it
+ # works as expected in subclasses,
+ # since metaclass instances are
+ # singletons, this is not really a
+ # big deal anyway.
+ $metaclass->initialize(blessed($_[0]) || $_[0])
+ };
+}
+
+sub wrap {
+ my ($class, @args) = @_;
+
+ unshift @args, 'body' if @args % 2 == 1;
+ my %params = @args;
+ confess "Overriding the body of meta methods is not allowed"
+ if $params{body};
+
+ my $metaclass_class = $params{associated_metaclass}->meta;
+ $params{body} = $class->_generate_meta_method($metaclass_class);
+ return $class->SUPER::wrap(%params);
+}
+
+sub _make_compatible_with {
+ my $self = shift;
+ my ($other) = @_;
+
+ # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta
+ # objects are subclasses of CMOP::Method, but when we get to moose, they'll
+ # need to be compatible with Moose::Meta::Method, which isn't possible. the
+ # right solution here is to make ::Meta into a role that gets applied to
+ # whatever the method_metaclass happens to be and get rid of
+ # _meta_method_metaclass entirely, but that's not going to happen until
+ # we ditch cmop and get roles into the bootstrapping, so. i'm not
+ # maintaining the previous behavior of turning them into instances of the
+ # new method_metaclass because that's equally broken, and at least this way
+ # any issues will at least be detectable and potentially fixable. -doy
+ return $self unless $other->_is_compatible_with($self->_real_ref_name);
+
+ return $self->SUPER::_make_compatible_with(@_);
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for C<meta> methods
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This is a L<Class::MOP::Method> subclass which represents C<meta>
+methods installed into classes by Class::MOP.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
+
+This is the constructor. It accepts a L<Class::MOP::Method> object and
+a hash of options. The options accepted are identical to the ones
+accepted by L<Class::MOP::Method>, except that C<body> cannot be passed
+(it will be generated automatically).
+
+=back
+
+=cut
+
--- /dev/null
+
+package Class::MOP::Method::Wrapped;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method';
+
+# NOTE:
+# this ugly beast is the result of trying
+# to micro optimize this as much as possible
+# while not completely loosing maintainability.
+# At this point it's "fast enough", after all
+# you can't get something for nothing :)
+my $_build_wrapped_method = sub {
+ my $modifier_table = shift;
+ my ($before, $after, $around) = (
+ $modifier_table->{before},
+ $modifier_table->{after},
+ $modifier_table->{around},
+ );
+ if (@$before && @$after) {
+ $modifier_table->{cache} = sub {
+ for my $c (@$before) { $c->(@_) };
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ for my $c (@$after) { $c->(@_) };
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ elsif (@$before && !@$after) {
+ $modifier_table->{cache} = sub {
+ for my $c (@$before) { $c->(@_) };
+ return $around->{cache}->(@_);
+ }
+ }
+ elsif (@$after && !@$before) {
+ $modifier_table->{cache} = sub {
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ for my $c (@$after) { $c->(@_) };
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ else {
+ $modifier_table->{cache} = $around->{cache};
+ }
+};
+
+sub wrap {
+ my ( $class, $code, %params ) = @_;
+
+ (blessed($code) && $code->isa('Class::MOP::Method'))
+ || confess "Can only wrap blessed CODE";
+
+ my $modifier_table = {
+ cache => undef,
+ orig => $code,
+ before => [],
+ after => [],
+ around => {
+ cache => $code->body,
+ methods => [],
+ },
+ };
+ $_build_wrapped_method->($modifier_table);
+ return $class->SUPER::wrap(
+ sub { $modifier_table->{cache}->(@_) },
+ # get these from the original
+ # unless explicitly overriden
+ package_name => $params{package_name} || $code->package_name,
+ name => $params{name} || $code->name,
+
+ modifier_table => $modifier_table,
+ );
+}
+
+sub _new {
+ my $class = shift;
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $params = @_ == 1 ? $_[0] : {@_};
+
+ return bless {
+ # inherited from Class::MOP::Method
+ 'body' => $params->{body},
+ 'associated_metaclass' => $params->{associated_metaclass},
+ 'package_name' => $params->{package_name},
+ 'name' => $params->{name},
+ 'original_method' => $params->{original_method},
+
+ # defined in this class
+ 'modifier_table' => $params->{modifier_table}
+ } => $class;
+}
+
+sub get_original_method {
+ my $code = shift;
+ $code->{'modifier_table'}->{orig};
+}
+
+sub add_before_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ unshift @{$code->{'modifier_table'}->{before}} => $modifier;
+ $_build_wrapped_method->($code->{'modifier_table'});
+}
+
+sub before_modifiers {
+ my $code = shift;
+ return @{$code->{'modifier_table'}->{before}};
+}
+
+sub add_after_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ push @{$code->{'modifier_table'}->{after}} => $modifier;
+ $_build_wrapped_method->($code->{'modifier_table'});
+}
+
+sub after_modifiers {
+ my $code = shift;
+ return @{$code->{'modifier_table'}->{after}};
+}
+
+{
+ # NOTE:
+ # this is another possible candidate for
+ # optimization as well. There is an overhead
+ # associated with the currying that, if
+ # eliminated might make around modifiers
+ # more manageable.
+ my $compile_around_method = sub {{
+ my $f1 = pop;
+ return $f1 unless @_;
+ my $f2 = pop;
+ push @_, sub { $f2->( $f1, @_ ) };
+ redo;
+ }};
+
+ sub add_around_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
+ $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
+ @{$code->{'modifier_table'}->{around}->{methods}},
+ $code->{'modifier_table'}->{orig}->body
+ );
+ $_build_wrapped_method->($code->{'modifier_table'});
+ }
+}
+
+sub around_modifiers {
+ my $code = shift;
+ return @{$code->{'modifier_table'}->{around}->{methods}};
+}
+
+sub _make_compatible_with {
+ my $self = shift;
+ my ($other) = @_;
+
+ # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped
+ # objects are subclasses of CMOP::Method, but when we get to moose, they'll
+ # need to be compatible with Moose::Meta::Method, which isn't possible. the
+ # right solution here is to make ::Wrapped into a role that gets applied to
+ # whatever the method_metaclass happens to be and get rid of
+ # wrapped_method_metaclass entirely, but that's not going to happen until
+ # we ditch cmop and get roles into the bootstrapping, so. i'm not
+ # maintaining the previous behavior of turning them into instances of the
+ # new method_metaclass because that's equally broken, and at least this way
+ # any issues will at least be detectable and potentially fixable. -doy
+ return $self unless $other->_is_compatible_with($self->_real_ref_name);
+
+ return $self->SUPER::_make_compatible_with(@_);
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for methods with before/after/around modifiers
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This is a L<Class::MOP::Method> subclass which implements before,
+after, and around method modifiers.
+
+=head1 METHODS
+
+=head2 Construction
+
+=over 4
+
+=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
+
+This is the constructor. It accepts a L<Class::MOP::Method> object and
+a hash of options.
+
+The options are:
+
+=over 8
+
+=item * name
+
+The method name (without a package name). This will be taken from the
+provided L<Class::MOP::Method> object if it is not provided.
+
+=item * package_name
+
+The package name for the method. This will be taken from the provided
+L<Class::MOP::Method> object if it is not provided.
+
+=item * associated_metaclass
+
+An optional L<Class::MOP::Class> object. This is the metaclass for the
+method's class.
+
+=back
+
+=item B<< $metamethod->get_original_method >>
+
+This returns the L<Class::MOP::Method> object that was passed to the
+constructor.
+
+=item B<< $metamethod->add_before_modifier($code) >>
+
+=item B<< $metamethod->add_after_modifier($code) >>
+
+=item B<< $metamethod->add_around_modifier($code) >>
+
+These methods all take a subroutine reference and apply it as a
+modifier to the original method.
+
+=item B<< $metamethod->before_modifiers >>
+
+=item B<< $metamethod->after_modifiers >>
+
+=item B<< $metamethod->around_modifiers >>
+
+These methods all return a list of subroutine references which are
+acting as the specified type of modifier.
+
+=back
+
+=cut
+
--- /dev/null
+package Class::MOP::MiniTrait;
+
+use strict;
+use warnings;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub apply {
+ my ( $to_class, $trait ) = @_;
+
+ for ( grep { !ref } $to_class, $trait ) {
+ Class::MOP::load_class($_);
+ $_ = Class::MOP::Class->initialize($_);
+ }
+
+ for my $meth ( $trait->get_all_methods ) {
+ my $meth_name = $meth->name;
+
+ if ( $to_class->find_method_by_name($meth_name) ) {
+ $to_class->add_around_method_modifier( $meth_name, $meth->body );
+ }
+ else {
+ $to_class->add_method( $meth_name, $meth->clone );
+ }
+ }
+}
+
+# We can't load this with use, since it may be loaded and used from Class::MOP
+# (via CMOP::Class, etc). However, if for some reason this module is loaded
+# _without_ first loading Class::MOP we need to require Class::MOP so we can
+# use it and CMOP::Class.
+require Class::MOP;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::MiniTrait - Extremely limited trait application
+
+=head1 DESCRIPTION
+
+This package provides a single function, C<apply>, which does a half-assed job
+of applying a trait to a class. It exists solely for use inside Class::MOP and
+L<Moose> core classes.
+
+=cut
+
--- /dev/null
+package Class::MOP::Mixin;
+
+use strict;
+use warnings;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Scalar::Util 'blessed';
+
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize( blessed( $_[0] ) || $_[0] );
+}
+
+1;
+
+# ABSTRACT: Base class for mixin classes
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This class provides a single method shared by all mixins
+
+=head1 METHODS
+
+This class provides a few methods which are useful in all metaclasses.
+
+=over 4
+
+=item B<< Class::MOP::Mixin->meta >>
+
+This returns a L<Class::MOP::Class> object for the mixin class.
+
+=back
+
+=cut
--- /dev/null
+package Class::MOP::Mixin::AttributeCore;
+
+use strict;
+use warnings;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Scalar::Util 'blessed';
+
+use base 'Class::MOP::Mixin';
+
+sub has_accessor { defined $_[0]->{'accessor'} }
+sub has_reader { defined $_[0]->{'reader'} }
+sub has_writer { defined $_[0]->{'writer'} }
+sub has_predicate { defined $_[0]->{'predicate'} }
+sub has_clearer { defined $_[0]->{'clearer'} }
+sub has_builder { defined $_[0]->{'builder'} }
+sub has_init_arg { defined $_[0]->{'init_arg'} }
+sub has_default { exists $_[0]->{'default'} }
+sub has_initializer { defined $_[0]->{'initializer'} }
+sub has_insertion_order { defined $_[0]->{'insertion_order'} }
+
+sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] }
+
+sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
+sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
+
+sub is_default_a_coderef {
+ # Uber hack because it is called from CMOP::Attribute constructor as
+ # $class->is_default_a_coderef(\%options)
+ my ($value) = ref $_[0] ? $_[0]->{'default'} : $_[1]->{'default'};
+
+ return unless ref($value);
+
+ return ref($value) eq 'CODE'
+ || ( blessed($value) && $value->isa('Class::MOP::Method') );
+}
+
+sub default {
+ my ( $self, $instance ) = @_;
+ if ( defined $instance && $self->is_default_a_coderef ) {
+ # if the default is a CODE ref, then we pass in the instance and
+ # default can return a value based on that instance. Somewhat crude,
+ # but works.
+ return $self->{'default'}->($instance);
+ }
+ $self->{'default'};
+}
+
+1;
+
+# ABSTRACT: Core attributes shared by attribute metaclasses
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This class implements the core attributes (aka properties) shared by all
+attributes. See the L<Class::MOP::Attribute> documentation for API details.
+
+=cut
--- /dev/null
+package Class::MOP::Mixin::HasAttributes;
+
+use strict;
+use warnings;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+use base 'Class::MOP::Mixin';
+
+sub add_attribute {
+ my $self = shift;
+
+ my $attribute
+ = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
+
+ ( $attribute->isa('Class::MOP::Mixin::AttributeCore') )
+ || confess
+ "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)";
+
+ $self->_attach_attribute($attribute);
+
+ my $attr_name = $attribute->name;
+
+ $self->remove_attribute($attr_name)
+ if $self->has_attribute($attr_name);
+
+ my $order = ( scalar keys %{ $self->_attribute_map } );
+ $attribute->_set_insertion_order($order);
+
+ $self->_attribute_map->{$attr_name} = $attribute;
+
+ # This method is called to allow for installing accessors. Ideally, we'd
+ # use method overriding, but then the subclass would be responsible for
+ # making the attribute, which would end up with lots of code
+ # duplication. Even more ideally, we'd use augment/inner, but this is
+ # Class::MOP!
+ $self->_post_add_attribute($attribute)
+ if $self->can('_post_add_attribute');
+
+ return $attribute;
+}
+
+sub has_attribute {
+ my ( $self, $attribute_name ) = @_;
+
+ ( defined $attribute_name )
+ || confess "You must define an attribute name";
+
+ exists $self->_attribute_map->{$attribute_name};
+}
+
+sub get_attribute {
+ my ( $self, $attribute_name ) = @_;
+
+ ( defined $attribute_name )
+ || confess "You must define an attribute name";
+
+ return $self->_attribute_map->{$attribute_name};
+}
+
+sub remove_attribute {
+ my ( $self, $attribute_name ) = @_;
+
+ ( defined $attribute_name )
+ || confess "You must define an attribute name";
+
+ my $removed_attribute = $self->_attribute_map->{$attribute_name};
+ return unless defined $removed_attribute;
+
+ delete $self->_attribute_map->{$attribute_name};
+
+ return $removed_attribute;
+}
+
+sub get_attribute_list {
+ my $self = shift;
+ keys %{ $self->_attribute_map };
+}
+
+sub _restore_metaattributes_from {
+ my $self = shift;
+ my ($old_meta) = @_;
+
+ for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
+ map { $old_meta->get_attribute($_) }
+ $old_meta->get_attribute_list) {
+ $attr->_make_compatible_with($self->attribute_metaclass);
+ $self->add_attribute($attr);
+ }
+}
+
+1;
+
+# ABSTRACT: Methods for metaclasses which have attributes
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This class implements methods for metaclasses which have attributes
+(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
+API details.
+
+=cut
--- /dev/null
+package Class::MOP::Mixin::HasMethods;
+
+use strict;
+use warnings;
+
+use Class::MOP::Method::Meta;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Scalar::Util 'blessed';
+use Carp 'confess';
+use Sub::Name 'subname';
+
+use base 'Class::MOP::Mixin';
+
+sub _meta_method_class { 'Class::MOP::Method::Meta' }
+
+sub _add_meta_method {
+ my $self = shift;
+ my ($name) = @_;
+ my $existing_method = $self->can('find_method_by_name')
+ ? $self->find_method_by_name($name)
+ : $self->get_method($name);
+ return if $existing_method
+ && $existing_method->isa($self->_meta_method_class);
+ $self->add_method(
+ $name => $self->_meta_method_class->wrap(
+ name => $name,
+ package_name => $self->name,
+ associated_metaclass => $self,
+ )
+ );
+}
+
+sub wrap_method_body {
+ my ( $self, %args ) = @_;
+
+ ( 'CODE' eq ref $args{body} )
+ || confess "Your code block must be a CODE reference";
+
+ $self->method_metaclass->wrap(
+ package_name => $self->name,
+ %args,
+ );
+}
+
+sub add_method {
+ my ( $self, $method_name, $method ) = @_;
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ my $package_name = $self->name;
+
+ my $body;
+ if ( blessed($method) ) {
+ $body = $method->body;
+ if ( $method->package_name ne $package_name ) {
+ $method = $method->clone(
+ package_name => $package_name,
+ name => $method_name,
+ );
+ }
+
+ $method->attach_to_class($self);
+ }
+ else {
+ # If a raw code reference is supplied, its method object is not created.
+ # The method object won't be created until required.
+ $body = $method;
+ }
+
+ $self->_method_map->{$method_name} = $method;
+
+ my ($current_package, $current_name) = Class::MOP::get_code_info($body);
+
+ subname($package_name . '::' . $method_name, $body)
+ unless defined $current_name && $current_name !~ /^__ANON__/;
+
+ $self->add_package_symbol("&$method_name", $body);
+
+ # we added the method to the method map too, so it's still valid
+ $self->update_package_cache_flag;
+}
+
+sub _code_is_mine {
+ my ( $self, $code ) = @_;
+
+ my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
+
+ return ( $code_package && $code_package eq $self->name )
+ || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
+}
+
+sub has_method {
+ my ( $self, $method_name ) = @_;
+
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ my $method = $self->_get_maybe_raw_method($method_name)
+ or return;
+
+ return defined($self->_method_map->{$method_name} = $method);
+}
+
+sub get_method {
+ my ( $self, $method_name ) = @_;
+
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ my $method = $self->_get_maybe_raw_method($method_name)
+ or return;
+
+ return $method if blessed $method;
+
+ return $self->_method_map->{$method_name} = $self->wrap_method_body(
+ body => $method,
+ name => $method_name,
+ associated_metaclass => $self,
+ );
+}
+
+sub _get_maybe_raw_method {
+ my ( $self, $method_name ) = @_;
+
+ my $map_entry = $self->_method_map->{$method_name};
+ return $map_entry if defined $map_entry;
+
+ my $code = $self->get_package_symbol("&$method_name");
+
+ return unless $code && $self->_code_is_mine($code);
+
+ return $code;
+}
+
+sub remove_method {
+ my ( $self, $method_name ) = @_;
+
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ my $removed_method = delete $self->_method_map->{$method_name};
+
+ $self->remove_package_symbol("&$method_name");
+
+ $removed_method->detach_from_class
+ if blessed($removed_method);
+
+ # still valid, since we just removed the method from the map
+ $self->update_package_cache_flag;
+
+ return $removed_method;
+}
+
+sub get_method_list {
+ my $self = shift;
+
+ return keys %{ $self->_full_method_map };
+}
+
+sub _get_local_methods {
+ my $self = shift;
+
+ return values %{ $self->_full_method_map };
+}
+
+sub _restore_metamethods_from {
+ my $self = shift;
+ my ($old_meta) = @_;
+
+ for my $method ($old_meta->_get_local_methods) {
+ $method->_make_compatible_with($self->method_metaclass);
+ $self->add_method($method->name => $method);
+ }
+}
+
+sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
+sub update_package_cache_flag {
+ my $self = shift;
+ # NOTE:
+ # we can manually update the cache number
+ # since we are actually adding the method
+ # to our cache as well. This avoids us
+ # having to regenerate the method_map.
+ # - SL
+ $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
+}
+
+sub _full_method_map {
+ my $self = shift;
+
+ my $pkg_gen = Class::MOP::check_package_cache_flag($self->name);
+
+ if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) {
+ # forcibly reify all method map entries
+ $self->get_method($_)
+ for $self->list_all_package_symbols('CODE');
+ $self->{_package_cache_flag_full} = $pkg_gen;
+ }
+
+ return $self->_method_map;
+}
+
+1;
+
+# ABSTRACT: Methods for metaclasses which have methods
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This class implements methods for metaclasses which have methods
+(L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
+for API details.
+
+=cut
--- /dev/null
+
+package Class::MOP::Module;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Package';
+
+sub _new {
+ my $class = shift;
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $params = @_ == 1 ? $_[0] : {@_};
+ return bless {
+
+ # from Class::MOP::Package
+ package => $params->{package},
+ namespace => \undef,
+
+ # attributes
+ version => \undef,
+ authority => \undef
+ } => $class;
+}
+
+sub version {
+ my $self = shift;
+ ${$self->get_or_add_package_symbol('$VERSION')};
+}
+
+sub authority {
+ my $self = shift;
+ ${$self->get_or_add_package_symbol('$AUTHORITY')};
+}
+
+sub identifier {
+ my $self = shift;
+ join '-' => (
+ $self->name,
+ ($self->version || ()),
+ ($self->authority || ()),
+ );
+}
+
+sub create {
+ confess "The Class::MOP::Module->create method has been made a private object method.\n";
+}
+
+sub _instantiate_module {
+ my($self, $version, $authority) = @_;
+ my $package_name = $self->name;
+
+ Class::MOP::_is_valid_class_name($package_name)
+ || confess "creation of $package_name failed: invalid package name";
+
+ no strict 'refs';
+ scalar %{ $package_name . '::' }; # touch the stash
+ ${ $package_name . '::VERSION' } = $version if defined $version;
+ ${ $package_name . '::AUTHORITY' } = $authority if defined $authority;
+
+ return;
+}
+
+1;
+
+# ABSTRACT: Module Meta Object
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Module - Module Meta Object
+
+=head1 DESCRIPTION
+
+A module is essentially a L<Class::MOP::Package> with metadata, in our
+case the version and authority.
+
+=head1 INHERITANCE
+
+B<Class::MOP::Module> is a subclass of L<Class::MOP::Package>.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< $metamodule->version >>
+
+This is a read-only attribute which returns the C<$VERSION> of the
+package, if one exists.
+
+=item B<< $metamodule->authority >>
+
+This is a read-only attribute which returns the C<$AUTHORITY> of the
+package, if one exists.
+
+=item B<< $metamodule->identifier >>
+
+This constructs a string which combines the name, version and
+authority.
+
+=item B<< Class::MOP::Module->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+=back
+
+=cut
--- /dev/null
+
+package Class::MOP::Object;
+
+use strict;
+use warnings;
+
+use Carp qw(confess);
+use Scalar::Util 'blessed';
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+# introspection
+
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
+}
+
+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);
+
+ confess "Can't make $self compatible with metaclass $other_name"
+ unless defined $new_metaclass;
+
+ # 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;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Object - Base class for metaclasses
+
+=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.
+
+=over 4
+
+=item B<< Class::MOP::???->meta >>
+
+This returns a L<Class::MOP::Class> object.
+
+=item B<< $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.
+
+=back
+
+=cut
--- /dev/null
+
+package Class::MOP::Package;
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed', 'reftype';
+use Carp 'confess';
+use Package::Stash;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Object';
+
+# creation ...
+
+sub initialize {
+ my ( $class, @args ) = @_;
+
+ unshift @args, "package" if @args % 2;
+
+ my %options = @args;
+ my $package_name = $options{package};
+
+
+ # we hand-construct the class
+ # until we can bootstrap it
+ if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
+ return $meta;
+ } else {
+ my $meta = ( ref $class || $class )->_new({
+ 'package' => $package_name,
+ %options,
+ });
+ Class::MOP::store_metaclass_by_name($package_name, $meta);
+
+ return $meta;
+ }
+}
+
+sub reinitialize {
+ my ( $class, @args ) = @_;
+
+ unshift @args, "package" if @args % 2;
+
+ my %options = @args;
+ my $package_name = delete $options{package};
+
+ (defined $package_name && $package_name
+ && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
+ || confess "You must pass a package name or an existing Class::MOP::Package instance";
+
+ $package_name = $package_name->name
+ if blessed $package_name;
+
+ Class::MOP::remove_metaclass_by_name($package_name);
+
+ $class->initialize($package_name, %options); # call with first arg form for compat
+}
+
+sub _new {
+ my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
+ my $params = @_ == 1 ? $_[0] : {@_};
+
+ return bless {
+ package => $params->{package},
+
+ # NOTE:
+ # because of issues with the Perl API
+ # to the typeglob in some versions, we
+ # need to just always grab a new
+ # reference to the hash in the accessor.
+ # Ideally we could just store a ref and
+ # it would Just Work, but oh well :\
+
+ namespace => \undef,
+
+ } => $class;
+}
+
+# Attributes
+
+# NOTE:
+# all these attribute readers will be bootstrapped
+# away in the Class::MOP bootstrap section
+
+sub _package_stash {
+ $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
+}
+sub namespace {
+ $_[0]->_package_stash->namespace
+}
+
+# Class attributes
+
+# ... these functions have to touch the symbol table itself,.. yuk
+
+sub add_package_symbol {
+ my $self = shift;
+ $self->_package_stash->add_symbol(@_);
+}
+
+sub remove_package_glob {
+ my $self = shift;
+ $self->_package_stash->remove_glob(@_);
+}
+
+# ... these functions deal with stuff on the namespace level
+
+sub has_package_symbol {
+ my $self = shift;
+ $self->_package_stash->has_symbol(@_);
+}
+
+sub get_package_symbol {
+ my $self = shift;
+ $self->_package_stash->get_symbol(@_);
+}
+
+sub get_or_add_package_symbol {
+ my $self = shift;
+ $self->_package_stash->get_or_add_symbol(@_);
+}
+
+sub remove_package_symbol {
+ my $self = shift;
+ $self->_package_stash->remove_symbol(@_);
+}
+
+sub list_all_package_symbols {
+ my $self = shift;
+ $self->_package_stash->list_all_symbols(@_);
+}
+
+sub get_all_package_symbols {
+ my $self = shift;
+ $self->_package_stash->get_all_symbols(@_);
+}
+
+1;
+
+# ABSTRACT: Package Meta Object
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+The Package Protocol provides an abstraction of a Perl 5 package. A
+package is basically namespace, and this module provides methods for
+looking at and changing that namespace's symbol table.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Package->initialize($package_name) >>
+
+This method creates a new C<Class::MOP::Package> instance which
+represents specified package. If an existing metaclass object exists
+for the package, that will be returned instead.
+
+=item B<< Class::MOP::Package->reinitialize($package) >>
+
+This method forcibly removes any existing metaclass for the package
+before calling C<initialize>. In contrast to C<initialize>, you may
+also pass an existing C<Class::MOP::Package> instance instead of just
+a package name as C<$package>.
+
+Do not call this unless you know what you are doing.
+
+=item B<< $metapackage->name >>
+
+This is returns the package's name, as passed to the constructor.
+
+=item B<< $metapackage->namespace >>
+
+This returns a hash reference to the package's symbol table. The keys
+are symbol names and the values are typeglob references.
+
+=item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
+
+This method accepts a variable name and an optional initial value. The
+C<$variable_name> must contain a leading sigil.
+
+This method creates the variable in the package's symbol table, and
+sets it to the initial value if one was provided.
+
+=item B<< $metapackage->get_package_symbol($variable_name) >>
+
+Given a variable name, this method returns the variable as a reference
+or undef if it does not exist. The C<$variable_name> must contain a
+leading sigil.
+
+=item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
+
+Given a variable name, this method returns the variable as a reference.
+If it does not exist, a default value will be generated if possible. The
+C<$variable_name> must contain a leading sigil.
+
+=item B<< $metapackage->has_package_symbol($variable_name) >>
+
+Returns true if there is a package variable defined for
+C<$variable_name>. The C<$variable_name> must contain a leading sigil.
+
+=item B<< $metapackage->remove_package_symbol($variable_name) >>
+
+This will remove the package variable specified C<$variable_name>. The
+C<$variable_name> must contain a leading sigil.
+
+=item B<< $metapackage->remove_package_glob($glob_name) >>
+
+Given the name of a glob, this will remove that glob from the
+package's symbol table. Glob names do not include a sigil. Removing
+the glob removes all variables and subroutines with the specified
+name.
+
+=item B<< $metapackage->list_all_package_symbols($type_filter) >>
+
+This will list all the glob names associated with the current
+package. These names do not have leading sigils.
+
+You can provide an optional type filter, which should be one of
+'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
+
+=item B<< $metapackage->get_all_package_symbols($type_filter) >>
+
+This works much like C<list_all_package_symbols>, but it returns a
+hash reference. The keys are glob names and the values are references
+to the value for that name.
+
+=item B<< Class::MOP::Package->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+=back
+
+=cut
use Moose::Deprecated;
use Moose::Exporter;
-use Class::MOP 1.10;
+use Class::MOP;
use Moose::Meta::Class;
use Moose::Meta::TypeConstraint;
our $AUTHORITY = 'cpan:STEVAN';
+use XSLoader;
+
+BEGIN {
+ XSLoader::load(
+ 'Moose',
+ $Moose::{VERSION} ? $Moose::{VERSION} : ()
+ );
+}
+
use Class::MOP;
use List::MoreUtils qw( first_index uniq );
use Moose::Util::MetaRole;
use Sub::Exporter 0.980;
use Sub::Name qw(subname);
-use XSLoader;
-
-XSLoader::load( 'Moose', $XS_VERSION );
-
my %EXPORT_SPEC;
sub setup_import_methods {
use List::Util qw(first);
use List::MoreUtils qw(any all);
use overload ();
-use Class::MOP 0.60;
+use Class::MOP;
our $AUTHORITY = 'cpan:STEVAN';
--- /dev/null
+
+package metaclass;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+use Try::Tiny;
+
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Class::MOP;
+
+sub import {
+ my ( $class, @args ) = @_;
+
+ unshift @args, "metaclass" if @args % 2 == 1;
+ my %options = @args;
+
+ my $meta_name = exists $options{meta_name} ? $options{meta_name} : 'meta';
+ my $metaclass = delete $options{metaclass};
+
+ unless ( defined $metaclass ) {
+ $metaclass = "Class::MOP::Class";
+ } else {
+ Class::MOP::load_class($metaclass);
+ }
+
+ ($metaclass->isa('Class::MOP::Class'))
+ || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class";
+
+ # make sure the custom metaclasses get loaded
+ foreach my $key (grep { /_(?:meta)?class$/ } keys %options) {
+ unless ( ref( my $class = $options{$key} ) ) {
+ Class::MOP::load_class($class)
+ }
+ }
+
+ my $package = caller();
+
+ # create a meta object so we can install &meta
+ my $meta = $metaclass->initialize($package => %options);
+ $meta->_add_meta_method($meta_name)
+ if defined $meta_name;
+}
+
+1;
+
+# ABSTRACT: a pragma for installing and using Class::MOP metaclasses
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+ package MyClass;
+
+ # use Class::MOP::Class
+ use metaclass;
+
+ # ... or use a custom metaclass
+ use metaclass 'MyMetaClass';
+
+ # ... or use a custom metaclass
+ # and custom attribute and method
+ # metaclasses
+ use metaclass 'MyMetaClass' => (
+ 'attribute_metaclass' => 'MyAttributeMetaClass',
+ 'method_metaclass' => 'MyMethodMetaClass',
+ );
+
+ # ... or just specify custom attribute
+ # and method classes, and Class::MOP::Class
+ # is the assumed metaclass
+ use metaclass (
+ 'attribute_metaclass' => 'MyAttributeMetaClass',
+ 'method_metaclass' => 'MyMethodMetaClass',
+ );
+
+ # if we'd rather not install a 'meta' method, we can do this
+ use metaclass meta_name => undef;
+ # or if we'd like it to have a different name,
+ use metaclass meta_name => 'my_meta';
+
+=head1 DESCRIPTION
+
+This is a pragma to make it easier to use a specific metaclass
+and a set of custom attribute and method metaclasses. It also
+installs a C<meta> method to your class as well, unless C<undef>
+is passed to the C<meta_name> option.
+
+=cut
--- /dev/null
+#include "mop.h"
+
+void
+mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark)
+{
+ dSP;
+ PUSHMARK(mark);
+ (*subaddr)(aTHX_ cv);
+ PUTBACK;
+}
+
+#if PERL_VERSION >= 10
+UV
+mop_check_package_cache_flag (pTHX_ HV *stash)
+{
+ assert(SvTYPE(stash) == SVt_PVHV);
+
+ /* here we're trying to implement a c version of mro::get_pkg_gen($stash),
+ * however the perl core doesn't make it easy for us. It doesn't provide an
+ * api that just does what we want.
+ *
+ * However, we know that the information we want is, inside the core,
+ * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the
+ * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init,
+ * which is not public and only available inside the core, as the mro
+ * interface as well as the structure returned by mro_meta_init isn't
+ * considered to be stable yet.
+ *
+ * Perl_mro_meta_init isn't declared static, so we could just define it
+ * ourselfs if perls headers don't do that for us, except that won't work
+ * on platforms where symbols need to be explicitly exported when linking
+ * shared libraries.
+ *
+ * So our, hopefully temporary, solution is to be even more evil and
+ * basically reimplement HvMROMETA in a very fragile way that'll blow up
+ * when the relevant parts of the mro implementation in core change.
+ *
+ * :-(
+ *
+ */
+
+ return HvAUX(stash)->xhv_mro_meta
+ ? HvAUX(stash)->xhv_mro_meta->pkg_gen
+ : 0;
+}
+
+#else /* pre 5.10.0 */
+
+UV
+mop_check_package_cache_flag (pTHX_ HV *stash)
+{
+ PERL_UNUSED_ARG(stash);
+ assert(SvTYPE(stash) == SVt_PVHV);
+
+ return PL_sub_generation;
+}
+#endif
+
+SV *
+mop_call0 (pTHX_ SV *const self, SV *const method)
+{
+ dSP;
+ SV *ret;
+
+ PUSHMARK(SP);
+ XPUSHs(self);
+ PUTBACK;
+
+ call_sv(method, G_SCALAR | G_METHOD);
+
+ SPAGAIN;
+ ret = POPs;
+ PUTBACK;
+
+ return ret;
+}
+
+int
+mop_get_code_info (SV *coderef, char **pkg, char **name)
+{
+ if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
+ return 0;
+ }
+
+ coderef = SvRV(coderef);
+
+ /* sub is still being compiled */
+ if (!CvGV(coderef)) {
+ return 0;
+ }
+
+ /* I think this only gets triggered with a mangled coderef, but if
+ we hit it without the guard, we segfault. The slightly odd return
+ value strikes me as an improvement (mst)
+ */
+
+ if ( isGV_with_GP(CvGV(coderef)) ) {
+ GV *gv = CvGV(coderef);
+ *pkg = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) );
+ *name = GvNAME( CvGV(coderef) );
+ } else {
+ *pkg = "__UNKNOWN__";
+ *name = "__ANON__";
+ }
+
+ return 1;
+}
+
+/* XXX: eventually this should just use the implementation in Package::Stash */
+void
+mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud)
+{
+ HE *he;
+
+ (void)hv_iterinit(stash);
+
+ if (filter == TYPE_FILTER_NONE) {
+ while ( (he = hv_iternext(stash)) ) {
+ STRLEN keylen;
+ const char *key = HePV(he, keylen);
+ if (!cb(key, keylen, HeVAL(he), ud)) {
+ return;
+ }
+ }
+ return;
+ }
+
+ while ( (he = hv_iternext(stash)) ) {
+ GV * const gv = (GV*)HeVAL(he);
+ STRLEN keylen;
+ const char * const key = HePV(he, keylen);
+ SV *sv = NULL;
+
+ if(isGV(gv)){
+ switch (filter) {
+ case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break;
+ case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break;
+ case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break;
+ case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break;
+ case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break;
+ default:
+ croak("Unknown type");
+ }
+ }
+ /* expand the gv into a real typeglob if it
+ * contains stub functions or constants and we
+ * were asked to return CODE references */
+ else if (filter == TYPE_FILTER_CODE) {
+ gv_init(gv, stash, key, keylen, GV_ADDMULTI);
+ sv = (SV *)GvCV(gv);
+ }
+
+ if (sv) {
+ if (!cb(key, keylen, sv, ud)) {
+ return;
+ }
+ }
+ }
+}
+
+static bool
+collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud)
+{
+ HV *hash = (HV *)ud;
+
+ if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) {
+ croak("failed to store symbol ref");
+ }
+
+ return TRUE;
+}
+
+HV *
+mop_get_all_package_symbols (HV *stash, type_filter_t filter)
+{
+ HV *ret = newHV ();
+ mop_get_package_symbols (stash, filter, collect_all_symbols, ret);
+ return ret;
+}
+
+#define DECLARE_KEY(name) { #name, #name, NULL, 0 }
+#define DECLARE_KEY_WITH_VALUE(name, value) { #name, value, NULL, 0 }
+
+/* the order of these has to match with those in mop.h */
+static struct {
+ const char *name;
+ const char *value;
+ SV *key;
+ U32 hash;
+} prehashed_keys[key_last] = {
+ DECLARE_KEY(_expected_method_class),
+ DECLARE_KEY(ISA),
+ DECLARE_KEY(VERSION),
+ DECLARE_KEY(accessor),
+ DECLARE_KEY(associated_class),
+ DECLARE_KEY(associated_metaclass),
+ DECLARE_KEY(associated_methods),
+ DECLARE_KEY(attribute_metaclass),
+ DECLARE_KEY(attributes),
+ DECLARE_KEY(body),
+ DECLARE_KEY(builder),
+ DECLARE_KEY(clearer),
+ DECLARE_KEY(constructor_class),
+ DECLARE_KEY(constructor_name),
+ DECLARE_KEY(definition_context),
+ DECLARE_KEY(destructor_class),
+ DECLARE_KEY(immutable_trait),
+ DECLARE_KEY(init_arg),
+ DECLARE_KEY(initializer),
+ DECLARE_KEY(insertion_order),
+ DECLARE_KEY(instance_metaclass),
+ DECLARE_KEY(is_inline),
+ DECLARE_KEY(method_metaclass),
+ DECLARE_KEY(methods),
+ DECLARE_KEY(name),
+ DECLARE_KEY(package),
+ DECLARE_KEY(package_name),
+ DECLARE_KEY(predicate),
+ DECLARE_KEY(reader),
+ DECLARE_KEY(wrapped_method_metaclass),
+ DECLARE_KEY(writer),
+ DECLARE_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"),
+ DECLARE_KEY_WITH_VALUE(_version, "-version")
+};
+
+SV *
+mop_prehashed_key_for (mop_prehashed_key_t key)
+{
+ return prehashed_keys[key].key;
+}
+
+U32
+mop_prehashed_hash_for (mop_prehashed_key_t key)
+{
+ return prehashed_keys[key].hash;
+}
+
+void
+mop_prehash_keys ()
+{
+ int i;
+ for (i = 0; i < key_last; i++) {
+ const char *value = prehashed_keys[i].value;
+ prehashed_keys[i].key = newSVpv(value, strlen(value));
+ PERL_HASH(prehashed_keys[i].hash, value, strlen(value));
+ }
+}
+
+XS(mop_xs_simple_reader)
+{
+#ifdef dVAR
+ dVAR; dXSARGS;
+#else
+ dXSARGS;
+#endif
+ register HE *he;
+ mop_prehashed_key_t key = (mop_prehashed_key_t)CvXSUBANY(cv).any_i32;
+ SV *self;
+
+ if (items != 1) {
+ croak("expected exactly one argument");
+ }
+
+ self = ST(0);
+
+ if (!SvROK(self)) {
+ croak("can't call %s as a class method", prehashed_keys[key].name);
+ }
+
+ if (SvTYPE(SvRV(self)) != SVt_PVHV) {
+ croak("object is not a hashref");
+ }
+
+ if ((he = hv_fetch_ent((HV *)SvRV(self), prehashed_keys[key].key, 0, prehashed_keys[key].hash))) {
+ ST(0) = HeVAL(he);
+ }
+ else {
+ ST(0) = &PL_sv_undef;
+ }
+
+ XSRETURN(1);
+}
+
--- /dev/null
+#ifndef __MOP_H__
+#define __MOP_H__
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define NEED_newRV_noinc
+#define NEED_sv_2pv_flags
+#define NEED_sv_2pv_nolen
+#include "ppport.h"
+
+#define MOP_CALL_BOOT(name) mop_call_xs(aTHX_ name, cv, mark);
+
+#ifndef XSPROTO
+#define XSPROTO(name) XS(name)
+#endif
+
+void mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark);
+
+typedef enum {
+ KEY__expected_method_class,
+ KEY_ISA,
+ KEY_VERSION,
+ KEY_accessor,
+ KEY_associated_class,
+ KEY_associated_metaclass,
+ KEY_associated_methods,
+ KEY_attribute_metaclass,
+ KEY_attributes,
+ KEY_body,
+ KEY_builder,
+ KEY_clearer,
+ KEY_constructor_class,
+ KEY_constructor_name,
+ KEY_definition_context,
+ KEY_destructor_class,
+ KEY_immutable_trait,
+ KEY_init_arg,
+ KEY_initializer,
+ KEY_insertion_order,
+ KEY_instance_metaclass,
+ KEY_is_inline,
+ KEY_method_metaclass,
+ KEY_methods,
+ KEY_name,
+ KEY_package,
+ KEY_package_name,
+ KEY_predicate,
+ KEY_reader,
+ KEY_wrapped_method_metaclass,
+ KEY_writer,
+ KEY_package_cache_flag,
+ KEY__version,
+ key_last,
+} mop_prehashed_key_t;
+
+#define KEY_FOR(name) mop_prehashed_key_for(KEY_ ##name)
+#define HASH_FOR(name) mop_prehashed_hash_for(KEY_ ##name)
+
+void mop_prehash_keys (void);
+SV *mop_prehashed_key_for (mop_prehashed_key_t key);
+U32 mop_prehashed_hash_for (mop_prehashed_key_t key);
+
+#define INSTALL_SIMPLE_READER(klass, name) INSTALL_SIMPLE_READER_WITH_KEY(klass, name, name)
+#define INSTALL_SIMPLE_READER_WITH_KEY(klass, name, key) \
+ { \
+ CV *cv = newXS("Class::MOP::" #klass "::" #name, mop_xs_simple_reader, __FILE__); \
+ CvXSUBANY(cv).any_i32 = KEY_ ##key; \
+ }
+
+XS(mop_xs_simple_reader);
+
+extern SV *mop_method_metaclass;
+extern SV *mop_associated_metaclass;
+extern SV *mop_wrap;
+
+UV mop_check_package_cache_flag(pTHX_ HV *stash);
+int mop_get_code_info (SV *coderef, char **pkg, char **name);
+SV *mop_call0(pTHX_ SV *const self, SV *const method);
+
+typedef enum {
+ TYPE_FILTER_NONE,
+ TYPE_FILTER_CODE,
+ TYPE_FILTER_ARRAY,
+ TYPE_FILTER_IO,
+ TYPE_FILTER_HASH,
+ TYPE_FILTER_SCALAR,
+} type_filter_t;
+
+typedef bool (*get_package_symbols_cb_t) (const char *, STRLEN, SV *, void *);
+
+void mop_get_package_symbols(HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud);
+HV *mop_get_all_package_symbols (HV *stash, type_filter_t filter);
+
+#endif
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Mixin');
+ use_ok('Class::MOP::Mixin::AttributeCore');
+ use_ok('Class::MOP::Mixin::HasAttributes');
+ use_ok('Class::MOP::Mixin::HasMethods');
+ use_ok('Class::MOP::Package');
+ use_ok('Class::MOP::Module');
+ use_ok('Class::MOP::Class');
+ use_ok('Class::MOP::Class::Immutable::Trait');
+ use_ok('Class::MOP::Method');
+ use_ok('Class::MOP::Method');
+ use_ok('Class::MOP::Method::Wrapped');
+ use_ok('Class::MOP::Method::Inlined');
+ use_ok('Class::MOP::Method::Generated');
+ use_ok('Class::MOP::Method::Accessor');
+ use_ok('Class::MOP::Method::Constructor');
+ use_ok('Class::MOP::Method::Meta');
+ use_ok('Class::MOP::Instance');
+ use_ok('Class::MOP::Object');
+}
+
+# make sure we are tracking metaclasses correctly
+
+my %METAS = (
+ 'Class::MOP::Attribute' => Class::MOP::Attribute->meta,
+ 'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta,
+ 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta,
+ 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta,
+ 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta,
+ 'Class::MOP::Method::Meta' => Class::MOP::Method::Meta->meta,
+ 'Class::MOP::Mixin' => Class::MOP::Mixin->meta,
+ 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta,
+ 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta,
+ 'Class::MOP::Mixin::HasMethods' => Class::MOP::Mixin::HasMethods->meta,
+ 'Class::MOP::Package' => Class::MOP::Package->meta,
+ 'Class::MOP::Module' => Class::MOP::Module->meta,
+ 'Class::MOP::Class' => Class::MOP::Class->meta,
+ 'Class::MOP::Method' => Class::MOP::Method->meta,
+ 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta,
+ 'Class::MOP::Instance' => Class::MOP::Instance->meta,
+ 'Class::MOP::Object' => Class::MOP::Object->meta,
+ 'Class::MOP::Class::Immutable::Trait' => Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'),
+ 'Class::MOP::Class::Immutable::Class::MOP::Class' => Class::MOP::Class::Immutable::Class::MOP::Class->meta,
+);
+
+ok( Class::MOP::is_class_loaded($_), '... ' . $_ . ' is loaded' )
+ for keys %METAS;
+
+for my $meta (values %METAS) {
+ # the trait shouldn't be made immutable, it doesn't actually do anything,
+ # and it doesn't even matter because it's not a class that will be
+ # instantiated
+ if ($meta->name eq 'Class::MOP::Class::Immutable::Trait') {
+ ok( $meta->is_mutable(), '... ' . $meta->name . ' is mutable' );
+ }
+ else {
+ ok( $meta->is_immutable(), '... ' . $meta->name . ' is immutable' );
+ }
+}
+
+is_deeply(
+ {Class::MOP::get_all_metaclasses},
+ \%METAS,
+ '... got all the metaclasses'
+);
+
+is_deeply(
+ [
+ sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances
+ ],
+ [
+ Class::MOP::Attribute->meta,
+ Class::MOP::Class->meta,
+ Class::MOP::Class::Immutable::Class::MOP::Class->meta,
+ Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'),
+ Class::MOP::Instance->meta,
+ Class::MOP::Method->meta,
+ Class::MOP::Method::Accessor->meta,
+ Class::MOP::Method::Constructor->meta,
+ Class::MOP::Method::Generated->meta,
+ Class::MOP::Method::Inlined->meta,
+ Class::MOP::Method::Meta->meta,
+ Class::MOP::Method::Wrapped->meta,
+ Class::MOP::Mixin->meta,
+ Class::MOP::Mixin::AttributeCore->meta,
+ Class::MOP::Mixin::HasAttributes->meta,
+ Class::MOP::Mixin::HasMethods->meta,
+ Class::MOP::Module->meta,
+ Class::MOP::Object->meta,
+ Class::MOP::Package->meta,
+ ],
+ '... got all the metaclass instances'
+);
+
+is_deeply(
+ [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ],
+ [
+ sort qw/
+ Class::MOP::Attribute
+ Class::MOP::Class
+ Class::MOP::Class::Immutable::Class::MOP::Class
+ Class::MOP::Class::Immutable::Trait
+ Class::MOP::Mixin
+ Class::MOP::Mixin::AttributeCore
+ Class::MOP::Mixin::HasAttributes
+ Class::MOP::Mixin::HasMethods
+ Class::MOP::Instance
+ Class::MOP::Method
+ Class::MOP::Method::Accessor
+ Class::MOP::Method::Constructor
+ Class::MOP::Method::Generated
+ Class::MOP::Method::Inlined
+ Class::MOP::Method::Wrapped
+ Class::MOP::Method::Meta
+ Class::MOP::Module
+ Class::MOP::Object
+ Class::MOP::Package
+ /,
+ ],
+ '... got all the metaclass names'
+);
+
+# testing the meta-circularity of the system
+
+is(
+ Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta,
+ '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta'
+);
+
+is(
+ Class::MOP::Class->meta->meta->meta, Class::MOP::Class->meta->meta->meta->meta,
+ '... Class::MOP::Class->meta->meta->meta == Class::MOP::Class->meta->meta->meta->meta'
+);
+
+is(
+ Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta,
+ '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta'
+);
+
+is(
+ Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta->meta,
+ '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta->meta'
+);
+
+isa_ok(Class::MOP::Class->meta, 'Class::MOP::Class');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Class;
+
+{
+ package Foo;
+ use metaclass;
+ our $VERSION = '0.01';
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ our $AUTHORITY = 'cpan:JRANDOM';
+}
+
+my $Foo = Foo->meta;
+isa_ok($Foo, 'Class::MOP::Class');
+
+my $Bar = Bar->meta;
+isa_ok($Bar, 'Class::MOP::Class');
+
+is($Foo->name, 'Foo', '... Foo->name == Foo');
+is($Bar->name, 'Bar', '... Bar->name == Bar');
+
+is($Foo->version, '0.01', '... Foo->version == 0.01');
+is($Bar->version, undef, '... Bar->version == undef');
+
+is($Foo->authority, undef, '... Foo->authority == undef');
+is($Bar->authority, 'cpan:JRANDOM', '... Bar->authority == cpan:JRANDOM');
+
+is($Foo->identifier, 'Foo-0.01', '... Foo->identifier == Foo-0.01');
+is($Bar->identifier, 'Bar-cpan:JRANDOM', '... Bar->identifier == Bar-cpan:JRANDOM');
+
+is_deeply([$Foo->superclasses], [], '... Foo has no superclasses');
+is_deeply([$Bar->superclasses], ['Foo'], '... Bar->superclasses == (Foo)');
+
+$Foo->superclasses('UNIVERSAL');
+
+is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now');
+
+is_deeply(
+ [ $Foo->class_precedence_list ],
+ [ 'Foo', 'UNIVERSAL' ],
+ '... Foo->class_precedence_list == (Foo, UNIVERSAL)');
+
+is_deeply(
+ [ $Bar->class_precedence_list ],
+ [ 'Bar', 'Foo', 'UNIVERSAL' ],
+ '... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)');
+
+# create a class using Class::MOP::Class ...
+
+my $Baz = Class::MOP::Class->create(
+ 'Baz' => (
+ version => '0.10',
+ authority => 'cpan:YOMAMA',
+ superclasses => [ 'Bar' ]
+ ));
+isa_ok($Baz, 'Class::MOP::Class');
+is(Baz->meta, $Baz, '... our metaclasses are singletons');
+
+is($Baz->name, 'Baz', '... Baz->name == Baz');
+is($Baz->version, '0.10', '... Baz->version == 0.10');
+is($Baz->authority, 'cpan:YOMAMA', '... Baz->authority == YOMAMA');
+
+is($Baz->identifier, 'Baz-0.10-cpan:YOMAMA', '... Baz->identifier == Baz-0.10-cpan:YOMAMA');
+
+is_deeply([$Baz->superclasses], ['Bar'], '... Baz->superclasses == (Bar)');
+
+is_deeply(
+ [ $Baz->class_precedence_list ],
+ [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ],
+ '... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use Class::MOP;
+use Class::MOP::Class;
+
+=pod
+
+ A
+ / \
+B C
+ \ /
+ D
+
+=cut
+
+{
+ package My::A;
+ use metaclass;
+ package My::B;
+ our @ISA = ('My::A');
+ package My::C;
+ our @ISA = ('My::A');
+ package My::D;
+ our @ISA = ('My::B', 'My::C');
+}
+
+is_deeply(
+ [ My::D->meta->class_precedence_list ],
+ [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ],
+ '... My::D->meta->class_precedence_list == (D B A C A)');
+
+is_deeply(
+ [ My::D->meta->linearized_isa ],
+ [ 'My::D', 'My::B', 'My::A', 'My::C' ],
+ '... My::D->meta->linearized_isa == (D B A C)');
+
+=pod
+
+ A <-+
+ | |
+ B |
+ | |
+ C --+
+
+=cut
+
+# 5.9.5+ dies at the moment of
+# recursive @ISA definition, not later when
+# you try to use the @ISAs.
+eval {
+ {
+ package My::2::A;
+ use metaclass;
+ our @ISA = ('My::2::C');
+
+ package My::2::B;
+ our @ISA = ('My::2::A');
+
+ package My::2::C;
+ our @ISA = ('My::2::B');
+ }
+
+ My::2::B->meta->class_precedence_list
+};
+ok($@, '... recursive inheritance breaks correctly :)');
+
+=pod
+
+ +--------+
+ | A |
+ | / \ |
+ +->B C-+
+ \ /
+ D
+
+=cut
+
+{
+ package My::3::A;
+ use metaclass;
+ package My::3::B;
+ our @ISA = ('My::3::A');
+ package My::3::C;
+ our @ISA = ('My::3::A', 'My::3::B');
+ package My::3::D;
+ our @ISA = ('My::3::B', 'My::3::C');
+}
+
+is_deeply(
+ [ My::3::D->meta->class_precedence_list ],
+ [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ],
+ '... My::3::D->meta->class_precedence_list == (D B A C A B A)');
+
+is_deeply(
+ [ My::3::D->meta->linearized_isa ],
+ [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ],
+ '... My::3::D->meta->linearized_isa == (D B A C B)');
+
+=pod
+
+Test all the class_precedence_lists
+using Perl's own dispatcher to check
+against.
+
+=cut
+
+my @CLASS_PRECEDENCE_LIST;
+
+{
+ package Foo;
+ use metaclass;
+
+ sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Bar';
+ $_[0]->SUPER::CPL();
+ }
+
+ package Baz;
+ use metaclass;
+ our @ISA = ('Bar');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Baz';
+ $_[0]->SUPER::CPL();
+ }
+
+ package Foo::Bar;
+ our @ISA = ('Baz');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Foo::Bar';
+ $_[0]->SUPER::CPL();
+ }
+
+ package Foo::Bar::Baz;
+ our @ISA = ('Foo::Bar');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz';
+ $_[0]->SUPER::CPL();
+ }
+
+}
+
+Foo::Bar::Baz->CPL();
+
+is_deeply(
+ [ Foo::Bar::Baz->meta->class_precedence_list ],
+ [ @CLASS_PRECEDENCE_LIST ],
+ '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Scalar::Util qw/reftype/;
+use Sub::Name;
+
+use Class::MOP;
+use Class::MOP::Class;
+use Class::MOP::Method;
+
+{
+ # This package tries to test &has_method as exhaustively as
+ # possible. More corner cases are welcome :)
+ package Foo;
+
+ # import a sub
+ use Scalar::Util 'blessed';
+
+ sub pie;
+ sub cake ();
+
+ use constant FOO_CONSTANT => 'Foo-CONSTANT';
+
+ # define a sub in package
+ sub bar {'Foo::bar'}
+ *baz = \&bar;
+
+ # create something with the typeglob inside the package
+ *baaz = sub {'Foo::baaz'};
+
+ { # method named with Sub::Name inside the package scope
+ no strict 'refs';
+ *{'Foo::floob'} = Sub::Name::subname 'floob' => sub {'!floob!'};
+ }
+
+ # We hateses the "used only once" warnings
+ {
+ my $temp1 = \&Foo::baz;
+ my $temp2 = \&Foo::baaz;
+ }
+
+ package OinkyBoinky;
+ our @ISA = "Foo";
+
+ sub elk {'OinkyBoinky::elk'}
+
+ package main;
+
+ sub Foo::blah { $_[0]->Foo::baz() }
+
+ {
+ no strict 'refs';
+ *{'Foo::bling'} = sub {'$$Bling$$'};
+ *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub {'!BANG!'};
+ *{'Foo::boom'} = Sub::Name::subname 'boom' => sub {'!BOOM!'};
+
+ eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }";
+ }
+}
+
+my $Foo = Class::MOP::Class->initialize('Foo');
+
+is join(' ', sort $Foo->get_method_list),
+ 'FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie';
+
+ok( $Foo->has_method('pie'), '... got the method stub pie' );
+ok( $Foo->has_method('cake'), '... got the constant method stub cake' );
+
+my $foo = sub {'Foo::foo'};
+
+ok( !UNIVERSAL::isa( $foo, 'Class::MOP::Method' ),
+ '... our method is not yet blessed' );
+
+is( exception {
+ $Foo->add_method( 'foo' => $foo );
+}, undef, '... we added the method successfully' );
+
+my $foo_method = $Foo->get_method('foo');
+
+isa_ok( $foo_method, 'Class::MOP::Method' );
+
+is( $foo_method->name, 'foo', '... got the right name for the method' );
+is( $foo_method->package_name, 'Foo',
+ '... got the right package name for the method' );
+
+ok( $Foo->has_method('foo'),
+ '... Foo->has_method(foo) (defined with Sub::Name)' );
+
+is( $Foo->get_method('foo')->body, $foo,
+ '... Foo->get_method(foo) == \&foo' );
+is( $Foo->get_method('foo')->execute, 'Foo::foo',
+ '... _method_foo->execute returns "Foo::foo"' );
+is( Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"' );
+
+# now check all our other items ...
+
+ok( $Foo->has_method('FOO_CONSTANT'),
+ '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)' );
+ok( !$Foo->has_method('bling'),
+ '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))'
+);
+
+ok( $Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)' );
+ok( $Foo->has_method('baz'),
+ '... Foo->has_method(baz) (typeglob aliased within Foo)' );
+ok( $Foo->has_method('baaz'),
+ '... Foo->has_method(baaz) (typeglob aliased within Foo)' );
+ok( $Foo->has_method('floob'),
+ '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)'
+);
+ok( $Foo->has_method('blah'),
+ '... Foo->has_method(blah) (defined in main:: using fully qualified package name)'
+);
+ok( $Foo->has_method('bang'),
+ '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)'
+);
+ok( $Foo->has_method('evaled_foo'),
+ '... Foo->has_method(evaled_foo) (evaled in main::)' );
+
+my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky');
+
+ok( $OinkyBoinky->has_method('elk'),
+ "the method 'elk' is defined in OinkyBoinky" );
+
+ok( !$OinkyBoinky->has_method('bar'),
+ "the method 'bar' is not defined in OinkyBoinky" );
+
+ok( my $bar = $OinkyBoinky->find_method_by_name('bar'),
+ "but if you look in the inheritence chain then 'bar' does exist" );
+
+is( reftype( $bar->body ), "CODE", "the returned value is a code ref" );
+
+# calling get_method blessed them all
+for my $method_name (
+ qw/baaz
+ bar
+ baz
+ floob
+ blah
+ bang
+ evaled_foo
+ FOO_CONSTANT/
+ ) {
+ isa_ok( $Foo->get_method($method_name), 'Class::MOP::Method' );
+ {
+ no strict 'refs';
+ is( $Foo->get_method($method_name)->body,
+ \&{ 'Foo::' . $method_name },
+ '... body matches CODE ref in package for ' . $method_name );
+ }
+}
+
+for my $method_name (
+ qw/
+ bling
+ /
+ ) {
+ is( ref( $Foo->get_package_symbol( '&' . $method_name ) ), 'CODE',
+ '... got the __ANON__ methods' );
+ {
+ no strict 'refs';
+ is( $Foo->get_package_symbol( '&' . $method_name ),
+ \&{ 'Foo::' . $method_name },
+ '... symbol matches CODE ref in package for ' . $method_name );
+ }
+}
+
+ok( !$Foo->has_method('blessed'),
+ '... !Foo->has_method(blessed) (imported into Foo)' );
+ok( !$Foo->has_method('boom'),
+ '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)'
+);
+
+ok( !$Foo->has_method('not_a_real_method'),
+ '... !Foo->has_method(not_a_real_method) (does not exist)' );
+is( $Foo->get_method('not_a_real_method'), undef,
+ '... Foo->get_method(not_a_real_method) == undef' );
+
+is_deeply(
+ [ sort $Foo->get_method_list ],
+ [qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob foo pie)],
+ '... got the right method list for Foo'
+);
+
+is_deeply(
+ [ sort { $a->name cmp $b->name } $Foo->get_all_methods() ],
+ [
+ map { $Foo->get_method($_) }
+ qw(
+ FOO_CONSTANT
+ baaz
+ bang
+ bar
+ baz
+ blah
+ cake
+ evaled_foo
+ floob
+ foo
+ pie
+ )
+ ],
+ '... got the right list of applicable methods for Foo'
+);
+
+is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' );
+ok( !$Foo->has_method('foo'),
+ '... !Foo->has_method(foo) we just removed it' );
+isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' );
+
+is_deeply(
+ [ sort $Foo->get_method_list ],
+ [qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie)],
+ '... got the right method list for Foo'
+);
+
+# ... test our class creator
+
+my $Bar = Class::MOP::Class->create(
+ package => 'Bar',
+ superclasses => ['Foo'],
+ methods => {
+ foo => sub {'Bar::foo'},
+ bar => sub {'Bar::bar'},
+ }
+);
+isa_ok( $Bar, 'Class::MOP::Class' );
+
+ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' );
+ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' );
+
+is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' );
+is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' );
+
+is( exception {
+ $Bar->add_method( 'foo' => sub {'Bar::foo v2'} );
+}, undef, '... overwriting a method is fine' );
+
+is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ],
+ [ "Bar", "foo" ], "subname applied to anonymous method" );
+
+ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' );
+is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' );
+
+is_deeply(
+ [ sort $Bar->get_method_list ],
+ [qw(bar foo meta)],
+ '... got the right method list for Bar'
+);
+
+is_deeply(
+ [ sort { $a->name cmp $b->name } $Bar->get_all_methods() ],
+ [
+ $Foo->get_method('FOO_CONSTANT'),
+ $Foo->get_method('baaz'),
+ $Foo->get_method('bang'),
+ $Bar->get_method('bar'),
+ (
+ map { $Foo->get_method($_) }
+ qw(
+ baz
+ blah
+ cake
+ evaled_foo
+ floob
+ )
+ ),
+ $Bar->get_method('foo'),
+ $Bar->get_method('meta'),
+ $Foo->get_method('pie'),
+ ],
+ '... got the right list of applicable methods for Bar'
+);
+
+my $method = Class::MOP::Method->wrap(
+ name => 'objecty',
+ package_name => 'Whatever',
+ body => sub {q{I am an object, and I feel an object's pain}},
+);
+
+Bar->meta->add_method( $method->name, $method );
+
+my $new_method = Bar->meta->get_method('objecty');
+
+isnt( $method, $new_method,
+ 'add_method clones method objects as they are added' );
+is( $new_method->original_method, $method,
+ '... the cloned method has the correct original method' )
+ or diag $new_method->dump;
+
+{
+ package CustomAccessor;
+
+ use Class::MOP;
+
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $meta->add_attribute(
+ foo => (
+ accessor => 'foo',
+ )
+ );
+
+ {
+ no warnings 'redefine', 'once';
+ *foo = sub {
+ my $self = shift;
+ $self->{custom_store} = $_[0];
+ };
+ }
+
+ $meta->add_around_method_modifier(
+ 'foo',
+ sub {
+ my $orig = shift;
+ $orig->(@_);
+ }
+ );
+
+ sub new {
+ return bless {}, shift;
+ }
+}
+
+{
+ my $o = CustomAccessor->new;
+ my $str = 'string';
+
+ $o->foo($str);
+
+ is(
+ $o->{custom_store}, $str,
+ 'Custom glob-assignment-created accessor still has method modifier'
+ );
+}
+
+{
+ # Since the sub reference below is not a closure, Perl caches it and uses
+ # the same reference each time through the loop. See RT #48985 for the
+ # bug.
+ foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) {
+ my $meta = Class::MOP::Class->create($ns);
+
+ my $sub = sub { };
+
+ $meta->add_method( 'foo', $sub );
+
+ my $method = $meta->get_method('foo');
+ ok( $method, 'Got the foo method back' );
+ }
+}
+
+{
+ package HasConstants;
+
+ use constant FOO => 1;
+ use constant BAR => [];
+ use constant BAZ => {};
+ use constant UNDEF => undef;
+
+ sub quux {1}
+ sub thing {1}
+}
+
+my $HC = Class::MOP::Class->initialize('HasConstants');
+
+is_deeply(
+ [ sort $HC->get_method_list ],
+ [qw( BAR BAZ FOO UNDEF quux thing )],
+ 'get_method_list handles constants properly'
+);
+
+is_deeply(
+ [ sort map { $_->name } $HC->_get_local_methods ],
+ [qw( BAR BAZ FOO UNDEF quux thing )],
+ '_get_local_methods handles constants properly'
+);
+
+{
+ package DeleteFromMe;
+ sub foo { 1 }
+}
+
+{
+ my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe');
+ ok($DFMmeta->get_method('foo'));
+
+ delete $DeleteFromMe::{foo};
+
+ ok(!$DFMmeta->get_method('foo'));
+ ok(!DeleteFromMe->can('foo'));
+}
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Class;
+
+=pod
+
+The following class hierarhcy is very contrived
+and totally horrid (it won't work under C3 even),
+but it tests a number of aspect of this module.
+
+A more real-world example would be a nice addition :)
+
+=cut
+
+{
+ package Foo;
+
+ sub BUILD { 'Foo::BUILD' }
+ sub foo { 'Foo::foo' }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ sub BUILD { 'Bar::BUILD' }
+ sub bar { 'Bar::bar' }
+
+ package Baz;
+ our @ISA = ('Bar');
+
+ sub baz { 'Baz::baz' }
+ sub foo { 'Baz::foo' }
+
+ package Foo::Bar;
+ our @ISA = ('Foo', 'Bar');
+
+ sub BUILD { 'Foo::Bar::BUILD' }
+ sub foobar { 'Foo::Bar::foobar' }
+
+ package Foo::Bar::Baz;
+ our @ISA = ('Foo', 'Bar', 'Baz');
+
+ sub BUILD { 'Foo::Bar::Baz::BUILD' }
+ sub bar { 'Foo::Bar::Baz::bar' }
+ sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' }
+}
+
+ok(!defined(Class::MOP::Class->initialize('Foo')->find_next_method_by_name('BUILD')),
+ '... Foo::BUILD has not next method');
+
+is(Class::MOP::Class->initialize('Bar')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
+ '... Bar::BUILD does have a next method');
+
+is(Class::MOP::Class->initialize('Baz')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Bar')->get_method('BUILD'),
+ '... Baz->BUILD does have a next method');
+
+is(Class::MOP::Class->initialize('Foo::Bar')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
+ '... Foo::Bar->BUILD does have a next method');
+
+is(Class::MOP::Class->initialize('Foo::Bar::Baz')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
+ '... Foo::Bar::Baz->BUILD does have a next method');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo')->get_all_methods() ],
+ [
+ Class::MOP::Class->initialize('Foo')->get_method('BUILD') ,
+ Class::MOP::Class->initialize('Foo')->get_method('foo'),
+ ],
+ '... got the right list of applicable methods for Foo');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Bar')->get_all_methods() ],
+ [
+ Class::MOP::Class->initialize('Bar')->get_method('BUILD'),
+ Class::MOP::Class->initialize('Bar')->get_method('bar'),
+ Class::MOP::Class->initialize('Foo')->get_method('foo'),
+ ],
+ '... got the right list of applicable methods for Bar');
+
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Baz')->get_all_methods() ],
+ [
+ Class::MOP::Class->initialize('Bar')->get_method('BUILD'),
+ Class::MOP::Class->initialize('Bar')->get_method('bar'),
+ Class::MOP::Class->initialize('Baz')->get_method('baz'),
+ Class::MOP::Class->initialize('Baz')->get_method('foo'),
+ ],
+ '... got the right list of applicable methods for Baz');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo::Bar')->get_all_methods() ],
+ [
+ Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD'),
+ Class::MOP::Class->initialize('Bar')->get_method('bar'),
+ Class::MOP::Class->initialize('Foo')->get_method('foo'),
+ Class::MOP::Class->initialize('Foo::Bar')->get_method('foobar'),
+ ],
+ '... got the right list of applicable methods for Foo::Bar');
+
+## find_all_methods_by_name
+
+is_deeply(
+ [ Class::MOP::Class->initialize('Foo::Bar')->find_all_methods_by_name('BUILD') ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Foo::Bar',
+ code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD')
+ },
+ {
+ name => 'BUILD',
+ class => 'Foo',
+ code => Class::MOP::Class->initialize('Foo')->get_method('BUILD')
+ },
+ {
+ name => 'BUILD',
+ class => 'Bar',
+ code => Class::MOP::Class->initialize('Bar')->get_method('BUILD')
+ }
+ ],
+ '... got the right list of BUILD methods for Foo::Bar');
+
+is_deeply(
+ [ Class::MOP::Class->initialize('Foo::Bar::Baz')->find_all_methods_by_name('BUILD') ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Foo::Bar::Baz',
+ code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD')
+ },
+ {
+ name => 'BUILD',
+ class => 'Foo',
+ code => Class::MOP::Class->initialize('Foo')->get_method('BUILD')
+ },
+ {
+ name => 'BUILD',
+ class => 'Bar',
+ code => Class::MOP::Class->initialize('Bar')->get_method('BUILD')
+ },
+ ],
+ '... got the right list of BUILD methods for Foo::Bar::Baz');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+my $FOO_ATTR = Class::MOP::Attribute->new('$foo');
+my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => (
+ accessor => 'bar'
+));
+my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => (
+ reader => 'get_baz',
+ writer => 'set_baz',
+));
+
+my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar');
+
+my $FOO_ATTR_2 = Class::MOP::Attribute->new('$foo' => (
+ accessor => 'foo',
+ builder => 'build_foo'
+));
+
+is($FOO_ATTR->name, '$foo', '... got the attributes name correctly');
+is($BAR_ATTR->name, '$bar', '... got the attributes name correctly');
+is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly');
+
+{
+ package Foo;
+ use metaclass;
+
+ my $meta = Foo->meta;
+ ::is( ::exception {
+ $meta->add_attribute($FOO_ATTR);
+ }, undef, '... we added an attribute to Foo successfully' );
+ ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute');
+ ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo');
+
+ ::ok(!$meta->has_method('foo'), '... no accessor created');
+
+ ::is( ::exception {
+ $meta->add_attribute($BAR_ATTR_2);
+ }, undef, '... we added an attribute to Foo successfully' );
+ ::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute');
+ ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo');
+
+ ::ok(!$meta->has_method('bar'), '... no accessor created');
+}
+{
+ package Bar;
+ our @ISA = ('Foo');
+
+ my $meta = Bar->meta;
+ ::is( ::exception {
+ $meta->add_attribute($BAR_ATTR);
+ }, undef, '... we added an attribute to Bar successfully' );
+ ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute');
+ ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar');
+
+ my $attr = $meta->get_attribute('$bar');
+ ::is($attr->get_read_method, 'bar', '... got the right read method for Bar');
+ ::is($attr->get_write_method, 'bar', '... got the right write method for Bar');
+
+ ::ok($meta->has_method('bar'), '... an accessor has been created');
+ ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor');
+}
+{
+ package Baz;
+ our @ISA = ('Bar');
+
+ my $meta = Baz->meta;
+ ::is( ::exception {
+ $meta->add_attribute($BAZ_ATTR);
+ }, undef, '... we added an attribute to Baz successfully' );
+ ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute');
+ ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz');
+
+ my $attr = $meta->get_attribute('$baz');
+ ::is($attr->get_read_method, 'get_baz', '... got the right read method for Baz');
+ ::is($attr->get_write_method, 'set_baz', '... got the right write method for Baz');
+
+ ::ok($meta->has_method('get_baz'), '... a reader has been created');
+ ::ok($meta->has_method('set_baz'), '... a writer has been created');
+
+ ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor');
+ ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor');
+}
+
+{
+ package Foo2;
+ use metaclass;
+
+ my $meta = Foo2->meta;
+ $meta->add_attribute(
+ Class::MOP::Attribute->new( '$foo2' => ( reader => 'foo2' ) ) );
+
+ ::ok( $meta->has_method('foo2'), '... a reader has been created' );
+
+ my $attr = $meta->get_attribute('$foo2');
+ ::is( $attr->get_read_method, 'foo2',
+ '... got the right read method for Foo2' );
+ ::is( $attr->get_write_method, undef,
+ '... got undef for the writer with a read-only attribute in Foo2' );
+}
+
+{
+ my $meta = Baz->meta;
+ isa_ok($meta, 'Class::MOP::Class');
+
+ is($meta->find_attribute_by_name('$bar'), $BAR_ATTR, '... got the right attribute for "bar"');
+ is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"');
+ is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"');
+
+ is_deeply(
+ [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ],
+ [
+ $BAR_ATTR,
+ $BAZ_ATTR,
+ $FOO_ATTR,
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+ is_deeply(
+ [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ],
+ [ Bar->meta, Baz->meta, Foo->meta ],
+ '... got the right list of associated classes from the applicable attributes for Baz');
+
+ my $attr;
+ is( exception {
+ $attr = $meta->remove_attribute('$baz');
+ }, undef, '... removed the $baz attribute successfully' );
+ is($attr, $BAZ_ATTR, '... got the right attribute back for Baz');
+
+ ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute');
+ is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute');
+
+ ok(!$meta->has_method('get_baz'), '... a reader has been removed');
+ ok(!$meta->has_method('set_baz'), '... a writer has been removed');
+
+ is_deeply(
+ [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ],
+ [
+ $BAR_ATTR,
+ $FOO_ATTR,
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+ is_deeply(
+ [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ],
+ [ Bar->meta, Foo->meta ],
+ '... got the right list of associated classes from the applicable attributes for Baz');
+
+ {
+ my $attr;
+ is( exception {
+ $attr = Bar->meta->remove_attribute('$bar');
+ }, undef, '... removed the $bar attribute successfully' );
+ is($attr, $BAR_ATTR, '... got the right attribute back for Bar');
+
+ ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute');
+
+ ok(!Bar->meta->has_method('bar'), '... a accessor has been removed');
+ }
+
+ is_deeply(
+ [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ],
+ [
+ $BAR_ATTR_2,
+ $FOO_ATTR,
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+ is_deeply(
+ [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ],
+ [ Foo->meta, Foo->meta ],
+ '... got the right list of associated classes from the applicable attributes for Baz');
+
+ # remove attribute which is not there
+ my $val;
+ is( exception {
+ $val = $meta->remove_attribute('$blammo');
+ }, undef, '... attempted to remove the non-existent $blammo attribute' );
+ is($val, undef, '... got the right value back (undef)');
+
+}
+
+{
+ package Buzz;
+ use metaclass;
+ use Scalar::Util qw/blessed/;
+
+ my $meta = Buzz->meta;
+ ::is( ::exception {
+ $meta->add_attribute($FOO_ATTR_2);
+ }, undef, '... we added an attribute to Buzz successfully' );
+
+ ::is( ::exception {
+ $meta->add_attribute(
+ Class::MOP::Attribute->new(
+ '$bar' => (
+ accessor => 'bar',
+ predicate => 'has_bar',
+ clearer => 'clear_bar',
+ )
+ )
+ );
+ }, undef, '... we added an attribute to Buzz successfully' );
+
+ ::is( ::exception {
+ $meta->add_attribute(
+ Class::MOP::Attribute->new(
+ '$bah' => (
+ accessor => 'bah',
+ predicate => 'has_bah',
+ clearer => 'clear_bah',
+ default => 'BAH',
+ )
+ )
+ );
+ }, undef, '... we added an attribute to Buzz successfully' );
+
+ ::is( ::exception {
+ $meta->add_method(build_foo => sub{ blessed shift; });
+ }, undef, '... we added a method to Buzz successfully' );
+}
+
+
+
+for(1 .. 2){
+ my $buzz;
+ ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' );
+ ::is($buzz->foo, 'Buzz', '...foo builder works as expected');
+ ::ok(!$buzz->has_bar, '...bar is not set');
+ ::is($buzz->bar, undef, '...bar returns undef');
+ ::ok(!$buzz->has_bar, '...bar was not autovivified');
+
+ $buzz->bar(undef);
+ ::ok($buzz->has_bar, '...bar is set');
+ ::is($buzz->bar, undef, '...bar is undef');
+ $buzz->clear_bar;
+ ::ok(!$buzz->has_bar, '...bar is no longerset');
+
+ my $buzz2;
+ ::is( ::exception { $buzz2 = Buzz->meta->new_object('$bar' => undef) }, undef, '...Buzz instantiated successfully' );
+ ::ok($buzz2->has_bar, '...bar is set');
+ ::is($buzz2->bar, undef, '...bar is undef');
+
+ my $buzz3;
+ ::is( ::exception { $buzz3 = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' );
+ ::ok($buzz3->has_bah, '...bah is set');
+ ::is($buzz3->bah, 'BAH', '...bah returns "BAH" ');
+
+ my $buzz4;
+ ::is( ::exception { $buzz4 = Buzz->meta->new_object('$bah' => undef) }, undef, '...Buzz instantiated successfully' );
+ ::ok($buzz4->has_bah, '...bah is set');
+ ::is($buzz4->bah, undef, '...bah is undef');
+
+ Buzz->meta->make_immutable();
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin;
+use File::Spec::Functions;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+use lib catdir($FindBin::Bin, 'lib');
+
+# make sure the Class::MOP::Class->meta does the right thing
+
+my $meta = Class::MOP::Class->meta();
+isa_ok($meta, 'Class::MOP::Class');
+
+my $new_meta = $meta->new_object('package' => 'Class::MOP::Class');
+isa_ok($new_meta, 'Class::MOP::Class');
+is($new_meta, $meta, '... it still creates the singleton');
+
+my $cloned_meta = $meta->clone_object($meta);
+isa_ok($cloned_meta, 'Class::MOP::Class');
+is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it');
+
+# make sure other metaclasses do the right thing
+
+{
+ package Foo;
+ use metaclass;
+}
+
+my $foo_meta = Foo->meta;
+isa_ok($foo_meta, 'Class::MOP::Class');
+
+is($meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton');
+is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton');
+
+# make sure subclassed of Class::MOP::Class do the right thing
+
+my $my_meta = MyMetaClass->meta;
+isa_ok($my_meta, 'Class::MOP::Class');
+
+my $new_my_meta = $my_meta->new_object('package' => 'MyMetaClass');
+isa_ok($new_my_meta, 'Class::MOP::Class');
+is($new_my_meta, $my_meta, '... even subclasses still create the singleton');
+
+my $cloned_my_meta = $meta->clone_object($my_meta);
+isa_ok($cloned_my_meta, 'Class::MOP::Class');
+is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it');
+
+is($my_meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)');
+is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)');
+
+# now create a metaclass for real
+
+my $bar_meta = $my_meta->new_object('package' => 'Bar');
+isa_ok($bar_meta, 'Class::MOP::Class');
+
+is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass');
+is($bar_meta->version, undef, '... Bar does not exists, so it has no version');
+
+$bar_meta->superclasses('Foo');
+
+# check with MyMetaClass
+
+{
+ package Baz;
+ use metaclass 'MyMetaClass';
+}
+
+my $baz_meta = Baz->meta;
+isa_ok($baz_meta, 'Class::MOP::Class');
+isa_ok($baz_meta, 'MyMetaClass');
+
+is($my_meta->new_object('package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton');
+is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton');
+
+$baz_meta->superclasses('Bar');
+
+# now create a regular objects for real
+
+my $foo = $foo_meta->new_object();
+isa_ok($foo, 'Foo');
+
+my $bar = $bar_meta->new_object();
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+my $baz = $baz_meta->new_object();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+my $cloned_foo = $foo_meta->clone_object($foo);
+isa_ok($cloned_foo, 'Foo');
+
+isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo');
+
+# check some errors
+
+isnt( exception {
+ $foo_meta->clone_object($meta);
+}, undef, '... this dies as expected' );
+
+# test stuff
+
+{
+ package FooBar;
+ use metaclass;
+
+ FooBar->meta->add_attribute('test');
+}
+
+my $attr = FooBar->meta->get_attribute('test');
+isa_ok($attr, 'Class::MOP::Attribute');
+
+my $attr_clone = $attr->clone();
+isa_ok($attr_clone, 'Class::MOP::Attribute');
+
+isnt($attr, $attr_clone, '... we successfully cloned our attributes');
+is($attr->associated_class,
+ $attr_clone->associated_class,
+ '... we successfully did not clone our associated metaclass');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Class;
+use Class::MOP::Package;
+use Class::MOP::Module;
+
+{
+ my $class = Class::MOP::Class->initialize('Foo');
+ is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta');
+}
+
+my $class_mop_class_meta = Class::MOP::Class->meta();
+isa_ok($class_mop_class_meta, 'Class::MOP::Class');
+
+my $class_mop_package_meta = Class::MOP::Package->meta();
+isa_ok($class_mop_package_meta, 'Class::MOP::Package');
+
+my $class_mop_module_meta = Class::MOP::Module->meta();
+isa_ok($class_mop_module_meta, 'Class::MOP::Module');
+
+my @class_mop_package_methods = qw(
+ _new
+
+ initialize reinitialize
+
+ name
+ namespace
+
+ add_package_symbol get_package_symbol has_package_symbol
+ remove_package_symbol get_or_add_package_symbol
+ list_all_package_symbols get_all_package_symbols remove_package_glob
+
+ _package_stash
+
+ get_method_map
+);
+
+my @class_mop_module_methods = qw(
+ _new
+
+ _instantiate_module
+
+ version authority identifier create
+);
+
+my @class_mop_class_methods = qw(
+ _new
+
+ is_pristine
+
+ initialize reinitialize create
+
+ create_anon_class is_anon_class
+
+ instance_metaclass get_meta_instance
+ _inline_create_instance
+ _inline_rebless_instance
+ _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot
+ create_meta_instance _create_meta_instance
+ new_object clone_object
+ _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses
+ _inline_slot_initializer _inline_extra_init _inline_fallback_constructor
+ _inline_generate_instance _inline_params _inline_slot_initializers
+ _inline_init_attr_from_constructor _inline_init_attr_from_default
+ _generate_fallback_constructor
+ construct_instance _construct_instance
+ construct_class_instance _construct_class_instance
+ clone_instance _clone_instance
+ rebless_instance rebless_instance_back rebless_instance_away
+ _force_rebless_instance _fixup_attributes_after_rebless
+ check_metaclass_compatibility _check_metaclass_compatibility
+ _check_class_metaclass_compatibility _check_single_metaclass_compatibility
+ _class_metaclass_is_compatible _single_metaclass_is_compatible
+ _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility
+ _fix_single_metaclass_incompatibility _base_metaclasses
+ _can_fix_metaclass_incompatibility
+ _class_metaclass_can_be_made_compatible
+ _single_metaclass_can_be_made_compatible
+
+ _remove_generated_metaobjects
+ _restore_metaobjects_from
+
+ add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies
+ add_dependent_meta_instance remove_dependent_meta_instance
+ invalidate_meta_instances invalidate_meta_instance
+
+ superclasses subclasses direct_subclasses class_precedence_list
+ linearized_isa _superclasses_updated _superclass_metas
+
+ alias_method get_all_method_names get_all_methods compute_all_applicable_methods
+ find_method_by_name find_all_methods_by_name find_next_method_by_name
+
+ add_before_method_modifier add_after_method_modifier add_around_method_modifier
+
+ _attach_attribute
+ _post_add_attribute
+ remove_attribute
+ find_attribute_by_name
+ get_all_attributes
+
+ compute_all_applicable_attributes
+ get_attribute_map
+
+ is_mutable is_immutable make_mutable make_immutable
+ _initialize_immutable _install_inlined_code _inlined_methods
+ _add_inlined_method _inline_accessors _inline_constructor
+ _inline_destructor _immutable_options _real_ref_name
+ _rebless_as_immutable _rebless_as_mutable _remove_inlined_code
+
+ _immutable_metaclass
+ immutable_trait immutable_options
+ constructor_name constructor_class destructor_class
+
+ DESTROY
+);
+
+# check the class ...
+
+is_deeply([ sort $class_mop_class_meta->get_method_list ], [ sort @class_mop_class_methods ], '... got the correct method list for class');
+
+foreach my $method_name (sort @class_mop_class_methods) {
+ ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')');
+ {
+ no strict 'refs';
+ is($class_mop_class_meta->get_method($method_name)->body,
+ \&{'Class::MOP::Class::' . $method_name},
+ '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name);
+ }
+}
+
+## check the package ....
+
+is_deeply([ sort $class_mop_package_meta->get_method_list ], [ sort @class_mop_package_methods ], '... got the correct method list for package');
+
+foreach my $method_name (sort @class_mop_package_methods) {
+ ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')');
+ {
+ no strict 'refs';
+ is($class_mop_package_meta->get_method($method_name)->body,
+ \&{'Class::MOP::Package::' . $method_name},
+ '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name);
+ }
+}
+
+## check the module ....
+
+is_deeply([ sort $class_mop_module_meta->get_method_list ], [ sort @class_mop_module_methods ], '... got the correct method list for module');
+
+foreach my $method_name (sort @class_mop_module_methods) {
+ ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')');
+ {
+ no strict 'refs';
+ is($class_mop_module_meta->get_method($method_name)->body,
+ \&{'Class::MOP::Module::' . $method_name},
+ '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name);
+ }
+}
+
+
+# check for imported functions which are not methods
+
+foreach my $non_method_name (qw(
+ confess
+ blessed
+ subname
+ svref_2object
+ )) {
+ ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')');
+}
+
+# check for the right attributes
+
+my @class_mop_package_attributes = (
+ 'package',
+ 'namespace',
+);
+
+my @class_mop_module_attributes = (
+ 'version',
+ 'authority'
+);
+
+my @class_mop_class_attributes = (
+ 'superclasses',
+ 'instance_metaclass',
+ 'immutable_trait',
+ 'constructor_name',
+ 'constructor_class',
+ 'destructor_class',
+);
+
+# check class
+
+is_deeply(
+ [ sort $class_mop_class_meta->get_attribute_list ],
+ [ sort @class_mop_class_attributes ],
+ '... got the right list of attributes'
+);
+
+is_deeply(
+ [ sort keys %{$class_mop_class_meta->_attribute_map} ],
+ [ sort @class_mop_class_attributes ],
+ '... got the right list of attributes');
+
+foreach my $attribute_name (sort @class_mop_class_attributes) {
+ ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')');
+ isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
+}
+
+# check module
+
+is_deeply(
+ [ sort $class_mop_package_meta->get_attribute_list ],
+ [ sort @class_mop_package_attributes ],
+ '... got the right list of attributes');
+
+is_deeply(
+ [ sort keys %{$class_mop_package_meta->_attribute_map} ],
+ [ sort @class_mop_package_attributes ],
+ '... got the right list of attributes');
+
+foreach my $attribute_name (sort @class_mop_package_attributes) {
+ ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')');
+ isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
+}
+
+# check package
+
+is_deeply(
+ [ sort $class_mop_module_meta->get_attribute_list ],
+ [ sort @class_mop_module_attributes ],
+ '... got the right list of attributes');
+
+is_deeply(
+ [ sort keys %{$class_mop_module_meta->_attribute_map} ],
+ [ sort @class_mop_module_attributes ],
+ '... got the right list of attributes');
+
+foreach my $attribute_name (sort @class_mop_module_attributes) {
+ ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')');
+ isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
+}
+
+## check the attributes themselves
+
+# ... package
+
+ok($class_mop_package_meta->get_attribute('package')->has_reader, '... Class::MOP::Class package has a reader');
+is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... Class::MOP::Class package\'s a reader is { name => sub { ... } }');
+
+ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg');
+is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package');
+
+# ... class, but inherited from HasMethods
+ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader');
+is_deeply($class_mop_class_meta->find_attribute_by_name('method_metaclass')->reader,
+ { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass },
+ '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass');
+
+ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg');
+is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->init_arg,
+ 'method_metaclass',
+ '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass');
+
+ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
+is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default,
+ 'Class::MOP::Method',
+ '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');
+
+ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader');
+is_deeply($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->reader,
+ { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass },
+ '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass');
+
+ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg');
+is($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg,
+ 'wrapped_method_metaclass',
+ '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass');
+
+ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
+is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default,
+ 'Class::MOP::Method',
+ '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');
+
+
+# ... class, but inherited from HasAttributes
+
+ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader');
+is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader,
+ { '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map },
+ '... Class::MOP::Class attributes\'s a reader is &_attribute_map');
+
+ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg');
+is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg,
+ 'attributes',
+ '... Class::MOP::Class attributes\'s a init_arg is attributes');
+
+ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default');
+is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'),
+ {},
+ '... Class::MOP::Class attributes\'s a default of {}');
+
+ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader');
+is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader,
+ { 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass },
+ '... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass');
+
+ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg');
+is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg,
+ 'attribute_metaclass',
+ '... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass');
+
+ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default');
+is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default,
+ 'Class::MOP::Attribute',
+ '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute');
+
+# check the values of some of the methods
+
+is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
+is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');
+
+ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)');
+is(${$class_mop_class_meta->get_package_symbol('$VERSION')},
+ $Class::MOP::Class::VERSION,
+ '... Class::MOP::Class->get_package_symbol($VERSION)');
+
+is_deeply(
+ [ $class_mop_class_meta->superclasses ],
+ [ qw/Class::MOP::Module Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods/ ],
+ '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]');
+
+is_deeply(
+ [ $class_mop_class_meta->class_precedence_list ],
+ [ qw/
+ Class::MOP::Class
+ Class::MOP::Module
+ Class::MOP::Package
+ Class::MOP::Object
+ Class::MOP::Mixin::HasAttributes
+ Class::MOP::Mixin
+ Class::MOP::Mixin::HasMethods
+ Class::MOP::Mixin
+ / ],
+ '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]');
+
+is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass');
+is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass');
+is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+my $Point = Class::MOP::Class->create('Point' => (
+ version => '0.01',
+ attributes => [
+ Class::MOP::Attribute->new('x' => (
+ reader => 'x',
+ init_arg => 'x'
+ )),
+ Class::MOP::Attribute->new('y' => (
+ accessor => 'y',
+ init_arg => 'y'
+ )),
+ ],
+ methods => {
+ 'new' => sub {
+ my $class = shift;
+ my $instance = $class->meta->new_object(@_);
+ bless $instance => $class;
+ },
+ 'clear' => sub {
+ my $self = shift;
+ $self->{'x'} = 0;
+ $self->{'y'} = 0;
+ }
+ }
+));
+
+my $Point3D = Class::MOP::Class->create('Point3D' => (
+ version => '0.01',
+ superclasses => [ 'Point' ],
+ attributes => [
+ Class::MOP::Attribute->new('z' => (
+ default => 123
+ )),
+ ],
+ methods => {
+ 'clear' => sub {
+ my $self = shift;
+ $self->{'z'} = 0;
+ $self->SUPER::clear();
+ }
+ }
+));
+
+isa_ok($Point, 'Class::MOP::Class');
+isa_ok($Point3D, 'Class::MOP::Class');
+
+# ... test the classes themselves
+
+my $point = Point->new('x' => 2, 'y' => 3);
+isa_ok($point, 'Point');
+
+can_ok($point, 'x');
+can_ok($point, 'y');
+can_ok($point, 'clear');
+
+{
+ my $meta = $point->meta;
+ is($meta, Point->meta(), '... got the meta from the instance too');
+}
+
+is($point->y, 3, '... the y attribute was initialized correctly through the metaobject');
+
+$point->y(42);
+is($point->y, 42, '... the y attribute was set properly with the accessor');
+
+is($point->x, 2, '... the x attribute was initialized correctly through the metaobject');
+
+isnt( exception {
+ $point->x(42);
+}, undef, '... cannot write to a read-only accessor' );
+is($point->x, 2, '... the x attribute was not altered');
+
+$point->clear();
+
+is($point->y, 0, '... the y attribute was cleared correctly');
+is($point->x, 0, '... the x attribute was cleared correctly');
+
+my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3);
+isa_ok($point3d, 'Point3D');
+isa_ok($point3d, 'Point');
+
+{
+ my $meta = $point3d->meta;
+ is($meta, Point3D->meta(), '... got the meta from the instance too');
+}
+
+can_ok($point3d, 'x');
+can_ok($point3d, 'y');
+can_ok($point3d, 'clear');
+
+is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject');
+is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject');
+is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject');
+
+{
+ my $point3d = Point3D->new();
+ isa_ok($point3d, 'Point3D');
+
+ is($point3d->x, undef, '... the x attribute was not initialized');
+ is($point3d->y, undef, '... the y attribute was not initialized');
+ is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject');
+
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package Foo;
+ use metaclass;
+}
+
+=pod
+
+This is the same test as 080_meta_package.t just here
+we call all the methods through Class::MOP::Class.
+
+=cut
+
+# ----------------------------------------------------------------------
+## tests adding a HASH
+
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
+ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees');
+
+is( exception {
+ Foo->meta->add_package_symbol('%foo' => { one => 1 });
+}, undef, '... created %Foo::foo successfully' );
+
+# ... scalar should NOT be created here
+
+ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too');
+
+ok(defined($Foo::{foo}), '... the %foo slot was created successfully');
+ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees');
+
+# check the value ...
+
+{
+ no strict 'refs';
+ ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly');
+ is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly');
+}
+
+my $foo = Foo->meta->get_package_symbol('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+# ... make sure changes propogate up
+
+$foo->{two} = 2;
+
+{
+ no strict 'refs';
+ is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas');
+
+ ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
+ is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
+}
+
+# ----------------------------------------------------------------------
+## test adding an ARRAY
+
+ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
+
+is( exception {
+ Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully' );
+
+ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
+ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees');
+
+# ... why does this not work ...
+
+ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too');
+
+# check the value itself
+
+{
+ no strict 'refs';
+ is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly');
+ is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly');
+}
+
+# ----------------------------------------------------------------------
+## test adding a SCALAR
+
+ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet');
+
+is( exception {
+ Foo->meta->add_package_symbol('$baz' => 10);
+}, undef, '... created $Foo::baz successfully' );
+
+ok(defined($Foo::{baz}), '... the $baz slot was created successfully');
+ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees');
+
+ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too');
+
+is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back');
+
+{
+ no strict 'refs';
+ ${'Foo::baz'} = 1;
+
+ is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly');
+ is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees');
+}
+
+# ----------------------------------------------------------------------
+## test adding a CODE
+
+ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
+
+is( exception {
+ Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" });
+}, undef, '... created &Foo::funk successfully' );
+
+ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
+ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees');
+
+ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too');
+
+{
+ no strict 'refs';
+ ok(defined &{'Foo::funk'}, '... our &funk exists');
+}
+
+is(Foo->funk(), 'Foo::funk', '... got the right value from the function');
+
+# ----------------------------------------------------------------------
+## test multiple slots in the glob
+
+my $ARRAY = [ 1, 2, 3 ];
+my $CODE = sub { "Foo::foo" };
+
+is( exception {
+ Foo->meta->add_package_symbol('@foo' => $ARRAY);
+}, undef, '... created @Foo::foo successfully' );
+
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully');
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+is( exception {
+ Foo->meta->add_package_symbol('&foo' => $CODE);
+}, undef, '... created &Foo::foo successfully' );
+
+ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees');
+is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+
+is( exception {
+ Foo->meta->add_package_symbol('$foo' => 'Foo::foo');
+}, undef, '... created $Foo::foo successfully' );
+
+ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees');
+my $SCALAR = Foo->meta->get_package_symbol('$foo');
+is($$SCALAR, 'Foo::foo', '... got the right scalar value back');
+
+{
+ no strict 'refs';
+ is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar');
+}
+
+is( exception {
+ Foo->meta->remove_package_symbol('%foo');
+}, undef, '... removed %Foo::foo successfully' );
+
+ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully');
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists');
+ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists');
+ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists');
+
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+}
+
+is( exception {
+ Foo->meta->remove_package_symbol('&foo');
+}, undef, '... removed &Foo::foo successfully' );
+
+ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists');
+
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists');
+ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists');
+
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+}
+
+is( exception {
+ Foo->meta->remove_package_symbol('$foo');
+}, undef, '... removed $Foo::foo successfully' );
+
+ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists');
+
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists');
+
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package Point;
+ use metaclass;
+
+ Point->meta->add_attribute('x' => (
+ reader => 'x',
+ init_arg => 'x'
+ ));
+
+ Point->meta->add_attribute('y' => (
+ accessor => 'y',
+ init_arg => 'y'
+ ));
+
+ sub new {
+ my $class = shift;
+ bless $class->meta->new_object(@_) => $class;
+ }
+
+ sub clear {
+ my $self = shift;
+ $self->{'x'} = 0;
+ $self->{'y'} = 0;
+ }
+
+ package Point3D;
+ our @ISA = ('Point');
+
+ Point3D->meta->add_attribute('z' => (
+ default => 123
+ ));
+
+ sub clear {
+ my $self = shift;
+ $self->{'z'} = 0;
+ $self->SUPER::clear();
+ }
+}
+
+isa_ok(Point->meta, 'Class::MOP::Class');
+isa_ok(Point3D->meta, 'Class::MOP::Class');
+
+# ... test the classes themselves
+
+my $point = Point->new('x' => 2, 'y' => 3);
+isa_ok($point, 'Point');
+
+can_ok($point, 'x');
+can_ok($point, 'y');
+can_ok($point, 'clear');
+
+{
+ my $meta = $point->meta;
+ is($meta, Point->meta(), '... got the meta from the instance too');
+}
+
+is($point->y, 3, '... the y attribute was initialized correctly through the metaobject');
+
+$point->y(42);
+is($point->y, 42, '... the y attribute was set properly with the accessor');
+
+is($point->x, 2, '... the x attribute was initialized correctly through the metaobject');
+
+isnt( exception {
+ $point->x(42);
+}, undef, '... cannot write to a read-only accessor' );
+is($point->x, 2, '... the x attribute was not altered');
+
+$point->clear();
+
+is($point->y, 0, '... the y attribute was cleared correctly');
+is($point->x, 0, '... the x attribute was cleared correctly');
+
+my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3);
+isa_ok($point3d, 'Point3D');
+isa_ok($point3d, 'Point');
+
+{
+ my $meta = $point3d->meta;
+ is($meta, Point3D->meta(), '... got the meta from the instance too');
+}
+
+can_ok($point3d, 'x');
+can_ok($point3d, 'y');
+can_ok($point3d, 'clear');
+
+is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject');
+is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject');
+is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject');
+
+{
+ my $point3d = Point3D->new();
+ isa_ok($point3d, 'Point3D');
+
+ is($point3d->x, undef, '... the x attribute was not initialized');
+ is($point3d->y, undef, '... the y attribute was not initialized');
+ is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject');
+
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ my $attr = Class::MOP::Attribute->new('$test');
+ is( $attr->meta, Class::MOP::Attribute->meta,
+ '... instance and class both lead to the same meta' );
+}
+
+{
+ my $meta = Class::MOP::Attribute->meta();
+ isa_ok( $meta, 'Class::MOP::Class' );
+
+ my @methods = qw(
+ new
+ clone
+
+ initialize_instance_slot
+ _set_initial_slot_value
+ _make_initializer_writer_callback
+
+ name
+ has_accessor accessor
+ has_writer writer
+ has_write_method get_write_method get_write_method_ref
+ has_reader reader
+ has_read_method get_read_method get_read_method_ref
+ has_predicate predicate
+ has_clearer clearer
+ has_builder builder
+ has_init_arg init_arg
+ has_default default is_default_a_coderef
+ has_initializer initializer
+ has_insertion_order insertion_order _set_insertion_order
+
+ definition_context
+
+ slots
+ get_value
+ set_value
+ get_raw_value
+ set_raw_value
+ set_initial_value
+ has_value
+ clear_value
+
+ associated_class
+ attach_to_class
+ detach_from_class
+
+ accessor_metaclass
+
+ associated_methods
+ associate_method
+
+ process_accessors
+ _process_accessors
+ install_accessors
+ remove_accessors
+
+ _inline_get_value
+ _inline_set_value
+ _inline_has_value
+ _inline_clear_value
+ _inline_instance_get
+ _inline_instance_set
+ _inline_instance_has
+ _inline_instance_clear
+
+ _new
+ );
+
+ is_deeply(
+ [
+ sort Class::MOP::Mixin::AttributeCore->meta->get_method_list,
+ $meta->get_method_list
+ ],
+ [ sort @methods ],
+ '... our method list matches'
+ );
+
+ foreach my $method_name (@methods) {
+ ok( $meta->find_method_by_name($method_name),
+ '... Class::MOP::Attribute->find_method_by_name(' . $method_name . ')' );
+ }
+
+ my @attributes = (
+ 'name',
+ 'accessor',
+ 'reader',
+ 'writer',
+ 'predicate',
+ 'clearer',
+ 'builder',
+ 'init_arg',
+ 'initializer',
+ 'definition_context',
+ 'default',
+ 'associated_class',
+ 'associated_methods',
+ 'insertion_order',
+ );
+
+ is_deeply(
+ [
+ sort Class::MOP::Mixin::AttributeCore->meta->get_attribute_list,
+ $meta->get_attribute_list
+ ],
+ [ sort @attributes ],
+ '... our attribute list matches'
+ );
+
+ foreach my $attribute_name (@attributes) {
+ ok( $meta->find_attribute_by_name($attribute_name),
+ '... Class::MOP::Attribute->find_attribute_by_name('
+ . $attribute_name
+ . ')' );
+ }
+
+ # We could add some tests here to make sure that
+ # the attribute have the appropriate
+ # accessor/reader/writer/predicate combinations,
+ # but that is getting a little excessive so I
+ # wont worry about it for now. Maybe if I get
+ # bored I will do it.
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+=pod
+
+Test that a default set up will cause metaclasses to inherit
+the same metaclass type, but produce different metaclasses.
+
+=cut
+
+{
+ package Foo;
+ use metaclass;
+
+ package Bar;
+ use base 'Foo';
+
+ package Baz;
+ use base 'Bar';
+}
+
+my $foo_meta = Foo->meta;
+isa_ok($foo_meta, 'Class::MOP::Class');
+
+is($foo_meta->name, 'Foo', '... foo_meta->name == Foo');
+
+my $bar_meta = Bar->meta;
+isa_ok($bar_meta, 'Class::MOP::Class');
+
+is($bar_meta->name, 'Bar', '... bar_meta->name == Bar');
+isnt($bar_meta, $foo_meta, '... Bar->meta != Foo->meta');
+
+my $baz_meta = Baz->meta;
+isa_ok($baz_meta, 'Class::MOP::Class');
+
+is($baz_meta->name, 'Baz', '... baz_meta->name == Baz');
+isnt($baz_meta, $bar_meta, '... Baz->meta != Bar->meta');
+isnt($baz_meta, $foo_meta, '... Baz->meta != Foo->meta');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ isnt( exception {
+ Class::MOP::Class->initialize();
+ }, undef, '... initialize requires a name parameter' );
+
+ isnt( exception {
+ Class::MOP::Class->initialize('');
+ }, undef, '... initialize requires a name valid parameter' );
+
+ isnt( exception {
+ Class::MOP::Class->initialize(bless {} => 'Foo');
+ }, undef, '... initialize requires an unblessed parameter' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->_construct_class_instance();
+ }, undef, '... _construct_class_instance requires an :package parameter' );
+
+ isnt( exception {
+ Class::MOP::Class->_construct_class_instance(':package' => undef);
+ }, undef, '... _construct_class_instance requires a defined :package parameter' );
+
+ isnt( exception {
+ Class::MOP::Class->_construct_class_instance(':package' => '');
+ }, undef, '... _construct_class_instance requires a valid :package parameter' );
+}
+
+
+{
+ isnt( exception {
+ Class::MOP::Class->create();
+ }, undef, '... create requires an package_name parameter' );
+
+ isnt( exception {
+ Class::MOP::Class->create(undef);
+ }, undef, '... create requires a defined package_name parameter' );
+
+ isnt( exception {
+ Class::MOP::Class->create('');
+ }, undef, '... create requires a valid package_name parameter' );
+
+ like( exception {
+ Class::MOP::Class->create('+++');
+ }, qr/^creation of \+\+\+ failed/, '... create requires a valid package_name parameter' );
+
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->clone_object(1);
+ }, undef, '... can only clone instances' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->add_method();
+ }, undef, '... add_method dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->add_method('');
+ }, undef, '... add_method dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->add_method('foo' => 'foo');
+ }, undef, '... add_method dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->add_method('foo' => []);
+ }, undef, '... add_method dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->has_method();
+ }, undef, '... has_method dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->has_method('');
+ }, undef, '... has_method dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->get_method();
+ }, undef, '... get_method dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->get_method('');
+ }, undef, '... get_method dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->remove_method();
+ }, undef, '... remove_method dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->remove_method('');
+ }, undef, '... remove_method dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->find_all_methods_by_name();
+ }, undef, '... find_all_methods_by_name dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->find_all_methods_by_name('');
+ }, undef, '... find_all_methods_by_name dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->add_attribute(bless {} => 'Foo');
+ }, undef, '... add_attribute dies as expected' );
+}
+
+
+{
+ isnt( exception {
+ Class::MOP::Class->has_attribute();
+ }, undef, '... has_attribute dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->has_attribute('');
+ }, undef, '... has_attribute dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->get_attribute();
+ }, undef, '... get_attribute dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->get_attribute('');
+ }, undef, '... get_attribute dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->remove_attribute();
+ }, undef, '... remove_attribute dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->remove_attribute('');
+ }, undef, '... remove_attribute dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->add_package_symbol();
+ }, undef, '... add_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->add_package_symbol('');
+ }, undef, '... add_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->add_package_symbol('foo');
+ }, undef, '... add_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->add_package_symbol('&foo');
+ }, undef, '... add_package_symbol dies as expected' );
+
+# throws_ok {
+# Class::MOP::Class->meta->add_package_symbol('@-');
+# } qr/^Could not create package variable \(\@\-\) because/,
+# '... add_package_symbol dies as expected';
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->has_package_symbol();
+ }, undef, '... has_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->has_package_symbol('');
+ }, undef, '... has_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->has_package_symbol('foo');
+ }, undef, '... has_package_symbol dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->get_package_symbol();
+ }, undef, '... get_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->get_package_symbol('');
+ }, undef, '... get_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->get_package_symbol('foo');
+ }, undef, '... get_package_symbol dies as expected' );
+}
+
+{
+ isnt( exception {
+ Class::MOP::Class->remove_package_symbol();
+ }, undef, '... remove_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->remove_package_symbol('');
+ }, undef, '... remove_package_symbol dies as expected' );
+
+ isnt( exception {
+ Class::MOP::Class->remove_package_symbol('foo');
+ }, undef, '... remove_package_symbol dies as expected' );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+
+ package BankAccount;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ use Carp 'confess';
+
+ BankAccount->meta->add_attribute(
+ 'balance' => (
+ accessor => 'balance',
+ init_arg => 'balance',
+ default => 0
+ )
+ );
+
+ sub new { (shift)->meta->new_object(@_) }
+
+ sub deposit {
+ my ( $self, $amount ) = @_;
+ $self->balance( $self->balance + $amount );
+ }
+
+ sub withdraw {
+ my ( $self, $amount ) = @_;
+ my $current_balance = $self->balance();
+ ( $current_balance >= $amount )
+ || confess "Account overdrawn";
+ $self->balance( $current_balance - $amount );
+ }
+
+ package CheckingAccount;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ use base 'BankAccount';
+
+ CheckingAccount->meta->add_attribute(
+ 'overdraft_account' => (
+ accessor => 'overdraft_account',
+ init_arg => 'overdraft',
+ )
+ );
+
+ CheckingAccount->meta->add_before_method_modifier(
+ 'withdraw' => sub {
+ my ( $self, $amount ) = @_;
+ my $overdraft_amount = $amount - $self->balance();
+ if ( $overdraft_amount > 0 ) {
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ }
+ );
+
+ ::like(
+ ::exception{ CheckingAccount->meta->add_before_method_modifier(
+ 'does_not_exist' => sub { }
+ );
+ },
+ qr/\QThe method 'does_not_exist' was not found in the inheritance hierarchy for CheckingAccount/
+ );
+
+ ::ok( CheckingAccount->meta->has_method('withdraw'),
+ '... checking account now has a withdraw method' );
+ ::isa_ok( CheckingAccount->meta->get_method('withdraw'),
+ 'Class::MOP::Method::Wrapped' );
+ ::isa_ok( BankAccount->meta->get_method('withdraw'),
+ 'Class::MOP::Method' );
+
+ CheckingAccount->meta->add_method( foo => sub { 'foo' } );
+ CheckingAccount->meta->add_before_method_modifier( foo => sub { 'wrapped' } );
+ ::isa_ok( CheckingAccount->meta->get_method('foo'),
+ 'Class::MOP::Method::Wrapped' );
+}
+
+my $savings_account = BankAccount->new( balance => 250 );
+isa_ok( $savings_account, 'BankAccount' );
+
+is( $savings_account->balance, 250, '... got the right savings balance' );
+is( exception {
+ $savings_account->withdraw(50);
+}, undef, '... withdrew from savings successfully' );
+is( $savings_account->balance, 200,
+ '... got the right savings balance after withdrawal' );
+isnt( exception {
+ $savings_account->withdraw(250);
+}, undef, '... could not withdraw from savings successfully' );
+
+$savings_account->deposit(150);
+is( $savings_account->balance, 350,
+ '... got the right savings balance after deposit' );
+
+my $checking_account = CheckingAccount->new(
+ balance => 100,
+ overdraft => $savings_account
+);
+isa_ok( $checking_account, 'CheckingAccount' );
+isa_ok( $checking_account, 'BankAccount' );
+
+is( $checking_account->overdraft_account, $savings_account,
+ '... got the right overdraft account' );
+
+is( $checking_account->balance, 100, '... got the right checkings balance' );
+
+is( exception {
+ $checking_account->withdraw(50);
+}, undef, '... withdrew from checking successfully' );
+is( $checking_account->balance, 50,
+ '... got the right checkings balance after withdrawal' );
+is( $savings_account->balance, 350,
+ '... got the right savings balance after checking withdrawal (no overdraft)'
+);
+
+is( exception {
+ $checking_account->withdraw(200);
+}, undef, '... withdrew from checking successfully' );
+is( $checking_account->balance, 0,
+ '... got the right checkings balance after withdrawal' );
+is( $savings_account->balance, 200,
+ '... got the right savings balance after overdraft withdrawal' );
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package Foo;
+ use strict;
+ use warnings;
+ use metaclass;
+
+ sub bar { 'Foo::bar' }
+}
+
+my $anon_class_id;
+{
+ my $instance;
+ {
+ my $anon_class = Class::MOP::Class->create_anon_class();
+ isa_ok($anon_class, 'Class::MOP::Class');
+
+ ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/);
+
+ ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists');
+ like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name');
+
+ is_deeply(
+ [$anon_class->superclasses],
+ [],
+ '... got an empty superclass list');
+ is( exception {
+ $anon_class->superclasses('Foo');
+ }, undef, '... can add a superclass to anon class' );
+ is_deeply(
+ [$anon_class->superclasses],
+ [ 'Foo' ],
+ '... got the right superclass list');
+
+ ok(!$anon_class->has_method('foo'), '... no foo method');
+ is( exception {
+ $anon_class->add_method('foo' => sub { "__ANON__::foo" });
+ }, undef, '... added a method to my anon-class' );
+ ok($anon_class->has_method('foo'), '... we have a foo method now');
+
+ $instance = $anon_class->new_object();
+ isa_ok($instance, $anon_class->name);
+ isa_ok($instance, 'Foo');
+
+ is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
+ is($instance->bar, 'Foo::bar', '... got the right return value of our bar method');
+ }
+
+ ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package still exists');
+}
+
+ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists');
+
+# but it breaks down when we try to create another one ...
+
+my $instance_2 = bless {} => ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id);
+isa_ok($instance_2, ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id));
+ok(!$instance_2->isa('Foo'), '... but the new instance is not a Foo');
+ok(!$instance_2->can('foo'), '... and it can no longer call the foo method');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+my $anon_class_name;
+my $anon_meta_name;
+{
+ package Foo;
+ use strict;
+ use warnings;
+ use metaclass;
+
+ sub make_anon_instance{
+ my $self = shift;
+ my $class = ref $self || $self;
+
+ my $anon_class = Class::MOP::Class->create_anon_class(superclasses => [$class]);
+ $anon_class_name = $anon_class->name;
+ $anon_meta_name = Scalar::Util::blessed($anon_class);
+ $anon_class->add_attribute( $_, reader => $_ ) for qw/bar baz/;
+
+ my $obj = $anon_class->new_object(bar => 'a', baz => 'b');
+ return $obj;
+ }
+
+ sub foo{ 'foo' }
+
+ 1;
+}
+
+my $instance = Foo->make_anon_instance;
+
+isa_ok($instance, $anon_class_name);
+isa_ok($instance->meta, $anon_meta_name);
+isa_ok($instance, 'Foo', '... Anonymous instance isa Foo');
+
+ok($instance->can('foo'), '... Anonymous instance can foo');
+ok($instance->meta->find_method_by_name('foo'), '... Anonymous instance has method foo');
+
+ok($instance->meta->has_attribute('bar'), '... Anonymous instance still has attribute bar');
+ok($instance->meta->has_attribute('baz'), '... Anonymous instance still has attribute baz');
+is($instance->bar, 'a', '... Anonymous instance still has correct bar value');
+is($instance->baz, 'b', '... Anonymous instance still has correct baz value');
+
+is_deeply([$instance->meta->class_precedence_list],
+ [$anon_class_name, 'Foo'],
+ '... Anonymous instance has class precedence list',
+ );
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Scalar::Util 'reftype', 'blessed';
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Attribute;
+use Class::MOP::Method;
+
+
+isnt( exception { Class::MOP::Attribute->name }, undef, q{... can't call name() as a class method} );
+
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo');
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '$foo', '... $attr init_arg is the name');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+ ok(!$attr->has_default, '... $attr does not have an default');
+ ok(!$attr->has_builder, '... $attr does not have a builder');
+
+ {
+ my $reader = $attr->get_read_method_ref;
+ my $writer = $attr->get_write_method_ref;
+
+ ok(!blessed($reader), '... it is a plain old sub');
+ ok(!blessed($writer), '... it is a plain old sub');
+
+ is(reftype($reader), 'CODE', '... it is a plain old sub');
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
+ }
+
+ my $class = Class::MOP::Class->initialize('Foo');
+ isa_ok($class, 'Class::MOP::Class');
+
+ is( exception {
+ $attr->attach_to_class($class);
+ }, undef, '... attached a class successfully' );
+
+ is($attr->associated_class, $class, '... the class was associated correctly');
+
+ ok(!$attr->get_read_method, '... $attr does not have an read method');
+ ok(!$attr->get_write_method, '... $attr does not have an write method');
+
+ {
+ my $reader = $attr->get_read_method_ref;
+ my $writer = $attr->get_write_method_ref;
+
+ ok(blessed($reader), '... it is a plain old sub');
+ ok(blessed($writer), '... it is a plain old sub');
+
+ isa_ok($reader, 'Class::MOP::Method');
+ isa_ok($writer, 'Class::MOP::Method');
+ }
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though');
+ is($attr->associated_class, $class, '... the associated classes are the same though');
+ is($attr_clone->associated_class, $class, '... the associated classes are the same though');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+ ok(!$attr->has_builder, '... $attr does not have a builder');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
+ ok(!$attr->get_read_method, '... $attr does not have an read method');
+ ok(!$attr->get_write_method, '... $attr does not have an write method');
+
+ {
+ my $reader = $attr->get_read_method_ref;
+ my $writer = $attr->get_write_method_ref;
+
+ ok(!blessed($reader), '... it is a plain old sub');
+ ok(!blessed($writer), '... it is a plain old sub');
+
+ is(reftype($reader), 'CODE', '... it is a plain old sub');
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
+ }
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though');
+ is($attr->associated_class, undef, '... the associated class is actually undef');
+ is($attr_clone->associated_class, undef, '... the associated class is actually undef');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok($attr->has_accessor, '... $attr does have an accessor');
+ is($attr->accessor, 'foo', '... $attr->accessor == foo');
+
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
+ is($attr->get_read_method, 'foo', '... $attr does not have an read method');
+ is($attr->get_write_method, 'foo', '... $attr does not have an write method');
+
+ {
+ my $reader = $attr->get_read_method_ref;
+ my $writer = $attr->get_write_method_ref;
+
+ ok(!blessed($reader), '... it is not a plain old sub');
+ ok(!blessed($writer), '... it is not a plain old sub');
+
+ is(reftype($reader), 'CODE', '... it is a plain old sub');
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
+ }
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok($attr->has_reader, '... $attr does have an reader');
+ is($attr->reader, 'get_foo', '... $attr->reader == get_foo');
+ ok($attr->has_writer, '... $attr does have an writer');
+ is($attr->writer, 'set_foo', '... $attr->writer == set_foo');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+
+ is($attr->get_read_method, 'get_foo', '... $attr does not have an read method');
+ is($attr->get_write_method, 'set_foo', '... $attr does not have an write method');
+
+ {
+ my $reader = $attr->get_read_method_ref;
+ my $writer = $attr->get_write_method_ref;
+
+ ok(!blessed($reader), '... it is not a plain old sub');
+ ok(!blessed($writer), '... it is not a plain old sub');
+
+ is(reftype($reader), 'CODE', '... it is a plain old sub');
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
+ }
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo');
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ my $attr_clone = $attr->clone('name' => '$bar');
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ isnt($attr->name, $attr_clone->name, '... we changes the name parameter');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+ is($attr_clone->name, '$bar', '... $attr_clone->name == $bar');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (builder => 'foo_builder'));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ ok(!$attr->has_default, '... $attr does not have a default');
+ ok($attr->has_builder, '... $attr does have a builder');
+ is($attr->builder, 'foo_builder', '... $attr->builder == foo_builder');
+
+}
+
+{
+ for my $value ({}, bless({}, 'Foo')) {
+ like( exception {
+ Class::MOP::Attribute->new('$foo', default => $value);
+ }, qr/References are not allowed as default values/ );
+ }
+}
+
+{
+ my $attr;
+ is( exception {
+ my $meth = Class::MOP::Method->wrap(sub {shift}, name => 'foo', package_name => 'bar');
+ $attr = Class::MOP::Attribute->new('$foo', default => $meth);
+ }, undef, 'Class::MOP::Methods accepted as default' );
+
+ is($attr->default(42), 42, 'passthrough for default on attribute');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Attribute;
+
+# most values are static
+
+{
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ default => qr/hello (.*)/
+ ));
+ }, undef, '... no refs for defaults' );
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ default => []
+ ));
+ }, undef, '... no refs for defaults' );
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ default => {}
+ ));
+ }, undef, '... no refs for defaults' );
+
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ default => \(my $var)
+ ));
+ }, undef, '... no refs for defaults' );
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ default => bless {} => 'Foo'
+ ));
+ }, undef, '... no refs for defaults' );
+
+}
+
+{
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ builder => qr/hello (.*)/
+ ));
+ }, undef, '... no refs for builders' );
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ builder => []
+ ));
+ }, undef, '... no refs for builders' );
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ builder => {}
+ ));
+ }, undef, '... no refs for builders' );
+
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ builder => \(my $var)
+ ));
+ }, undef, '... no refs for builders' );
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ builder => bless {} => 'Foo'
+ ));
+ }, undef, '... no refs for builders' );
+
+ isnt( exception {
+ Class::MOP::Attribute->new('$test' => (
+ builder => 'Foo', default => 'Foo'
+ ));
+ }, undef, '... no default AND builder' );
+
+ my $undef_attr;
+ is( exception {
+ $undef_attr = Class::MOP::Attribute->new('$test' => (
+ default => undef,
+ predicate => 'has_test',
+ ));
+ }, undef, '... undef as a default is okay' );
+ ok($undef_attr->has_default, '... and it counts as an actual default');
+ ok(!Class::MOP::Attribute->new('$test')->has_default,
+ '... but attributes with no default have no default');
+
+ Class::MOP::Class->create(
+ 'Foo',
+ attributes => [$undef_attr],
+ );
+ {
+ my $obj = Foo->meta->new_object;
+ ok($obj->has_test, '... and the default is populated');
+ is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value');
+ }
+ is( exception { Foo->meta->make_immutable }, undef, '... and it can be inlined' );
+ {
+ my $obj = Foo->new;
+ ok($obj->has_test, '... and the default is populated');
+ is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value');
+ }
+
+}
+
+
+{ # bad construtor args
+ isnt( exception {
+ Class::MOP::Attribute->new();
+ }, undef, '... no name argument' );
+
+ # These are no longer errors
+ is( exception {
+ Class::MOP::Attribute->new('');
+ }, undef, '... bad name argument' );
+
+ is( exception {
+ Class::MOP::Attribute->new(0);
+ }, undef, '... bad name argument' );
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test');
+ isnt( exception {
+ $attr->attach_to_class();
+ }, undef, '... attach_to_class died as expected' );
+
+ isnt( exception {
+ $attr->attach_to_class('Fail');
+ }, undef, '... attach_to_class died as expected' );
+
+ isnt( exception {
+ $attr->attach_to_class(bless {} => 'Fail');
+ }, undef, '... attach_to_class died as expected' );
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test' => (
+ reader => [ 'whoops, this wont work' ]
+ ));
+
+ $attr->attach_to_class(Class::MOP::Class->initialize('Foo'));
+
+ isnt( exception {
+ $attr->install_accessors;
+ }, undef, '... bad reader format' );
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test');
+
+ isnt( exception {
+ $attr->_process_accessors('fail', 'my_failing_sub');
+ }, undef, '... cannot find "fail" type generator' );
+}
+
+
+{
+ {
+ package My::Attribute;
+ our @ISA = ('Class::MOP::Attribute');
+ sub generate_reader_method { eval { die } }
+ }
+
+ my $attr = My::Attribute->new('$test' => (
+ reader => 'test'
+ ));
+
+ isnt( exception {
+ $attr->install_accessors;
+ }, undef, '... failed to generate accessors correctly' );
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test' => (
+ predicate => 'has_test'
+ ));
+
+ my $Bar = Class::MOP::Class->create('Bar');
+ isa_ok($Bar, 'Class::MOP::Class');
+
+ $Bar->add_attribute($attr);
+
+ can_ok('Bar', 'has_test');
+
+ is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute');
+
+ ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method');
+}
+
+
+{
+ # NOTE:
+ # the next three tests once tested that
+ # the code would fail, but we lifted the
+ # restriction so you can have an accessor
+ # along with a reader/writer pair (I mean
+ # why not really). So now they test that
+ # it works, which is kinda silly, but it
+ # tests the API change, so I keep it.
+
+ is( exception {
+ Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ reader => 'get_foo',
+ ));
+ }, undef, '... can create accessors with reader/writers' );
+
+ is( exception {
+ Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ writer => 'set_foo',
+ ));
+ }, undef, '... can create accessors with reader/writers' );
+
+ is( exception {
+ Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ reader => 'get_foo',
+ writer => 'set_foo',
+ ));
+ }, undef, '... can create accessors with reader/writers' );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Scalar::Util;
+
+use Test::More;
+
+use Class::MOP;
+
+=pod
+
+This tests that when an attribute of the same name
+is added to a class, that it will remove the old
+one first.
+
+=cut
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute('bar' =>
+ reader => 'get_bar',
+ writer => 'set_bar',
+ );
+
+ ::can_ok('Foo', 'get_bar');
+ ::can_ok('Foo', 'set_bar');
+ ::ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar');
+
+ my $bar_attr = Foo->meta->get_attribute('bar');
+
+ ::is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar');
+ ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar');
+ ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta');
+
+ Foo->meta->add_attribute('bar' =>
+ reader => 'assign_bar'
+ );
+
+ ::ok(!Foo->can('get_bar'), '... Foo no longer has the get_bar method');
+ ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method');
+ ::can_ok('Foo', 'assign_bar');
+ ::ok(Foo->meta->has_attribute('bar'), '... Foo still has the attribute bar');
+
+ my $bar_attr2 = Foo->meta->get_attribute('bar');
+
+ ::isnt($bar_attr, $bar_attr2, '... this is a new bar attribute');
+ ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta');
+
+ ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta');
+
+ ::isnt($bar_attr2->reader, 'get_bar', '... the bar attribute no longer has the reader get_bar');
+ ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar');
+ ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed', 'reftype';
+
+use Test::More;
+
+use Class::MOP;
+
+=pod
+
+This checks the get_read/write_method
+and get_read/write_method_ref methods
+
+=cut
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute('bar' =>
+ reader => 'get_bar',
+ writer => 'set_bar',
+ );
+
+ Foo->meta->add_attribute('baz' =>
+ accessor => 'baz',
+ );
+
+ Foo->meta->add_attribute('gorch' =>
+ reader => { 'get_gorch', => sub { (shift)->{gorch} } }
+ );
+
+ package Bar;
+ use metaclass;
+ Bar->meta->superclasses('Foo');
+
+ Bar->meta->add_attribute('quux' =>
+ accessor => 'quux',
+ );
+}
+
+can_ok('Foo', 'get_bar');
+can_ok('Foo', 'set_bar');
+can_ok('Foo', 'baz');
+can_ok('Foo', 'get_gorch');
+
+ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar');
+ok(Foo->meta->has_attribute('baz'), '... Foo has the attribute baz');
+ok(Foo->meta->has_attribute('gorch'), '... Foo has the attribute gorch');
+
+my $bar_attr = Foo->meta->get_attribute('bar');
+my $baz_attr = Foo->meta->get_attribute('baz');
+my $gorch_attr = Foo->meta->get_attribute('gorch');
+
+is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar');
+is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar');
+is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta');
+
+is($bar_attr->get_read_method, 'get_bar', '... $attr does have an read method');
+is($bar_attr->get_write_method, 'set_bar', '... $attr does have an write method');
+
+{
+ my $reader = $bar_attr->get_read_method_ref;
+ my $writer = $bar_attr->get_write_method_ref;
+
+ isa_ok($reader, 'Class::MOP::Method');
+ isa_ok($writer, 'Class::MOP::Method');
+
+ is($reader->fully_qualified_name, 'Foo::get_bar', '... it is the sub we are looking for');
+ is($writer->fully_qualified_name, 'Foo::set_bar', '... it is the sub we are looking for');
+
+ is(reftype($reader->body), 'CODE', '... it is a plain old sub');
+ is(reftype($writer->body), 'CODE', '... it is a plain old sub');
+}
+
+is($baz_attr->accessor, 'baz', '... the bar attribute has the accessor baz');
+is($baz_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta');
+
+is($baz_attr->get_read_method, 'baz', '... $attr does have an read method');
+is($baz_attr->get_write_method, 'baz', '... $attr does have an write method');
+
+{
+ my $reader = $baz_attr->get_read_method_ref;
+ my $writer = $baz_attr->get_write_method_ref;
+
+ isa_ok($reader, 'Class::MOP::Method');
+ isa_ok($writer, 'Class::MOP::Method');
+
+ is($reader, $writer, '... they are the same method');
+
+ is($reader->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for');
+ is($writer->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for');
+}
+
+is(ref($gorch_attr->reader), 'HASH', '... the gorch attribute has the reader get_gorch (HASH ref)');
+is($gorch_attr->associated_class, Foo->meta, '... and the gorch attribute is associated with Foo->meta');
+
+is($gorch_attr->get_read_method, 'get_gorch', '... $attr does have an read method');
+ok(!$gorch_attr->get_write_method, '... $attr does not have an write method');
+
+{
+ my $reader = $gorch_attr->get_read_method_ref;
+ my $writer = $gorch_attr->get_write_method_ref;
+
+ isa_ok($reader, 'Class::MOP::Method');
+ ok(blessed($writer), '... it is not a plain old sub');
+ isa_ok($writer, 'Class::MOP::Method');
+
+ is($reader->fully_qualified_name, 'Foo::get_gorch', '... it is the sub we are looking for');
+ is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed', 'reftype';
+
+use Test::More;
+
+use Class::MOP;
+
+=pod
+
+This checks that the initializer is used to set the initial value.
+
+=cut
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute('bar' =>
+ reader => 'get_bar',
+ writer => 'set_bar',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Class::MOP::Attribute');
+ ::is($attr->name, 'bar', '... the attribute is our own');
+
+ $callback->($value * 2);
+ },
+ );
+}
+
+can_ok('Foo', 'get_bar');
+can_ok('Foo', 'set_bar');
+
+my $foo = Foo->meta->new_object(bar => 10);
+is($foo->get_bar, 20, "... initial argument was doubled as expected");
+
+$foo->set_bar(30);
+
+is($foo->get_bar, 30, "... and setter works correctly");
+
+# meta tests ...
+
+my $bar = Foo->meta->get_attribute('bar');
+isa_ok($bar, 'Class::MOP::Attribute');
+
+ok($bar->has_initializer, '... bar has an initializer');
+is(reftype $bar->initializer, 'CODE', '... the initializer is a CODE ref');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Class::MOP;
+
+use Test::More;
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute( '@foo', accessor => 'foo' );
+ Foo->meta->add_attribute( '!bar', reader => 'bar' );
+ Foo->meta->add_attribute( '%baz', reader => 'baz' );
+}
+
+{
+ my $meta = Foo->meta;
+
+ for my $name ( '@foo', '!bar', '%baz' ) {
+ ok(
+ $meta->has_attribute($name),
+ "Foo has $name attribute"
+ );
+
+ my $meth = substr $name, 1;
+ ok( $meta->has_method($meth), 'Foo has $meth method' );
+ }
+
+ $meta->make_immutable, redo
+ unless $meta->is_immutable;
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Method;
+
+my $method = Class::MOP::Method->wrap(
+ sub {1},
+ package_name => 'main',
+ name => '__ANON__',
+);
+is( $method->meta, Class::MOP::Method->meta,
+ '... instance and class both lead to the same meta' );
+
+is( $method->package_name, 'main', '... our package is main::' );
+is( $method->name, '__ANON__', '... our sub name is __ANON__' );
+is( $method->fully_qualified_name, 'main::__ANON__',
+ '... our subs full name is main::__ANON__' );
+is( $method->original_method, undef, '... no original_method ' );
+is( $method->original_package_name, 'main',
+ '... the original_package_name is the same as package_name' );
+is( $method->original_name, '__ANON__',
+ '... the original_name is the same as name' );
+is( $method->original_fully_qualified_name, 'main::__ANON__',
+ '... the original_fully_qualified_name is the same as fully_qualified_name'
+);
+
+isnt( exception { Class::MOP::Method->wrap }, undef, q{... can't call wrap() without some code} );
+isnt( exception { Class::MOP::Method->wrap( [] ) }, undef, q{... can't call wrap() without some code} );
+isnt( exception { Class::MOP::Method->wrap( bless {} => 'Fail' ) }, undef, q{... can't call wrap() without some code} );
+
+isnt( exception { Class::MOP::Method->name }, undef, q{... can't call name() as a class method} );
+isnt( exception { Class::MOP::Method->body }, undef, q{... can't call body() as a class method} );
+isnt( exception { Class::MOP::Method->package_name }, undef, q{... can't call package_name() as a class method} );
+isnt( exception { Class::MOP::Method->fully_qualified_name }, undef, q{... can't call fully_qualified_name() as a class method} );
+
+my $meta = Class::MOP::Method->meta;
+isa_ok( $meta, 'Class::MOP::Class' );
+
+foreach my $method_name (
+ qw(
+ wrap
+ package_name
+ name
+ )
+ ) {
+ ok( $meta->has_method($method_name),
+ '... Class::MOP::Method->has_method(' . $method_name . ')' );
+ my $method = $meta->get_method($method_name);
+ is( $method->package_name, 'Class::MOP::Method',
+ '... our package is Class::MOP::Method' );
+ is( $method->name, $method_name,
+ '... our sub name is "' . $method_name . '"' );
+}
+
+isnt( exception {
+ Class::MOP::Method->wrap();
+}, undef, '... bad args for &wrap' );
+
+isnt( exception {
+ Class::MOP::Method->wrap('Fail');
+}, undef, '... bad args for &wrap' );
+
+isnt( exception {
+ Class::MOP::Method->wrap( [] );
+}, undef, '... bad args for &wrap' );
+
+isnt( exception {
+ Class::MOP::Method->wrap( sub {'FAIL'} );
+}, undef, '... bad args for &wrap' );
+
+isnt( exception {
+ Class::MOP::Method->wrap( sub {'FAIL'}, package_name => 'main' );
+}, undef, '... bad args for &wrap' );
+
+isnt( exception {
+ Class::MOP::Method->wrap( sub {'FAIL'}, name => '__ANON__' );
+}, undef, '... bad args for &wrap' );
+
+is( exception {
+ Class::MOP::Method->wrap( bless( sub {'FAIL'}, "Foo" ),
+ name => '__ANON__', package_name => 'Foo::Bar' );
+}, undef, '... blessed coderef to &wrap' );
+
+my $clone = $method->clone(
+ package_name => 'NewPackage',
+ name => 'new_name',
+);
+
+isa_ok( $clone, 'Class::MOP::Method' );
+is( $clone->package_name, 'NewPackage',
+ '... cloned method has new package name' );
+is( $clone->name, 'new_name', '... cloned method has new sub name' );
+is( $clone->fully_qualified_name, 'NewPackage::new_name',
+ '... cloned method has new fq name' );
+is( $clone->original_method, $method,
+ '... cloned method has correct original_method' );
+is( $clone->original_package_name, 'main',
+ '... cloned method has correct original_package_name' );
+is( $clone->original_name, '__ANON__',
+ '... cloned method has correct original_name' );
+is( $clone->original_fully_qualified_name, 'main::__ANON__',
+ '... cloned method has correct original_fully_qualified_name' );
+
+my $clone2 = $clone->clone(
+ package_name => 'NewerPackage',
+ name => 'newer_name',
+);
+
+is( $clone2->package_name, 'NewerPackage',
+ '... clone of clone has new package name' );
+is( $clone2->name, 'newer_name', '... clone of clone has new sub name' );
+is( $clone2->fully_qualified_name, 'NewerPackage::newer_name',
+ '... clone of clone new fq name' );
+is( $clone2->original_method, $clone,
+ '... cloned method has correct original_method' );
+is( $clone2->original_package_name, 'main',
+ '... original_package_name follows clone chain' );
+is( $clone2->original_name, '__ANON__',
+ '... original_name follows clone chain' );
+is( $clone2->original_fully_qualified_name, 'main::__ANON__',
+ '... original_fully_qualified_name follows clone chain' );
+
+Class::MOP::Class->create(
+ 'Method::Subclass',
+ superclasses => ['Class::MOP::Method'],
+ attributes => [
+ Class::MOP::Attribute->new(
+ foo => (
+ accessor => 'foo',
+ )
+ ),
+ ],
+);
+
+my $wrapped = Method::Subclass->wrap($method, foo => 'bar');
+isa_ok($wrapped, 'Method::Subclass');
+isa_ok($wrapped, 'Class::MOP::Method');
+is($wrapped->foo, 'bar', 'attribute set properly');
+is($wrapped->package_name, 'main', 'package_name copied properly');
+is($wrapped->name, '__ANON__', 'method name copied properly');
+
+my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO');
+is($wrapped2->name, 'FOO', 'got a new method name');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Method;
+
+# test before and afters
+{
+ my $trace = '';
+
+ my $method = Class::MOP::Method->wrap(
+ body => sub { $trace .= 'primary' },
+ package_name => 'main',
+ name => '__ANON__',
+ );
+ isa_ok( $method, 'Class::MOP::Method' );
+
+ $method->();
+ is( $trace, 'primary', '... got the right return value from method' );
+ $trace = '';
+
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' );
+ isa_ok( $wrapped, 'Class::MOP::Method' );
+
+ $wrapped->();
+ is( $trace, 'primary',
+ '... got the right return value from the wrapped method' );
+ $trace = '';
+
+ is( exception {
+ $wrapped->add_before_modifier( sub { $trace .= 'before -> ' } );
+ }, undef, '... added the before modifier okay' );
+
+ $wrapped->();
+ is( $trace, 'before -> primary',
+ '... got the right return value from the wrapped method (w/ before)'
+ );
+ $trace = '';
+
+ is( exception {
+ $wrapped->add_after_modifier( sub { $trace .= ' -> after' } );
+ }, undef, '... added the after modifier okay' );
+
+ $wrapped->();
+ is( $trace, 'before -> primary -> after',
+ '... got the right return value from the wrapped method (w/ before)'
+ );
+ $trace = '';
+}
+
+# test around method
+{
+ my $method = Class::MOP::Method->wrap(
+ sub {4},
+ package_name => 'main',
+ name => '__ANON__',
+ );
+ isa_ok( $method, 'Class::MOP::Method' );
+
+ is( $method->(), 4, '... got the right value from the wrapped method' );
+
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' );
+ isa_ok( $wrapped, 'Class::MOP::Method' );
+
+ is( $wrapped->(), 4, '... got the right value from the wrapped method' );
+
+ is( exception {
+ $wrapped->add_around_modifier( sub { ( 3, $_[0]->() ) } );
+ $wrapped->add_around_modifier( sub { ( 2, $_[0]->() ) } );
+ $wrapped->add_around_modifier( sub { ( 1, $_[0]->() ) } );
+ $wrapped->add_around_modifier( sub { ( 0, $_[0]->() ) } );
+ }, undef, '... added the around modifier okay' );
+
+ is_deeply(
+ [ $wrapped->() ],
+ [ 0, 1, 2, 3, 4 ],
+ '... got the right results back from the around methods (in list context)'
+ );
+
+ is( scalar $wrapped->(), 4,
+ '... got the right results back from the around methods (in scalar context)'
+ );
+}
+
+{
+ my @tracelog;
+
+ my $method = Class::MOP::Method->wrap(
+ sub { push @tracelog => 'primary' },
+ package_name => 'main',
+ name => '__ANON__',
+ );
+ isa_ok( $method, 'Class::MOP::Method' );
+
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' );
+ isa_ok( $wrapped, 'Class::MOP::Method' );
+
+ is( exception {
+ $wrapped->add_before_modifier( sub { push @tracelog => 'before 1' } );
+ $wrapped->add_before_modifier( sub { push @tracelog => 'before 2' } );
+ $wrapped->add_before_modifier( sub { push @tracelog => 'before 3' } );
+ }, undef, '... added the before modifier okay' );
+
+ is( exception {
+ $wrapped->add_around_modifier(
+ sub { push @tracelog => 'around 1'; $_[0]->(); } );
+ $wrapped->add_around_modifier(
+ sub { push @tracelog => 'around 2'; $_[0]->(); } );
+ $wrapped->add_around_modifier(
+ sub { push @tracelog => 'around 3'; $_[0]->(); } );
+ }, undef, '... added the around modifier okay' );
+
+ is( exception {
+ $wrapped->add_after_modifier( sub { push @tracelog => 'after 1' } );
+ $wrapped->add_after_modifier( sub { push @tracelog => 'after 2' } );
+ $wrapped->add_after_modifier( sub { push @tracelog => 'after 3' } );
+ }, undef, '... added the after modifier okay' );
+
+ $wrapped->();
+ is_deeply(
+ \@tracelog,
+ [
+ 'before 3', 'before 2', 'before 1', # last-in-first-out order
+ 'around 3', 'around 2', 'around 1', # last-in-first-out order
+ 'primary',
+ 'after 1', 'after 2', 'after 3', # first-in-first-out order
+ ],
+ '... got the right tracelog from all our before/around/after methods'
+ );
+}
+
+# test introspection
+{
+ sub before1 {
+ }
+
+ sub before2 {
+ }
+
+ sub before3 {
+ }
+
+ sub after1 {
+ }
+
+ sub after2 {
+ }
+
+ sub after3 {
+ }
+
+ sub around1 {
+ }
+
+ sub around2 {
+ }
+
+ sub around3 {
+ }
+
+ sub orig {
+ }
+
+ my $method = Class::MOP::Method->wrap(
+ body => \&orig,
+ package_name => 'main',
+ name => '__ANON__',
+ );
+
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+
+ $wrapped->add_before_modifier($_)
+ for \&before1, \&before2, \&before3;
+
+ $wrapped->add_after_modifier($_)
+ for \&after1, \&after2, \&after3;
+
+ $wrapped->add_around_modifier($_)
+ for \&around1, \&around2, \&around3;
+
+ is( $wrapped->get_original_method, $method,
+ 'check get_original_method' );
+
+ is_deeply( [ $wrapped->before_modifiers ],
+ [ \&before3, \&before2, \&before1 ],
+ 'check before_modifiers' );
+
+ is_deeply( [ $wrapped->after_modifiers ],
+ [ \&after1, \&after2, \&after3 ],
+ 'check after_modifiers' );
+
+ is_deeply( [ $wrapped->around_modifiers ],
+ [ \&around3, \&around2, \&around1 ],
+ 'check around_modifiers' );
+}
+
+done_testing;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+# UNIVERSAL methods
+
+use Test::More;
+use Class::MOP;
+
+my $meta_class = Class::MOP::Class->create_anon_class;
+
+my @universal_methods = qw/isa can VERSION/;
+push @universal_methods, 'DOES' if $] >= 5.010;
+
+TODO: {
+ local $TODO = 'UNIVERSAL methods should be available';
+
+ for my $method ( @universal_methods ) {
+ ok $meta_class->find_method_by_name($method), "has UNIVERSAL method $method";
+ }
+};
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use metaclass;
+
+{
+ package FooMeta;
+ use base 'Class::MOP::Class';
+
+ package Foo;
+ use metaclass 'FooMeta';
+}
+
+can_ok('Foo', 'meta');
+isa_ok(Foo->meta, 'FooMeta');
+isa_ok(Foo->meta, 'Class::MOP::Class');
+
+{
+ package BarMeta;
+ use base 'Class::MOP::Class';
+
+ package BarMeta::Attribute;
+ use base 'Class::MOP::Attribute';
+
+ package BarMeta::Method;
+ use base 'Class::MOP::Method';
+
+ package Bar;
+ use metaclass 'BarMeta' => (
+ 'attribute_metaclass' => 'BarMeta::Attribute',
+ 'method_metaclass' => 'BarMeta::Method',
+ );
+}
+
+can_ok('Bar', 'meta');
+isa_ok(Bar->meta, 'BarMeta');
+isa_ok(Bar->meta, 'Class::MOP::Class');
+
+is(Bar->meta->attribute_metaclass, 'BarMeta::Attribute', '... got the right attribute metaobject');
+is(Bar->meta->method_metaclass, 'BarMeta::Method', '... got the right method metaobject');
+
+{
+ package Baz;
+ use metaclass;
+}
+
+can_ok('Baz', 'meta');
+isa_ok(Baz->meta, 'Class::MOP::Class');
+
+eval {
+ package Boom;
+ metaclass->import('Foo');
+};
+ok($@, '... metaclasses must be subclass of Class::MOP::Class');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use metaclass;
+
+my %metaclass_attrs = (
+ 'Instance' => 'instance_metaclass',
+ 'Attribute' => 'attribute_metaclass',
+ 'Method' => 'method_metaclass',
+ 'Method::Wrapped' => 'wrapped_method_metaclass',
+ 'Method::Constructor' => 'constructor_class',
+);
+
+# meta classes
+for my $suffix ('Class', keys %metaclass_attrs) {
+ Class::MOP::Class->create(
+ "Foo::Meta::$suffix",
+ superclasses => ["Class::MOP::$suffix"]
+ );
+ Class::MOP::Class->create(
+ "Bar::Meta::$suffix",
+ superclasses => ["Class::MOP::$suffix"]
+ );
+ Class::MOP::Class->create(
+ "FooBar::Meta::$suffix",
+ superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"]
+ );
+}
+
+# checking...
+
+is( exception {
+ Foo::Meta::Class->create('Foo')
+}, undef, '... Foo.meta => Foo::Meta::Class is compatible' );
+is( exception {
+ Bar::Meta::Class->create('Bar')
+}, undef, '... Bar.meta => Bar::Meta::Class is compatible' );
+
+like( exception {
+ Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo'])
+}, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' );
+like( exception {
+ Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar'])
+}, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' );
+
+is( exception {
+ FooBar::Meta::Class->create('FooBar', superclasses => ['Foo'])
+}, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' );
+is( exception {
+ FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar'])
+}, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' );
+
+Foo::Meta::Class->create(
+ 'Foo::All',
+ map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+);
+
+like( exception {
+ Bar::Meta::Class->create(
+ 'Foo::All::Sub::Class',
+ superclasses => ['Foo::All'],
+ map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+ )
+}, qr/compatible/, 'incompatible Class metaclass' );
+for my $suffix (keys %metaclass_attrs) {
+ like( exception {
+ Foo::Meta::Class->create(
+ "Foo::All::Sub::$suffix",
+ superclasses => ['Foo::All'],
+ (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
+ $metaclass_attrs{$suffix} => "Bar::Meta::$suffix",
+ )
+ }, qr/compatible/, "incompatible $suffix metaclass" );
+}
+
+# fixing...
+
+is( exception {
+ Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo'])
+}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' );
+isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class');
+is( exception {
+ Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar'])
+}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' );
+isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class');
+
+is( exception {
+ Class::MOP::Class->create(
+ 'Foo::All::Sub::CMOP::Class',
+ superclasses => ['Foo::All'],
+ map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+ )
+}, undef, 'metaclass fixing works with other non-default metaclasses' );
+isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class');
+
+for my $suffix (keys %metaclass_attrs) {
+ is( exception {
+ Foo::Meta::Class->create(
+ "Foo::All::Sub::CMOP::$suffix",
+ superclasses => ['Foo::All'],
+ (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
+ $metaclass_attrs{$suffix} => "Class::MOP::$suffix",
+ )
+ }, undef, "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses" );
+ for my $suffix2 (keys %metaclass_attrs) {
+ my $method = $metaclass_attrs{$suffix2};
+ isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2");
+ }
+}
+
+# initializing...
+
+{
+ package Foo::NoMeta;
+}
+
+Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']);
+ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
+isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class');
+isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class');
+
+{
+ package Foo::NoMeta2;
+}
+Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']);
+ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
+isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class');
+isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class');
+
+Foo::Meta::Class->create('Foo::WithMeta');
+{
+ package Foo::WithMeta::Sub;
+ use base 'Foo::WithMeta';
+}
+Class::MOP::Class->create(
+ 'Foo::WithMeta::Sub::Sub',
+ superclasses => ['Foo::WithMeta::Sub']
+);
+
+isa_ok(Class::MOP::class_of('Foo::WithMeta'), 'Foo::Meta::Class');
+isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub'), 'Foo::Meta::Class');
+isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub::Sub'), 'Foo::Meta::Class');
+
+Foo::Meta::Class->create('Foo::WithMeta2');
+{
+ package Foo::WithMeta2::Sub;
+ use base 'Foo::WithMeta2';
+}
+{
+ package Foo::WithMeta2::Sub::Sub;
+ use base 'Foo::WithMeta2::Sub';
+}
+Class::MOP::Class->create(
+ 'Foo::WithMeta2::Sub::Sub::Sub',
+ superclasses => ['Foo::WithMeta2::Sub::Sub']
+);
+
+isa_ok(Class::MOP::class_of('Foo::WithMeta2'), 'Foo::Meta::Class');
+isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub'), 'Foo::Meta::Class');
+isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub'), 'Foo::Meta::Class');
+isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub::Sub'), 'Foo::Meta::Class');
+
+Class::MOP::Class->create(
+ 'Foo::Reverse::Sub::Sub',
+ superclasses => ['Foo::Reverse::Sub'],
+);
+eval "package Foo::Reverse::Sub; use base 'Foo::Reverse';";
+Foo::Meta::Class->create(
+ 'Foo::Reverse',
+);
+isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class');
+{ local $TODO = 'No idea how to handle case where parent class is created before children';
+isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class');
+isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class');
+}
+
+# unsafe fixing...
+
+{
+ Class::MOP::Class->create(
+ 'Foo::Unsafe',
+ attribute_metaclass => 'Foo::Meta::Attribute',
+ );
+ my $meta = Class::MOP::Class->create(
+ 'Foo::Unsafe::Sub',
+ );
+ $meta->add_attribute(foo => reader => 'foo');
+ like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" );
+}
+
+# immutability...
+
+{
+ my $foometa = Foo::Meta::Class->create(
+ 'Foo::Immutable',
+ );
+ $foometa->make_immutable;
+ my $barmeta = Class::MOP::Class->create(
+ 'Bar::Mutable',
+ );
+ my $bazmeta = Class::MOP::Class->create(
+ 'Baz::Mutable',
+ );
+ $bazmeta->superclasses($foometa->name);
+ is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" );
+ ok(!$bazmeta->is_immutable,
+ "immutable superclass doesn't make this class immutable");
+ is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" );
+}
+
+# nonexistent metaclasses
+
+Class::MOP::Class->create(
+ 'Weird::Meta::Method::Destructor',
+ superclasses => ['Class::MOP::Method'],
+);
+
+is( exception {
+ Class::MOP::Class->create(
+ 'Weird::Class',
+ destructor_class => 'Weird::Meta::Method::Destructor',
+ );
+}, undef, "defined metaclass in child with defined metaclass in parent is fine" );
+
+is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor',
+ "got the right destructor class");
+
+is( exception {
+ Class::MOP::Class->create(
+ 'Weird::Class::Sub',
+ superclasses => ['Weird::Class'],
+ destructor_class => undef,
+ );
+}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
+
+is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
+ "got the right destructor class");
+
+is( exception {
+ Class::MOP::Class->create(
+ 'Weird::Class::Sub2',
+ destructor_class => undef,
+ );
+}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
+
+is( exception {
+ Weird::Class::Sub2->meta->superclasses('Weird::Class');
+}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
+
+is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
+ "got the right destructor class");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use metaclass;
+
+# meta classes
+{
+ package Foo::Meta;
+ use base 'Class::MOP::Class';
+
+ package Bar::Meta;
+ use base 'Class::MOP::Class';
+
+ package FooBar::Meta;
+ use base 'Foo::Meta', 'Bar::Meta';
+}
+
+$@ = undef;
+eval {
+ package Foo;
+ metaclass->import('Foo::Meta');
+};
+ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar;
+ metaclass->import('Bar::Meta');
+};
+ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Foo::Foo;
+ metaclass->import('Bar::Meta');
+ Foo::Foo->meta->superclasses('Foo');
+};
+ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar::Bar;
+ metaclass->import('Foo::Meta');
+ Bar::Bar->meta->superclasses('Bar');
+};
+ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar;
+ metaclass->import('FooBar::Meta');
+ FooBar->meta->superclasses('Foo');
+};
+ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar2;
+ metaclass->import('FooBar::Meta');
+ FooBar2->meta->superclasses('Bar');
+};
+ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use metaclass;
+
+# meta classes
+{
+ package Foo::Meta::Instance;
+ use base 'Class::MOP::Instance';
+
+ package Bar::Meta::Instance;
+ use base 'Class::MOP::Instance';
+
+ package FooBar::Meta::Instance;
+ use base 'Foo::Meta::Instance', 'Bar::Meta::Instance';
+}
+
+$@ = undef;
+eval {
+ package Foo;
+ metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
+};
+ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar;
+ metaclass->import('instance_metaclass' => 'Bar::Meta::Instance');
+};
+ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Foo::Foo;
+ use base 'Foo';
+ metaclass->import('instance_metaclass' => 'Bar::Meta::Instance');
+};
+ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar::Bar;
+ use base 'Bar';
+ metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
+};
+ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar;
+ use base 'Foo';
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+};
+ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar2;
+ use base 'Bar';
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+};
+ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use metaclass;
+
+# meta classes
+{
+ package Foo::Meta::Instance;
+ use base 'Class::MOP::Instance';
+
+ package Bar::Meta::Instance;
+ use base 'Class::MOP::Instance';
+
+ package FooBar::Meta::Instance;
+ use base 'Foo::Meta::Instance', 'Bar::Meta::Instance';
+}
+
+$@ = undef;
+eval {
+ package Foo;
+ metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
+};
+ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar;
+ metaclass->import('instance_metaclass' => 'Bar::Meta::Instance');
+};
+ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Foo::Foo;
+ metaclass->import('instance_metaclass' => 'Bar::Meta::Instance');
+ Foo::Foo->meta->superclasses('Foo');
+};
+ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar::Bar;
+ metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
+ Bar::Bar->meta->superclasses('Bar');
+};
+ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar;
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+ FooBar->meta->superclasses('Foo');
+};
+ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar2;
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+ FooBar2->meta->superclasses('Bar');
+};
+ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin;
+use File::Spec::Functions;
+
+use Test::More;
+
+use Class::MOP;
+
+use lib catdir($FindBin::Bin, 'lib');
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+
+ use metaclass 'MyMetaClass' => (
+ 'attribute_metaclass' => 'MyMetaClass::Attribute',
+ 'instance_metaclass' => 'MyMetaClass::Instance',
+ 'method_metaclass' => 'MyMetaClass::Method',
+ 'random_metaclass' => 'MyMetaClass::Random',
+ );
+}
+
+my $meta = Foo->meta;
+
+isa_ok($meta, 'MyMetaClass', '... Correct metaclass');
+ok(Class::MOP::is_class_loaded('MyMetaClass'), '... metaclass loaded');
+
+is($meta->attribute_metaclass, 'MyMetaClass::Attribute', '... Correct attribute metaclass');
+ok(Class::MOP::is_class_loaded('MyMetaClass::Attribute'), '... attribute metaclass loaded');
+
+is($meta->instance_metaclass, 'MyMetaClass::Instance', '... Correct instance metaclass');
+ok(Class::MOP::is_class_loaded('MyMetaClass::Instance'), '... instance metaclass loaded');
+
+is($meta->method_metaclass, 'MyMetaClass::Method', '... Correct method metaclass');
+ok(Class::MOP::is_class_loaded('MyMetaClass::Method'), '... method metaclass loaded');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+use Scalar::Util 'blessed';
+
+{
+ package Parent;
+ use metaclass;
+
+ sub new { bless {} => shift }
+ sub whoami { "parent" }
+ sub parent { "parent" }
+
+ package Child;
+ use metaclass;
+ use base qw/Parent/;
+
+ sub whoami { "child" }
+ sub child { "child" }
+
+ package LeftField;
+ use metaclass;
+
+ sub new { bless {} => shift }
+ sub whoami { "leftfield" }
+ sub myhax { "areleet" }
+}
+
+# basic tests
+my $foo = Parent->new;
+is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
+is($foo->whoami, "parent", 'Parent->whoami gives parent');
+is($foo->parent, "parent", 'Parent->parent gives parent');
+isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" );
+
+Child->meta->rebless_instance($foo);
+is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance');
+is($foo->whoami, "child", 'reblessed->whoami gives child');
+is($foo->parent, "parent", 'reblessed->parent gives parent');
+is($foo->child, "child", 'reblessed->child gives child');
+
+like( exception { LeftField->meta->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./ );
+
+like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./ );
+
+Parent->meta->rebless_instance_back($foo);
+is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
+is($foo->whoami, "parent", 'Parent->whoami gives parent');
+is($foo->parent, "parent", 'Parent->parent gives parent');
+isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" );
+
+like( exception { LeftField->meta->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./ );
+
+like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./ );
+
+# make sure our ->meta is still sane
+my $bar = Parent->new;
+is(blessed($bar), 'Parent', "sanity check");
+is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
+is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
+
+ok($bar->meta->has_method('new'), 'metaclass has "new" method');
+ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
+ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
+
+is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
+
+Child->meta->rebless_instance($bar);
+is(blessed($bar), 'Child', "rebless really reblessed");
+is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
+is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child");
+
+ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method');
+ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method');
+ok(!$bar->meta->has_method('new'), 'no "new" method in this class');
+ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class');
+ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
+ok($bar->meta->has_method('child'), 'metaclass has "child" method');
+
+is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
+
+Parent->meta->rebless_instance_back($bar);
+is(blessed($bar), 'Parent', "sanity check");
+is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
+is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
+
+ok($bar->meta->has_method('new'), 'metaclass has "new" method');
+ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
+ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
+
+is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package Foo;
+ use metaclass;
+ Foo->meta->add_attribute('bar' => (reader => 'bar'));
+
+ sub new { (shift)->meta->new_object(@_) }
+
+ package Bar;
+ use metaclass;
+ use base 'Foo';
+ Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ'));
+}
+
+# normal ...
+{
+ my $foo = Foo->new(bar => 'BAR');
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 'BAR', '... got the expect value');
+ ok(!$foo->can('baz'), '... no baz method though');
+
+ is( exception {
+ Bar->meta->rebless_instance($foo)
+ }, undef, '... this works' );
+
+ is($foo->bar, 'BAR', '... got the expect value');
+ ok($foo->can('baz'), '... we have baz method now');
+ is($foo->baz, 'BAZ', '... got the expect value');
+
+ is( exception {
+ Foo->meta->rebless_instance_back($foo)
+ }, undef, '... this works' );
+ is($foo->bar, 'BAR', '... got the expect value');
+ ok(!$foo->can('baz'), '... no baz method though');
+}
+
+# with extra params ...
+{
+ my $foo = Foo->new(bar => 'BAR');
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 'BAR', '... got the expect value');
+ ok(!$foo->can('baz'), '... no baz method though');
+
+ is( exception {
+ Bar->meta->rebless_instance($foo, (baz => 'FOO-BAZ'))
+ }, undef, '... this works' );
+
+ is($foo->bar, 'BAR', '... got the expect value');
+ ok($foo->can('baz'), '... we have baz method now');
+ is($foo->baz, 'FOO-BAZ', '... got the expect value');
+
+ is( exception {
+ Foo->meta->rebless_instance_back($foo)
+ }, undef, '... this works' );
+
+ is($foo->bar, 'BAR', '... got the expect value');
+ ok(!$foo->can('baz'), '... no baz method though');
+ ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized');
+}
+
+# with extra params ...
+{
+ my $foo = Foo->new(bar => 'BAR');
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 'BAR', '... got the expect value');
+ ok(!$foo->can('baz'), '... no baz method though');
+
+ is( exception {
+ Bar->meta->rebless_instance($foo, (bar => 'FOO-BAR', baz => 'FOO-BAZ'))
+ }, undef, '... this works' );
+
+ is($foo->bar, 'FOO-BAR', '... got the expect value');
+ ok($foo->can('baz'), '... we have baz method now');
+ is($foo->baz, 'FOO-BAZ', '... got the expect value');
+
+ is( exception {
+ Foo->meta->rebless_instance_back($foo)
+ }, undef, '... this works' );
+
+ is($foo->bar, 'FOO-BAR', '... got the expect value');
+ ok(!$foo->can('baz'), '... no baz method though');
+ ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package MyMeta;
+ use base 'Class::MOP::Class';
+ sub initialize {
+ my $class = shift;
+ my ( $package, %options ) = @_;
+ ::cmp_ok( $options{foo}, 'eq', 'this',
+ 'option passed to initialize() on create_anon_class()' );
+ return $class->SUPER::initialize( @_ );
+ }
+
+}
+
+{
+ my $anon = MyMeta->create_anon_class( foo => 'this' );
+ isa_ok( $anon, 'MyMeta' );
+}
+
+my $instance;
+
+{
+ my $meta = Class::MOP::Class->create_anon_class;
+ $instance = $meta->new_object;
+}
+{
+ my $meta = Class::MOP::class_of($instance);
+ Scalar::Util::weaken($meta);
+ ok($meta, "anon class is kept alive by existing instances");
+
+ undef $instance;
+ ok(!$meta, "anon class is collected once instances go away");
+}
+
+{
+ my $meta = Class::MOP::Class->create_anon_class;
+ $meta->make_immutable;
+ $instance = $meta->name->new;
+}
+{
+ my $meta = Class::MOP::class_of($instance);
+ Scalar::Util::weaken($meta);
+ ok($meta, "anon class is kept alive by existing instances (immutable)");
+
+ undef $instance;
+ ok(!$meta, "anon class is collected once instances go away (immutable)");
+}
+
+{
+ $instance = Class::MOP::Class->create('Foo')->new_object;
+ my $meta = Class::MOP::Class->create_anon_class(superclasses => ['Foo']);
+ $meta->rebless_instance($instance);
+}
+{
+ my $meta = Class::MOP::class_of($instance);
+ Scalar::Util::weaken($meta);
+ ok($meta, "anon class is kept alive by existing instances");
+
+ undef $instance;
+ ok(!$meta, "anon class is collected once instances go away");
+}
+
+{
+ {
+ my $meta = Class::MOP::Class->create_anon_class;
+ {
+ my $submeta = Class::MOP::Class->create_anon_class(
+ superclasses => [$meta->name]
+ );
+ $instance = $submeta->new_object;
+ }
+ {
+ my $submeta = Class::MOP::class_of($instance);
+ Scalar::Util::weaken($submeta);
+ ok($submeta, "anon class is kept alive by existing instances");
+
+ $meta->rebless_instance_back($instance);
+ ok(!$submeta, "reblessing away loses the metaclass");
+ }
+ }
+
+ my $meta = Class::MOP::class_of($instance);
+ Scalar::Util::weaken($meta);
+ ok($meta, "anon class is kept alive by existing instances");
+}
+
+{
+ my $submeta = Class::MOP::Class->create_anon_class(
+ superclasses => [Class::MOP::Class->create_anon_class->name],
+ );
+ my @superclasses = $submeta->superclasses;
+ ok(Class::MOP::class_of($superclasses[0]),
+ "superclasses are kept alive by their subclasses");
+}
+
+{
+ my $meta_name;
+ {
+ my $meta = Class::MOP::Class->create_anon_class(
+ superclasses => ['Class::MOP::Class'],
+ );
+ $meta_name = $meta->name;
+ ok(Class::MOP::metaclass_is_weak($meta_name),
+ "default is for anon metaclasses to be weakened");
+ }
+ ok(!Class::MOP::class_of($meta_name),
+ "and weak metaclasses go away when all refs do");
+ {
+ my $meta = Class::MOP::Class->create_anon_class(
+ superclasses => ['Class::MOP::Class'],
+ weaken => 0,
+ );
+ $meta_name = $meta->name;
+ ok(!Class::MOP::metaclass_is_weak($meta_name),
+ "anon classes can be told not to weaken");
+ }
+ ok(Class::MOP::class_of($meta_name), "metaclass still exists");
+ {
+ my $bar_meta;
+ is( exception {
+ $bar_meta = $meta_name->initialize('Bar');
+ }, undef, "we can use the name on its own" );
+ isa_ok($bar_meta, $meta_name);
+ }
+}
+
+{
+ my $meta = Class::MOP::Class->create(
+ 'Baz',
+ weaken => 1,
+ );
+ $instance = $meta->new_object;
+}
+{
+ my $meta = Class::MOP::class_of($instance);
+ Scalar::Util::weaken($meta);
+ ok($meta, "weak class is kept alive by existing instances");
+
+ undef $instance;
+ ok(!$meta, "weak class is collected once instances go away");
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+{
+ package Foo;
+ use metaclass;
+ sub foo {}
+ Foo->meta->add_attribute('bar');
+}
+
+sub check_meta_sanity {
+ my ($meta, $class) = @_;
+ isa_ok($meta, 'Class::MOP::Class');
+ is($meta->name, $class);
+ ok($meta->has_method('foo'));
+ isa_ok($meta->get_method('foo'), 'Class::MOP::Method');
+ ok($meta->has_attribute('bar'));
+ isa_ok($meta->get_attribute('bar'), 'Class::MOP::Attribute');
+}
+
+can_ok('Foo', 'meta');
+
+my $meta = Foo->meta;
+check_meta_sanity($meta, 'Foo');
+
+is( exception {
+ $meta = $meta->reinitialize($meta->name);
+}, undef );
+check_meta_sanity($meta, 'Foo');
+
+is( exception {
+ $meta = $meta->reinitialize($meta);
+}, undef );
+check_meta_sanity($meta, 'Foo');
+
+like( exception {
+ $meta->reinitialize('');
+}, qr/You must pass a package name or an existing Class::MOP::Package instance/ );
+
+like( exception {
+ $meta->reinitialize($meta->new_object);
+}, qr/You must pass a package name or an existing Class::MOP::Package instance/ );
+
+{
+ package Bar::Meta::Method;
+ use base 'Class::MOP::Method';
+ __PACKAGE__->meta->add_attribute('test', accessor => 'test');
+}
+
+{
+ package Bar::Meta::Attribute;
+ use base 'Class::MOP::Attribute';
+ __PACKAGE__->meta->add_attribute('tset', accessor => 'tset');
+}
+
+{
+ package Bar;
+ use metaclass;
+ Bar->meta->add_method('foo' => Bar::Meta::Method->wrap(sub {}, name => 'foo', package_name => 'Bar'));
+ Bar->meta->add_attribute(Bar::Meta::Attribute->new('bar'));
+}
+
+$meta = Bar->meta;
+check_meta_sanity($meta, 'Bar');
+isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method');
+isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute');
+is( exception {
+ $meta = $meta->reinitialize('Bar');
+}, undef );
+check_meta_sanity($meta, 'Bar');
+isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method');
+isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute');
+
+Bar->meta->get_method('foo')->test('FOO');
+Bar->meta->get_attribute('bar')->tset('OOF');
+
+is(Bar->meta->get_method('foo')->test, 'FOO');
+is(Bar->meta->get_attribute('bar')->tset, 'OOF');
+is( exception {
+ $meta = $meta->reinitialize('Bar');
+}, undef );
+is(Bar->meta->get_method('foo')->test, 'FOO');
+is(Bar->meta->get_attribute('bar')->tset, 'OOF');
+
+{
+ package Baz::Meta::Attribute;
+ use base 'Class::MOP::Attribute';
+}
+
+{
+ package Baz::Meta::Method;
+ use base 'Class::MOP::Method';
+}
+
+{
+ package Baz;
+ use metaclass meta_name => undef;
+
+ sub foo {}
+ Class::MOP::class_of('Baz')->add_attribute('bar');
+}
+
+$meta = Class::MOP::class_of('Baz');
+check_meta_sanity($meta, 'Baz');
+ok(!$meta->get_method('foo')->isa('Baz::Meta::Method'));
+ok(!$meta->get_attribute('bar')->isa('Baz::Meta::Attribute'));
+is( exception {
+ $meta = $meta->reinitialize(
+ 'Baz',
+ attribute_metaclass => 'Baz::Meta::Attribute',
+ method_metaclass => 'Baz::Meta::Method'
+ );
+}, undef );
+check_meta_sanity($meta, 'Baz');
+isa_ok($meta->get_method('foo'), 'Baz::Meta::Method');
+isa_ok($meta->get_attribute('bar'), 'Baz::Meta::Attribute');
+
+{
+ package Quux;
+ use metaclass
+ attribute_metaclass => 'Bar::Meta::Attribute',
+ method_metaclass => 'Bar::Meta::Method';
+
+ sub foo {}
+ Quux->meta->add_attribute('bar');
+}
+
+$meta = Quux->meta;
+check_meta_sanity($meta, 'Quux');
+isa_ok(Quux->meta->get_method('foo'), 'Bar::Meta::Method');
+isa_ok(Quux->meta->get_attribute('bar'), 'Bar::Meta::Attribute');
+like( exception {
+ $meta = $meta->reinitialize(
+ 'Quux',
+ attribute_metaclass => 'Baz::Meta::Attribute',
+ method_metaclass => 'Baz::Meta::Method',
+ );
+}, qr/compatible/ );
+
+{
+ package Quuux::Meta::Attribute;
+ use base 'Class::MOP::Attribute';
+
+ sub install_accessors {}
+}
+
+{
+ package Quuux;
+ use metaclass;
+ sub foo {}
+ Quuux->meta->add_attribute('bar', reader => 'bar');
+}
+
+$meta = Quuux->meta;
+check_meta_sanity($meta, 'Quuux');
+ok($meta->has_method('bar'));
+is( exception {
+ $meta = $meta->reinitialize(
+ 'Quuux',
+ attribute_metaclass => 'Quuux::Meta::Attribute',
+ );
+}, undef );
+check_meta_sanity($meta, 'Quuux');
+ok(!$meta->has_method('bar'));
+
+{
+ package Blah::Meta::Method;
+ use base 'Class::MOP::Method';
+
+ __PACKAGE__->meta->add_attribute('foo', reader => 'foo', default => 'TEST');
+}
+
+{
+ package Blah::Meta::Attribute;
+ use base 'Class::MOP::Attribute';
+
+ __PACKAGE__->meta->add_attribute('oof', reader => 'oof', default => 'TSET');
+}
+
+{
+ package Blah;
+ use metaclass no_meta => 1;
+ sub foo {}
+ Class::MOP::class_of('Blah')->add_attribute('bar');
+}
+
+$meta = Class::MOP::class_of('Blah');
+check_meta_sanity($meta, 'Blah');
+is( exception {
+ $meta = Class::MOP::Class->reinitialize(
+ 'Blah',
+ attribute_metaclass => 'Blah::Meta::Attribute',
+ method_metaclass => 'Blah::Meta::Method',
+ );
+}, undef );
+check_meta_sanity($meta, 'Blah');
+can_ok($meta->get_method('foo'), 'foo');
+is($meta->get_method('foo')->foo, 'TEST');
+can_ok($meta->get_attribute('bar'), 'oof');
+is($meta->get_attribute('bar')->oof, 'TSET');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use Test::Requires {
+ 'SUPER' => 1.10, # skip all if not installed
+};
+
+=pod
+
+This test demonstrates how simple it is to create Scala Style
+Class Mixin Composition. Below is an example taken from the
+Scala web site's example section, and trancoded to Class::MOP.
+
+NOTE:
+We require SUPER for this test to handle the issue with SUPER::
+being determined at compile time.
+
+L<http://scala.epfl.ch/intro/mixin.html>
+
+A class can only be used as a mixin in the definition of another
+class, if this other class extends a subclass of the superclass
+of the mixin. Since ColoredPoint3D extends Point3D and Point3D
+extends Point2D which is the superclass of ColoredPoint2D, the
+code above is well-formed.
+
+ class Point2D(xc: Int, yc: Int) {
+ val x = xc;
+ val y = yc;
+ override def toString() = "x = " + x + ", y = " + y;
+ }
+
+ class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) {
+ val color = c;
+ def setColor(newCol: String): Unit = color = newCol;
+ override def toString() = super.toString() + ", col = " + color;
+ }
+
+ class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) {
+ val z = zc;
+ override def toString() = super.toString() + ", z = " + z;
+ }
+
+ class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String)
+ extends Point3D(xc, yc, zc)
+ with ColoredPoint2D(xc, yc, col);
+
+
+ Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString())
+
+ "x = 1, y = 2, z = 3, col = blue"
+
+=cut
+
+use Scalar::Util 'blessed';
+use Carp 'confess';
+
+sub ::with ($) {
+ # fetch the metaclass for the
+ # caller and the mixin arg
+ my $metaclass = (caller)->meta;
+ my $mixin = (shift)->meta;
+
+ # according to Scala, the
+ # the superclass of our class
+ # must be a subclass of the
+ # superclass of the mixin (see above)
+ my ($super_meta) = $metaclass->superclasses();
+ my ($super_mixin) = $mixin->superclasses();
+ ($super_meta->isa($super_mixin))
+ || confess "The superclass must extend a subclass of the superclass of the mixin";
+
+ # collect all the attributes
+ # and clone them so they can
+ # associate with the new class
+ my @attributes = map {
+ $mixin->get_attribute($_)->clone()
+ } $mixin->get_attribute_list;
+
+ my %methods = map {
+ my $method = $mixin->get_method($_);
+ # we want to ignore accessors since
+ # they will be created with the attrs
+ (blessed($method) && $method->isa('Class::MOP::Method::Accessor'))
+ ? () : ($_ => $method)
+ } $mixin->get_method_list;
+
+ # NOTE:
+ # I assume that locally defined methods
+ # and attributes get precedence over those
+ # from the mixin.
+
+ # add all the attributes in ....
+ foreach my $attr (@attributes) {
+ $metaclass->add_attribute($attr)
+ unless $metaclass->has_attribute($attr->name);
+ }
+
+ # add all the methods in ....
+ foreach my $method_name (keys %methods) {
+ $metaclass->add_method($method_name => $methods{$method_name})
+ unless $metaclass->has_method($method_name);
+ }
+}
+
+{
+ package Point2D;
+ use metaclass;
+
+ Point2D->meta->add_attribute('$x' => (
+ accessor => 'x',
+ init_arg => 'x',
+ ));
+
+ Point2D->meta->add_attribute('$y' => (
+ accessor => 'y',
+ init_arg => 'y',
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ sub toString {
+ my $self = shift;
+ "x = " . $self->x . ", y = " . $self->y;
+ }
+
+ package ColoredPoint2D;
+ our @ISA = ('Point2D');
+
+ ColoredPoint2D->meta->add_attribute('$color' => (
+ accessor => 'color',
+ init_arg => 'color',
+ ));
+
+ sub toString {
+ my $self = shift;
+ $self->SUPER() . ', col = ' . $self->color;
+ }
+
+ package Point3D;
+ our @ISA = ('Point2D');
+
+ Point3D->meta->add_attribute('$z' => (
+ accessor => 'z',
+ init_arg => 'z',
+ ));
+
+ sub toString {
+ my $self = shift;
+ $self->SUPER() . ', z = ' . $self->z;
+ }
+
+ package ColoredPoint3D;
+ our @ISA = ('Point3D');
+
+ ::with('ColoredPoint2D');
+
+}
+
+my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue');
+isa_ok($colored_point_3d, 'ColoredPoint3D');
+isa_ok($colored_point_3d, 'Point3D');
+isa_ok($colored_point_3d, 'Point2D');
+
+is($colored_point_3d->toString(),
+ 'x = 1, y = 2, z = 3, col = blue',
+ '... got the right toString method');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Scalar::Util qw/isweak reftype/;
+
+use Class::MOP::Instance;
+
+can_ok( "Class::MOP::Instance", $_ ) for qw/
+ new
+
+ create_instance
+ bless_instance_structure
+
+ get_all_slots
+
+ initialize_all_slots
+ deinitialize_all_slots
+
+ get_slot_value
+ set_slot_value
+ initialize_slot
+ deinitialize_slot
+ is_slot_initialized
+ weaken_slot_value
+ strengthen_slot_value
+
+ inline_get_slot_value
+ inline_set_slot_value
+ inline_initialize_slot
+ inline_deinitialize_slot
+ inline_is_slot_initialized
+ inline_weaken_slot_value
+ inline_strengthen_slot_value
+/;
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute('moosen');
+
+ package Bar;
+ use metaclass;
+ use base qw/Foo/;
+
+ Bar->meta->add_attribute('elken');
+}
+
+my $mi_foo = Foo->meta->get_meta_instance;
+isa_ok($mi_foo, "Class::MOP::Instance");
+
+is_deeply(
+ [ $mi_foo->get_all_slots ],
+ [ "moosen" ],
+ '... get all slots for Foo');
+
+my $mi_bar = Bar->meta->get_meta_instance;
+isa_ok($mi_bar, "Class::MOP::Instance");
+
+isnt($mi_foo, $mi_bar, '... they are not the same instance');
+
+is_deeply(
+ [ sort $mi_bar->get_all_slots ],
+ [ "elken", "moosen" ],
+ '... get all slots for Bar');
+
+my $i_foo = $mi_foo->create_instance;
+isa_ok($i_foo, "Foo");
+
+{
+ my $i_foo_2 = $mi_foo->create_instance;
+ isa_ok($i_foo_2, "Foo");
+ isnt($i_foo_2, $i_foo, '... not the same instance');
+ is_deeply($i_foo, $i_foo_2, '... but the same structure');
+}
+
+ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot not initialized");
+
+ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot");
+
+$mi_foo->initialize_slot( $i_foo, "moosen" );
+
+#Removed becayse slot initialization works differently now (groditi)
+#ok($mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot initialized");
+
+ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... but no value for slot");
+
+$mi_foo->set_slot_value( $i_foo, "moosen", "the value" );
+
+is($mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "... get slot value");
+ok(!$i_foo->can('moosen'), '... Foo cant moosen');
+
+my $ref = [];
+
+$mi_foo->set_slot_value( $i_foo, "moosen", $ref );
+$mi_foo->weaken_slot_value( $i_foo, "moosen" );
+
+ok( isweak($i_foo->{moosen}), '... white box test of weaken' );
+is( $mi_foo->get_slot_value( $i_foo, "moosen" ), $ref, "weak value is fetchable" );
+ok( !isweak($mi_foo->get_slot_value( $i_foo, "moosen" )), "return value not weak" );
+
+undef $ref;
+
+is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" );
+
+$ref = [];
+
+$mi_foo->set_slot_value( $i_foo, "moosen", $ref );
+
+undef $ref;
+
+is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "value not weak yet" );
+
+$mi_foo->weaken_slot_value( $i_foo, "moosen" );
+
+is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" );
+
+$ref = [];
+
+$mi_foo->set_slot_value( $i_foo, "moosen", $ref );
+$mi_foo->weaken_slot_value( $i_foo, "moosen" );
+ok( isweak($i_foo->{moosen}), '... white box test of weaken' );
+$mi_foo->strengthen_slot_value( $i_foo, "moosen" );
+ok( !isweak($i_foo->{moosen}), '... white box test of weaken' );
+
+undef $ref;
+
+is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "weak value can be strengthened" );
+
+$mi_foo->deinitialize_slot( $i_foo, "moosen" );
+
+ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot deinitialized");
+
+ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP::Instance;
+
+my $C = 'Class::MOP::Instance';
+
+{
+ my $instance = '$self';
+ my $slot_name = 'foo';
+ my $value = '$value';
+ my $class = '$class';
+
+ is($C->inline_create_instance($class),
+ 'bless {} => $class',
+ '... got the right code for create_instance');
+ is($C->inline_get_slot_value($instance, $slot_name),
+ q[$self->{"foo"}],
+ '... got the right code for get_slot_value');
+
+ is($C->inline_set_slot_value($instance, $slot_name, $value),
+ q[$self->{"foo"} = $value],
+ '... got the right code for set_slot_value');
+
+ is($C->inline_initialize_slot($instance, $slot_name),
+ '',
+ '... got the right code for initialize_slot');
+
+ is($C->inline_is_slot_initialized($instance, $slot_name),
+ q[exists $self->{"foo"}],
+ '... got the right code for get_slot_value');
+
+ is($C->inline_weaken_slot_value($instance, $slot_name),
+ q[Scalar::Util::weaken( $self->{"foo"} )],
+ '... got the right code for weaken_slot_value');
+
+ is($C->inline_strengthen_slot_value($instance, $slot_name),
+ q[$self->{"foo"} = $self->{"foo"}],
+ '... got the right code for strengthen_slot_value');
+ is($C->inline_rebless_instance_structure($instance, $class),
+ q[bless $self => $class],
+ '... got the right code for rebless_instance_structure');
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+my $instance;
+{
+ package Foo;
+
+ sub new {
+ my $class = shift;
+ $instance = bless {@_}, $class;
+ return $instance;
+ }
+
+ sub foo { shift->{foo} }
+}
+
+{
+ package Foo::Sub;
+ use base 'Foo';
+ use metaclass;
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(
+ __INSTANCE__ => $class->SUPER::new(@_),
+ @_,
+ );
+ }
+
+ __PACKAGE__->meta->add_attribute(
+ bar => (
+ reader => 'bar',
+ initializer => sub {
+ my $self = shift;
+ my ($value, $writer, $attr) = @_;
+ $writer->(uc $value);
+ },
+ ),
+ );
+}
+
+undef $instance;
+is( exception {
+ my $foo = Foo::Sub->new;
+ isa_ok($foo, 'Foo');
+ isa_ok($foo, 'Foo::Sub');
+ is($foo, $instance, "used the passed-in instance");
+}, undef );
+
+undef $instance;
+is( exception {
+ my $foo = Foo::Sub->new(foo => 'FOO');
+ isa_ok($foo, 'Foo');
+ isa_ok($foo, 'Foo::Sub');
+ is($foo, $instance, "used the passed-in instance");
+ is($foo->foo, 'FOO', "set non-CMOP constructor args");
+}, undef );
+
+undef $instance;
+is( exception {
+ my $foo = Foo::Sub->new(bar => 'bar');
+ isa_ok($foo, 'Foo');
+ isa_ok($foo, 'Foo::Sub');
+ is($foo, $instance, "used the passed-in instance");
+ is($foo->bar, 'BAR', "set CMOP attributes");
+}, undef );
+
+undef $instance;
+is( exception {
+ my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar');
+ isa_ok($foo, 'Foo');
+ isa_ok($foo, 'Foo::Sub');
+ is($foo, $instance, "used the passed-in instance");
+ is($foo->foo, 'FOO', "set non-CMOP constructor arg");
+ is($foo->bar, 'BAR', "set correct CMOP attribute");
+}, undef );
+
+{
+ package BadFoo;
+
+ sub new {
+ my $class = shift;
+ $instance = bless {@_};
+ return $instance;
+ }
+
+ sub foo { shift->{foo} }
+}
+
+{
+ package BadFoo::Sub;
+ use base 'BadFoo';
+ use metaclass;
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(
+ __INSTANCE__ => $class->SUPER::new(@_),
+ @_,
+ );
+ }
+
+ __PACKAGE__->meta->add_attribute(
+ bar => (
+ reader => 'bar',
+ initializer => sub {
+ my $self = shift;
+ my ($value, $writer, $attr) = @_;
+ $writer->(uc $value);
+ },
+ ),
+ );
+}
+
+like( exception { BadFoo::Sub->new }, qr/BadFoo=HASH.*is not a BadFoo::Sub/, "error with incorrect constructors" );
+
+{
+ my $meta = Class::MOP::Class->create('Really::Bad::Foo');
+ like( exception {
+ $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class'))
+ }, qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, "error with completely invalid class" );
+}
+
+{
+ my $meta = Class::MOP::Class->create('Really::Bad::Foo::2');
+ for my $invalid ('foo', 1, 0, '') {
+ like( exception {
+ $meta->new_object(__INSTANCE__ => $invalid)
+ }, qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, "error with unblessed thing" );
+ }
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->add_attribute('bar');
+
+ package Bar;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Foo');
+
+ __PACKAGE__->meta->add_attribute('baz');
+
+ package Baz;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Bar');
+
+ __PACKAGE__->meta->add_attribute('bah');
+}
+
+{
+ my $meta = Foo->meta;
+ my $original_metaclass_name = ref $meta;
+
+ is_deeply(
+ { $meta->immutable_options }, {},
+ 'immutable_options is empty before a class is made_immutable'
+ );
+
+ $meta->make_immutable;
+
+ my $immutable_metaclass = $meta->_immutable_metaclass->meta;
+
+ my $immutable_class_name = $immutable_metaclass->name;
+
+ ok( !$immutable_class_name->is_mutable, '... immutable_metaclass is not mutable' );
+ ok( $immutable_class_name->is_immutable, '... immutable_metaclass is immutable' );
+ is( $immutable_class_name->meta, $immutable_metaclass,
+ '... immutable_metaclass meta hack works' );
+
+ is_deeply(
+ { $meta->immutable_options },
+ {
+ inline_accessors => 1,
+ inline_constructor => 1,
+ inline_destructor => 0,
+ debug => 0,
+ immutable_trait => 'Class::MOP::Class::Immutable::Trait',
+ constructor_name => 'new',
+ constructor_class => 'Class::MOP::Method::Constructor',
+ destructor_class => undef,
+ },
+ 'immutable_options is empty before a class is made_immutable'
+ );
+
+ isa_ok( $meta, "Class::MOP::Class" );
+}
+
+{
+ my $meta = Foo->meta;
+ is( $meta->name, 'Foo', '... checking the Foo metaclass' );
+
+ ok( !$meta->is_mutable, '... our class is not mutable' );
+ ok( $meta->is_immutable, '... our class is immutable' );
+
+ isa_ok( $meta, 'Class::MOP::Class' );
+
+ isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' );
+
+ isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' );
+
+ isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' );
+
+ is( exception { $meta->identifier() }, undef, '... no exception for get_package_symbol special case' );
+
+ my @supers;
+ is( exception {
+ @supers = $meta->superclasses;
+ }, undef, '... got the superclasses okay' );
+
+ isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' );
+
+ my $meta_instance;
+ is( exception {
+ $meta_instance = $meta->get_meta_instance;
+ }, undef, '... got the meta instance okay' );
+ isa_ok( $meta_instance, 'Class::MOP::Instance' );
+ is( $meta_instance, $meta->get_meta_instance,
+ '... and we know it is cached' );
+
+ my @cpl;
+ is( exception {
+ @cpl = $meta->class_precedence_list;
+ }, undef, '... got the class precedence list okay' );
+ is_deeply(
+ \@cpl,
+ ['Foo'],
+ '... we just have ourselves in the class precedence list'
+ );
+
+ my @attributes;
+ is( exception {
+ @attributes = $meta->get_all_attributes;
+ }, undef, '... got the attribute list okay' );
+ is_deeply(
+ \@attributes,
+ [ $meta->get_attribute('bar') ],
+ '... got the right list of attributes'
+ );
+}
+
+{
+ my $meta = Bar->meta;
+ is( $meta->name, 'Bar', '... checking the Bar metaclass' );
+
+ ok( $meta->is_mutable, '... our class is mutable' );
+ ok( !$meta->is_immutable, '... our class is not immutable' );
+
+ is( exception {
+ $meta->make_immutable();
+ }, undef, '... changed Bar to be immutable' );
+
+ ok( !$meta->make_immutable, '... make immutable now returns nothing' );
+
+ ok( !$meta->is_mutable, '... our class is no longer mutable' );
+ ok( $meta->is_immutable, '... our class is now immutable' );
+
+ isa_ok( $meta, 'Class::MOP::Class' );
+
+ isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' );
+
+ isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' );
+
+ isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' );
+
+ my @supers;
+ is( exception {
+ @supers = $meta->superclasses;
+ }, undef, '... got the superclasses okay' );
+
+ isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' );
+
+ my $meta_instance;
+ is( exception {
+ $meta_instance = $meta->get_meta_instance;
+ }, undef, '... got the meta instance okay' );
+ isa_ok( $meta_instance, 'Class::MOP::Instance' );
+ is( $meta_instance, $meta->get_meta_instance,
+ '... and we know it is cached' );
+
+ my @cpl;
+ is( exception {
+ @cpl = $meta->class_precedence_list;
+ }, undef, '... got the class precedence list okay' );
+ is_deeply(
+ \@cpl,
+ [ 'Bar', 'Foo' ],
+ '... we just have ourselves in the class precedence list'
+ );
+
+ my @attributes;
+ is( exception {
+ @attributes = $meta->get_all_attributes;
+ }, undef, '... got the attribute list okay' );
+ is_deeply(
+ [ sort { $a->name cmp $b->name } @attributes ],
+ [ Foo->meta->get_attribute('bar'), $meta->get_attribute('baz') ],
+ '... got the right list of attributes'
+ );
+}
+
+{
+ my $meta = Baz->meta;
+ is( $meta->name, 'Baz', '... checking the Baz metaclass' );
+
+ ok( $meta->is_mutable, '... our class is mutable' );
+ ok( !$meta->is_immutable, '... our class is not immutable' );
+
+ is( exception {
+ $meta->make_immutable();
+ }, undef, '... changed Baz to be immutable' );
+
+ ok( !$meta->make_immutable, '... make immutable now returns nothing' );
+
+ ok( !$meta->is_mutable, '... our class is no longer mutable' );
+ ok( $meta->is_immutable, '... our class is now immutable' );
+
+ isa_ok( $meta, 'Class::MOP::Class' );
+
+ isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' );
+
+ isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' );
+
+ isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' );
+
+ my @supers;
+ is( exception {
+ @supers = $meta->superclasses;
+ }, undef, '... got the superclasses okay' );
+
+ isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' );
+
+ my $meta_instance;
+ is( exception {
+ $meta_instance = $meta->get_meta_instance;
+ }, undef, '... got the meta instance okay' );
+ isa_ok( $meta_instance, 'Class::MOP::Instance' );
+ is( $meta_instance, $meta->get_meta_instance,
+ '... and we know it is cached' );
+
+ my @cpl;
+ is( exception {
+ @cpl = $meta->class_precedence_list;
+ }, undef, '... got the class precedence list okay' );
+ is_deeply(
+ \@cpl,
+ [ 'Baz', 'Bar', 'Foo' ],
+ '... we just have ourselves in the class precedence list'
+ );
+
+ my @attributes;
+ is( exception {
+ @attributes = $meta->get_all_attributes;
+ }, undef, '... got the attribute list okay' );
+ is_deeply(
+ [ sort { $a->name cmp $b->name } @attributes ],
+ [
+ $meta->get_attribute('bah'), Foo->meta->get_attribute('bar'),
+ Bar->meta->get_attribute('baz')
+ ],
+ '... got the right list of attributes'
+ );
+}
+
+# This test probably needs to go last since it will muck up the Foo class
+{
+ my $meta = Foo->meta;
+
+ $meta->make_mutable;
+ $meta->make_immutable(
+ inline_accessors => 0,
+ inline_constructor => 0,
+ constructor_name => 'newer',
+ );
+
+ is_deeply(
+ { $meta->immutable_options },
+ {
+ inline_accessors => 0,
+ inline_constructor => 0,
+ inline_destructor => 0,
+ debug => 0,
+ immutable_trait => 'Class::MOP::Class::Immutable::Trait',
+ constructor_name => 'newer',
+ constructor_class => 'Class::MOP::Method::Constructor',
+ destructor_class => undef,
+ },
+ 'custom immutable_options are returned by immutable_options accessor'
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin;
+use File::Spec::Functions;
+
+use Test::More;
+use Test::Fatal;
+use Scalar::Util;
+
+use Class::MOP;
+
+use lib catdir( $FindBin::Bin, 'lib' );
+
+{
+
+ package Foo;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->make_immutable;
+
+ package Bar;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->make_immutable;
+
+ package Baz;
+
+ use strict;
+ use warnings;
+ use metaclass 'MyMetaClass';
+
+ sub mymetaclass_attributes {
+ shift->meta->mymetaclass_attributes;
+ }
+
+ ::is( ::exception { Baz->meta->superclasses('Bar') }, undef, '... we survive the metaclass incompatibility test' );
+}
+
+{
+ my $meta = Baz->meta;
+ ok( $meta->is_mutable, '... Baz is mutable' );
+ is(
+ Scalar::Util::blessed( Foo->meta ),
+ Scalar::Util::blessed( Bar->meta ),
+ 'Foo and Bar immutable metaclasses match'
+ );
+ is( Scalar::Util::blessed($meta), 'MyMetaClass',
+ 'Baz->meta blessed as MyMetaClass' );
+ ok( Baz->can('mymetaclass_attributes'),
+ '... Baz can do method before immutable' );
+ ok( $meta->can('mymetaclass_attributes'),
+ '... meta can do method before immutable' );
+ is( exception { $meta->make_immutable }, undef, "Baz is now immutable" );
+ ok( $meta->is_immutable, '... Baz is immutable' );
+ isa_ok( $meta, 'MyMetaClass', 'Baz->meta' );
+ ok( Baz->can('mymetaclass_attributes'),
+ '... Baz can do method after imutable' );
+ ok( $meta->can('mymetaclass_attributes'),
+ '... meta can do method after immutable' );
+ isnt( Scalar::Util::blessed( Baz->meta ),
+ Scalar::Util::blessed( Bar->meta ),
+ 'Baz and Bar immutable metaclasses are different' );
+ is( exception { $meta->make_mutable }, undef, "Baz is now mutable" );
+ ok( $meta->is_mutable, '... Baz is mutable again' );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->add_attribute('bar' => (
+ reader => 'bar',
+ default => 'BAR',
+ ));
+
+ package Bar;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Foo');
+
+ __PACKAGE__->meta->add_attribute('baz' => (
+ reader => 'baz',
+ default => sub { 'BAZ' },
+ ));
+
+ package Baz;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Bar');
+
+ __PACKAGE__->meta->add_attribute('bah' => (
+ reader => 'bah',
+ default => 'BAH',
+ ));
+
+ package Buzz;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+
+ __PACKAGE__->meta->add_attribute('bar' => (
+ accessor => 'bar',
+ predicate => 'has_bar',
+ clearer => 'clear_bar',
+ ));
+
+ __PACKAGE__->meta->add_attribute('bah' => (
+ accessor => 'bah',
+ predicate => 'has_bah',
+ clearer => 'clear_bah',
+ default => 'BAH'
+ ));
+
+}
+
+{
+ my $meta = Foo->meta;
+ is($meta->name, 'Foo', '... checking the Foo metaclass');
+
+ {
+ my $bar_accessor = $meta->get_method('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
+ }
+
+ ok(!$meta->is_immutable, '... our class is not immutable');
+
+ is( exception {
+ $meta->make_immutable(
+ inline_constructor => 1,
+ inline_accessors => 0,
+ );
+ }, undef, '... changed Foo to be immutable' );
+
+ ok($meta->is_immutable, '... our class is now immutable');
+ isa_ok($meta, 'Class::MOP::Class');
+
+ # they made a constructor for us :)
+ can_ok('Foo', 'new');
+
+ {
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+ is($foo->bar, 'BAR', '... got the right default value');
+ }
+
+ {
+ my $foo = Foo->new(bar => 'BAZ');
+ isa_ok($foo, 'Foo');
+ is($foo->bar, 'BAZ', '... got the right parameter value');
+ }
+
+ # NOTE:
+ # check that the constructor correctly handles inheritance
+ {
+ my $bar = Bar->new();
+ isa_ok($bar, 'Bar');
+ isa_ok($bar, 'Foo');
+ is($bar->bar, 'BAR', '... got the right inherited parameter value');
+ is($bar->baz, 'BAZ', '... got the right inherited parameter value');
+ }
+
+ # check out accessors too
+ {
+ my $bar_accessor = $meta->get_method('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
+ }
+}
+
+{
+ my $meta = Bar->meta;
+ is($meta->name, 'Bar', '... checking the Bar metaclass');
+
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
+
+ my $baz_accessor = $meta->get_method('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+
+ ok(!$meta->is_immutable, '... our class is not immutable');
+
+ is( exception {
+ $meta->make_immutable(
+ inline_constructor => 1,
+ inline_accessors => 1,
+ );
+ }, undef, '... changed Bar to be immutable' );
+
+ ok($meta->is_immutable, '... our class is now immutable');
+ isa_ok($meta, 'Class::MOP::Class');
+
+ # they made a constructor for us :)
+ can_ok('Bar', 'new');
+
+ {
+ my $bar = Bar->new;
+ isa_ok($bar, 'Bar');
+ is($bar->bar, 'BAR', '... got the right default value');
+ is($bar->baz, 'BAZ', '... got the right default value');
+ }
+
+ {
+ my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!');
+ isa_ok($bar, 'Bar');
+ is($bar->bar, 'BAZ!', '... got the right parameter value');
+ is($bar->baz, 'BAR!', '... got the right parameter value');
+ }
+
+ # check out accessors too
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
+
+ my $baz_accessor = $meta->get_method('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok($baz_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+}
+
+{
+ my $meta = Baz->meta;
+ is($meta->name, 'Baz', '... checking the Bar metaclass');
+
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
+
+ my $baz_accessor = $meta->find_method_by_name('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok($baz_accessor->is_inline, '... the baz accessor is inlined');
+
+ my $bah_accessor = $meta->get_method('bah');
+ isa_ok($bah_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bah_accessor, 'Class::MOP::Method');
+
+ ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+
+ ok(!$meta->is_immutable, '... our class is not immutable');
+
+ is( exception {
+ $meta->make_immutable(
+ inline_constructor => 0,
+ inline_accessors => 1,
+ );
+ }, undef, '... changed Bar to be immutable' );
+
+ ok($meta->is_immutable, '... our class is now immutable');
+ isa_ok($meta, 'Class::MOP::Class');
+
+ ok(!Baz->meta->has_method('new'), '... no constructor was made');
+
+ {
+ my $baz = Baz->meta->new_object;
+ isa_ok($baz, 'Bar');
+ is($baz->bar, 'BAR', '... got the right default value');
+ is($baz->baz, 'BAZ', '... got the right default value');
+ }
+
+ {
+ my $baz = Baz->meta->new_object(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!');
+ isa_ok($baz, 'Baz');
+ is($baz->bar, 'BAZ!', '... got the right parameter value');
+ is($baz->baz, 'BAR!', '... got the right parameter value');
+ is($baz->bah, 'BAH!', '... got the right parameter value');
+ }
+
+ # check out accessors too
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
+
+ my $baz_accessor = $meta->find_method_by_name('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok($baz_accessor->is_inline, '... the baz accessor is not inlined');
+
+ my $bah_accessor = $meta->get_method('bah');
+ isa_ok($bah_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bah_accessor, 'Class::MOP::Method');
+
+ ok($bah_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+}
+
+
+{
+ my $buzz;
+ ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' );
+ ::ok(!$buzz->has_bar, '...bar is not set');
+ ::is($buzz->bar, undef, '...bar returns undef');
+ ::ok(!$buzz->has_bar, '...bar was not autovivified');
+
+ $buzz->bar(undef);
+ ::ok($buzz->has_bar, '...bar is set');
+ ::is($buzz->bar, undef, '...bar is undef');
+ $buzz->clear_bar;
+ ::ok(!$buzz->has_bar, '...bar is no longerset');
+
+ my $buzz2;
+ ::is( ::exception { $buzz2 = Buzz->meta->new_object('bar' => undef) }, undef, '...Buzz instantiated successfully' );
+ ::ok($buzz2->has_bar, '...bar is set');
+ ::is($buzz2->bar, undef, '...bar is undef');
+
+}
+
+{
+ my $buzz;
+ ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' );
+ ::ok($buzz->has_bah, '...bah is set');
+ ::is($buzz->bah, 'BAH', '...bah returns "BAH"' );
+
+ my $buzz2;
+ ::is( ::exception { $buzz2 = Buzz->meta->new_object('bah' => undef) }, undef, '...Buzz instantiated successfully' );
+ ::ok($buzz2->has_bah, '...bah is set');
+ ::is($buzz2->bah, undef, '...bah is undef');
+
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Scalar::Util;
+
+use Class::MOP;
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->add_attribute('bar');
+
+ package Bar;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Foo');
+
+ __PACKAGE__->meta->add_attribute('baz');
+
+ package Baz;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Bar');
+
+ __PACKAGE__->meta->add_attribute('bah');
+}
+
+{
+ my $meta = Baz->meta;
+ is($meta->name, 'Baz', '... checking the Baz metaclass');
+ my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta;
+ # Since this has no default it won't be present yet, but it will
+ # be after the class is made immutable.
+
+ is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable' );
+ ok(!$meta->is_mutable, '... our class is no longer mutable');
+ ok($meta->is_immutable, '... our class is now immutable');
+ ok(!$meta->make_immutable, '... make immutable now returns nothing');
+ ok($meta->get_method('new'), '... inlined constructor created');
+ ok($meta->has_method('new'), '... inlined constructor created for sure');
+ is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it');
+
+ is( exception { $meta->make_mutable; }, undef, '... changed Baz to be mutable' );
+ ok($meta->is_mutable, '... our class is mutable');
+ ok(!$meta->is_immutable, '... our class is not immutable');
+ ok(!$meta->make_mutable, '... make mutable now returns nothing');
+ ok(!$meta->get_method('new'), '... inlined constructor created');
+ ok(!$meta->has_method('new'), '... inlined constructor removed for sure');
+
+ my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta;
+ is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys');
+
+ isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class');
+
+ $meta->add_method('xyz', sub{'xxx'});
+ is( Baz->xyz, 'xxx', '... method xyz works');
+
+ ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute');
+ ok(Baz->can('fickle'), '... Baz can fickle');
+ ok($meta->remove_attribute('fickle'), '... removed attribute');
+
+ my $reef = \ 'reef';
+ $meta->add_package_symbol('$ref', $reef);
+ is($meta->get_package_symbol('$ref'), $reef, '... values match');
+ is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' );
+ isnt($meta->get_package_symbol('$ref'), $reef, '... values match');
+
+ ok( my @supers = $meta->superclasses, '... got the superclasses okay');
+ ok( $meta->superclasses('Foo'), '... set the superclasses');
+ is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay');
+ ok( $meta->superclasses( @supers ), '... reset superclasses');
+ is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay');
+
+ ok( $meta->$_ , "... ${_} works")
+ for qw(get_meta_instance get_all_attributes
+ class_precedence_list );
+
+ is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable again' );
+ ok($meta->get_method('new'), '... inlined constructor recreated');
+}
+
+{
+ my $meta = Baz->meta;
+
+ is( exception { $meta->make_immutable() }, undef, 'Changed Baz to be immutable' );
+ is( exception { $meta->make_mutable() }, undef, '... changed Baz to be mutable' );
+ is( exception { $meta->make_immutable() }, undef, '... changed Baz to be immutable' );
+
+ isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' );
+
+ isnt( exception {
+ $meta->add_attribute('fickle', accessor => 'fickle')
+ }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' );
+
+ my $reef = \ 'reef';
+ isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' );
+
+ ok( my @supers = $meta->superclasses, '... got the superclasses okay');
+ isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' );
+
+ ok( $meta->$_ , "... ${_} works")
+ for qw(get_meta_instance get_all_attributes
+ class_precedence_list );
+}
+
+{
+
+ ok(Baz->meta->is_immutable, 'Superclass is immutable');
+ my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']);
+ my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta;
+ my @orig_meths = sort { $a->name cmp $b->name } $meta->get_all_methods;
+ ok($meta->is_anon_class, 'We have an anon metaclass');
+ ok($meta->is_mutable, '... our anon class is mutable');
+ ok(!$meta->is_immutable, '... our anon class is not immutable');
+
+ is( exception {$meta->make_immutable(
+ inline_accessor => 1,
+ inline_destructor => 0,
+ inline_constructor => 1,
+ )
+ }, undef, '... changed class to be immutable' );
+ ok(!$meta->is_mutable, '... our class is no longer mutable');
+ ok($meta->is_immutable, '... our class is now immutable');
+ ok(!$meta->make_immutable, '... make immutable now returns nothing');
+
+ is( exception { $meta->make_mutable }, undef, '... changed Baz to be mutable' );
+ ok($meta->is_mutable, '... our class is mutable');
+ ok(!$meta->is_immutable, '... our class is not immutable');
+ ok(!$meta->make_mutable, '... make mutable now returns nothing');
+ ok($meta->is_anon_class, '... still marked as an anon class');
+ my $instance = $meta->new_object;
+
+ my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta;
+ my @new_meths = sort { $a->name cmp $b->name }
+ $meta->get_all_methods;
+ is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys');
+ is_deeply(\@orig_meths, \@new_meths, '... no straneous methods');
+
+ isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class');
+
+ $meta->add_method('xyz', sub{'xxx'});
+ is( $instance->xyz , 'xxx', '... method xyz works');
+ ok( $meta->remove_method('xyz'), '... removed method');
+
+ ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute');
+ ok($instance->can('fickle'), '... instance can fickle');
+ ok($meta->remove_attribute('fickle'), '... removed attribute');
+
+ my $reef = \ 'reef';
+ $meta->add_package_symbol('$ref', $reef);
+ is($meta->get_package_symbol('$ref'), $reef, '... values match');
+ is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' );
+ isnt($meta->get_package_symbol('$ref'), $reef, '... values match');
+
+ ok( my @supers = $meta->superclasses, '... got the superclasses okay');
+ ok( $meta->superclasses('Foo'), '... set the superclasses');
+ is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay');
+ ok( $meta->superclasses( @supers ), '... reset superclasses');
+ is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay');
+
+ ok( $meta->$_ , "... ${_} works")
+ for qw(get_meta_instance get_all_attributes
+ class_precedence_list );
+};
+
+
+#rerun the same tests on an anon class.. just cause we can.
+{
+ my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']);
+
+ is( exception {$meta->make_immutable(
+ inline_accessor => 1,
+ inline_destructor => 0,
+ inline_constructor => 1,
+ )
+ }, undef, '... changed class to be immutable' );
+ is( exception { $meta->make_mutable() }, undef, '... changed class to be mutable' );
+ is( exception {$meta->make_immutable }, undef, '... changed class to be immutable' );
+
+ isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' );
+
+ isnt( exception {
+ $meta->add_attribute('fickle', accessor => 'fickle')
+ }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' );
+
+ my $reef = \ 'reef';
+ isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' );
+ isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' );
+
+ ok( my @supers = $meta->superclasses, '... got the superclasses okay');
+ isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' );
+
+ ok( $meta->$_ , "... ${_} works")
+ for qw(get_meta_instance get_all_attributes
+ class_precedence_list );
+}
+
+{
+ Foo->meta->make_immutable;
+ Bar->meta->make_immutable;
+ Bar->meta->make_mutable;
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+
+ package My::Meta;
+
+ use strict;
+ use warnings;
+
+ use base 'Class::MOP::Class';
+
+ sub initialize {
+ shift->SUPER::initialize(
+ @_,
+ immutable_trait => 'My::Meta::Class::Immutable::Trait',
+ );
+ }
+}
+
+{
+ package My::Meta::Class::Immutable::Trait;
+
+ use MRO::Compat;
+ use base 'Class::MOP::Class::Immutable::Trait';
+
+ sub another_method { 42 }
+
+ sub superclasses {
+ my $orig = shift;
+ my $self = shift;
+ $self->$orig(@_);
+ }
+}
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->add_attribute('foo');
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ package Bar;
+
+ use strict;
+ use warnings;
+ use metaclass 'My::Meta';
+
+ use base 'Foo';
+
+ __PACKAGE__->meta->add_attribute('bar');
+
+ ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'can safely make a class immutable when it has a custom metaclass and immutable trait' );
+}
+
+{
+ can_ok( Bar->meta, 'another_method' );
+ is( Bar->meta->another_method, 42, 'another_method returns expected value' );
+ is_deeply(
+ [ Bar->meta->superclasses ], ['Foo'],
+ 'Bar->meta->superclasses returns expected value after immutabilization'
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+use Class::MOP::Package;
+
+
+isnt( exception { Class::MOP::Package->get_all_package_symbols }, undef, q{... can't call get_all_package_symbols() as a class method} );
+isnt( exception { Class::MOP::Package->name }, undef, q{... can't call name() as a class method} );
+
+{
+ package Foo;
+
+ use constant SOME_CONSTANT => 1;
+
+ sub meta { Class::MOP::Package->initialize('Foo') }
+}
+
+# ----------------------------------------------------------------------
+## tests adding a HASH
+
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
+ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees');
+ok(!defined($Foo::{foo}), '... checking doesn\' vivify');
+
+is( exception {
+ Foo->meta->add_package_symbol('%foo' => { one => 1 });
+}, undef, '... created %Foo::foo successfully' );
+
+# ... scalar should NOT be created here
+
+ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too');
+
+ok(defined($Foo::{foo}), '... the %foo slot was created successfully');
+ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees');
+
+# check the value ...
+
+{
+ no strict 'refs';
+ ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly');
+ is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly');
+}
+
+my $foo = Foo->meta->get_package_symbol('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+# ... make sure changes propogate up
+
+$foo->{two} = 2;
+
+{
+ no strict 'refs';
+ is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas');
+
+ ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
+ is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
+}
+
+# ----------------------------------------------------------------------
+## test adding an ARRAY
+
+ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
+
+is( exception {
+ Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully' );
+
+ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
+ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees');
+
+# ... why does this not work ...
+
+ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too');
+
+# check the value itself
+
+{
+ no strict 'refs';
+ is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly');
+ is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly');
+}
+
+# ----------------------------------------------------------------------
+## test adding a SCALAR
+
+ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet');
+
+is( exception {
+ Foo->meta->add_package_symbol('$baz' => 10);
+}, undef, '... created $Foo::baz successfully' );
+
+ok(defined($Foo::{baz}), '... the $baz slot was created successfully');
+ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees');
+
+ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too');
+
+is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back');
+
+{
+ no strict 'refs';
+ ${'Foo::baz'} = 1;
+
+ is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly');
+ is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees');
+}
+
+# ----------------------------------------------------------------------
+## test adding a CODE
+
+ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
+
+is( exception {
+ Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" });
+}, undef, '... created &Foo::funk successfully' );
+
+ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
+ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees');
+
+ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too');
+ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too');
+
+{
+ no strict 'refs';
+ ok(defined &{'Foo::funk'}, '... our &funk exists');
+}
+
+is(Foo->funk(), 'Foo::funk', '... got the right value from the function');
+
+# ----------------------------------------------------------------------
+## test multiple slots in the glob
+
+my $ARRAY = [ 1, 2, 3 ];
+my $CODE = sub { "Foo::foo" };
+
+is( exception {
+ Foo->meta->add_package_symbol('@foo' => $ARRAY);
+}, undef, '... created @Foo::foo successfully' );
+
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully');
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+is( exception {
+ Foo->meta->add_package_symbol('&foo' => $CODE);
+}, undef, '... created &Foo::foo successfully' );
+
+ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees');
+is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+
+is( exception {
+ Foo->meta->add_package_symbol('$foo' => 'Foo::foo');
+}, undef, '... created $Foo::foo successfully' );
+
+ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees');
+my $SCALAR = Foo->meta->get_package_symbol('$foo');
+is($$SCALAR, 'Foo::foo', '... got the right scalar value back');
+
+{
+ no strict 'refs';
+ is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar');
+}
+
+is( exception {
+ Foo->meta->remove_package_symbol('%foo');
+}, undef, '... removed %Foo::foo successfully' );
+
+ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully');
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists');
+ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists');
+ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists');
+
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+}
+
+is( exception {
+ Foo->meta->remove_package_symbol('&foo');
+}, undef, '... removed &Foo::foo successfully' );
+
+ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists');
+
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists');
+ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists');
+
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+}
+
+is( exception {
+ Foo->meta->remove_package_symbol('$foo');
+}, undef, '... removed $Foo::foo successfully' );
+
+ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists');
+
+ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists');
+
+is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+}
+
+# get_all_package_symbols
+
+{
+ my $syms = Foo->meta->get_all_package_symbols;
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort Foo->meta->list_all_package_symbols ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+}
+
+{
+ my $syms = Foo->meta->get_all_package_symbols('CODE');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort Foo->meta->list_all_package_symbols('CODE') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, Foo->meta->get_package_symbol('&' . $symbol), '... got the right symbol');
+ }
+}
+
+{
+ Foo->meta->add_package_symbol('%zork');
+
+ my $syms = Foo->meta->get_all_package_symbols('HASH');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort Foo->meta->list_all_package_symbols('HASH') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, Foo->meta->get_package_symbol('%' . $symbol), '... got the right symbol');
+ }
+
+ no warnings 'once';
+ is_deeply(
+ $syms,
+ { zork => \%Foo::zork },
+ "got the right ones",
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package My::Package::Stash;
+ use strict;
+ use warnings;
+
+ use base 'Package::Stash';
+
+ use metaclass;
+
+ use Symbol 'gensym';
+
+ __PACKAGE__->meta->add_attribute(
+ 'namespace' => (
+ reader => 'namespace',
+ default => sub { {} }
+ )
+ );
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_));
+ }
+
+ sub add_symbol {
+ my ($self, $variable, $initial_value) = @_;
+
+ (my $name = $variable) =~ s/^[\$\@\%\&]//;
+
+ my $glob = gensym();
+ *{$glob} = $initial_value if defined $initial_value;
+ $self->namespace->{$name} = *{$glob};
+ }
+}
+
+{
+ package My::Meta::Package;
+
+ use strict;
+ use warnings;
+
+ use base 'Class::MOP::Package';
+
+ sub _package_stash {
+ $_[0]->{_package_stash} ||= My::Package::Stash->new($_[0]->name);
+ }
+}
+
+# No actually package Foo exists :)
+my $meta = My::Meta::Package->initialize('Foo');
+
+isa_ok($meta, 'My::Meta::Package');
+isa_ok($meta, 'Class::MOP::Package');
+
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
+ok(!$meta->has_package_symbol('%foo'), '... the meta agrees');
+
+is( exception {
+ $meta->add_package_symbol('%foo' => { one => 1 });
+}, undef, '... the %foo symbol is created succcessfully' );
+
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package');
+ok($meta->has_package_symbol('%foo'), '... the meta agrees');
+
+my $foo = $meta->get_package_symbol('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+$foo->{two} = 2;
+
+is($foo, $meta->get_package_symbol('%foo'), '... our %foo is the same as the metas');
+
+ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
+
+is( exception {
+ $meta->add_package_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully' );
+
+ok(!defined($Foo::{bar}), '... the @bar slot has still not been created');
+
+ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet');
+
+is( exception {
+ $meta->add_package_symbol('%baz');
+}, undef, '... created %Foo::baz successfully' );
+
+ok(!defined($Foo::{baz}), '... the %baz slot has still not been created');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Sub::Name 'subname';
+
+BEGIN {
+ $^P &= ~0x200; # Don't munge anonymous sub names
+}
+
+use Class::MOP;
+
+
+sub code_name_is {
+ my ( $code, $stash, $name ) = @_;
+
+ is_deeply(
+ [ Class::MOP::get_code_info($code) ],
+ [ $stash, $name ],
+ "sub name is ${stash}::$name"
+ );
+}
+
+code_name_is( sub {}, main => "__ANON__" );
+
+code_name_is( subname("Foo::bar", sub {}), Foo => "bar" );
+
+code_name_is( subname("", sub {}), "main" => "" );
+
+require Class::MOP::Method;
+code_name_is( \&Class::MOP::Method::name, "Class::MOP::Method", "name" );
+
+{
+ package Foo;
+
+ sub MODIFY_CODE_ATTRIBUTES {
+ my ($class, $code) = @_;
+ my @info = Class::MOP::get_code_info($code);
+
+ if ( $] >= 5.011 ) {
+ ::is_deeply(\@info, ['Foo', 'foo'], "got a name for a code ref in an attr handler");
+ }
+ else {
+ ::is_deeply(\@info, [], "no name for a coderef that's still compiling");
+ }
+ return ();
+ }
+
+ sub foo : Bar {}
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin;
+use File::Spec::Functions;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+use lib catdir($FindBin::Bin, 'lib');
+
+isnt( exception {
+ Class::MOP::is_class_loaded()
+}, undef, "is_class_loaded with no argument dies" );
+
+ok(!Class::MOP::is_class_loaded(''), "can't load the empty class");
+ok(!Class::MOP::is_class_loaded(\"foo"), "can't load a class name reference??");
+
+ok(!Class::MOP::_is_valid_class_name(undef), 'undef is not a valid class name');
+ok(!Class::MOP::_is_valid_class_name(''), 'empty string is not a valid class name');
+ok(!Class::MOP::_is_valid_class_name(\"foo"), 'a reference is not a valid class name');
+ok(!Class::MOP::_is_valid_class_name('bogus name'), q{'bogus name' is not a valid class name});
+ok(Class::MOP::_is_valid_class_name('Foo'), q{'Foo' is a valid class name});
+ok(Class::MOP::_is_valid_class_name('Foo::Bar'), q{'Foo::Bar' is a valid class name});
+ok(Class::MOP::_is_valid_class_name('Foo_::Bar2'), q{'Foo_::Bar2' is a valid class name});
+like( exception { Class::MOP::load_class('bogus name') }, qr/Invalid class name \(bogus name\)/ );
+
+like( exception {
+ Class::MOP::load_class('__PACKAGE__')
+}, qr/__PACKAGE__\.pm.*\@INC/, 'errors sanely on __PACKAGE__.pm' );
+
+Class::MOP::load_class('BinaryTree');
+can_ok('BinaryTree' => 'traverse');
+
+do {
+ package Class;
+ sub method {}
+};
+
+
+{
+ local $@;
+ eval { Class::MOP::load_class('Class') };
+ ok( ! $@, 'load_class does not die if the package is already defined' );
+}
+
+ok( !Class::MOP::does_metaclass_exist("Class"), "no metaclass for non MOP class" );
+
+like( exception {
+ Class::MOP::load_class('FakeClassOhNo');
+}, qr/Can't locate / );
+
+like( exception {
+ Class::MOP::load_class('SyntaxError');
+}, qr/Missing right curly/ );
+
+like( exception {
+ delete $INC{'SyntaxError.pm'};
+ Class::MOP::load_first_existing_class(
+ 'FakeClassOhNo', 'SyntaxError', 'Class'
+ );
+}, qr/Missing right curly/, 'load_first_existing_class does not pass over an existing (bad) module' );
+
+like( exception {
+ Class::MOP::load_class('This::Does::Not::Exist');
+}, qr{Can't locate This/Does/Not/Exist\.pm in \@INC}, 'load_first_existing_class throws a familiar error for a single module' );
+
+{
+ package Other;
+ use constant foo => "bar";
+}
+
+is( exception {
+ ok(Class::MOP::is_class_loaded("Other"), 'is_class_loaded(Other)');
+}, undef, "a class with just constants is still a class" );
+
+{
+ package Lala;
+ use metaclass;
+}
+
+is( exception {
+ is(Class::MOP::load_first_existing_class("Lala", "Does::Not::Exist"), "Lala", 'load_first_existing_class 1/2 params ok, class name returned');
+ is(Class::MOP::load_first_existing_class("Does::Not::Exist", "Lala"), "Lala", 'load_first_existing_class 2/2 params ok, class name returned');
+}, undef, 'load_classes works' );
+
+like( exception {
+ Class::MOP::load_first_existing_class("Does::Not::Exist", "Also::Does::Not::Exist")
+}, qr/Does::Not::Exist.*Also::Does::Not::Exist/s, 'Multiple non-existant classes cause exception' );
+
+{
+ sub whatever {
+ TestClassLoaded::this_method_does_not_even_exist();
+ }
+
+ ok( ! Class::MOP::is_class_loaded('TestClassLoaded'),
+ 'the mere mention of TestClassLoaded in the whatever sub does not make us think it has been loaded' );
+}
+
+{
+ require TestClassLoaded::Sub;
+ ok( ! Class::MOP::is_class_loaded('TestClassLoaded'),
+ 'requiring TestClassLoaded::Sub does not make us think TestClassLoaded is loaded' );
+}
+
+{
+ require TestClassLoaded;
+ ok( Class::MOP::is_class_loaded('TestClassLoaded'),
+ 'We see that TestClassLoaded is loaded after requiring it (it has methods but no $VERSION or @ISA)' );
+}
+
+{
+ require TestClassLoaded2;
+ ok( Class::MOP::is_class_loaded('TestClassLoaded2'),
+ 'We see that TestClassLoaded2 is loaded after requiring it (it has a $VERSION but no methods or @ISA)' );
+}
+
+{
+ require TestClassLoaded3;
+ ok( Class::MOP::is_class_loaded('TestClassLoaded3'),
+ 'We see that TestClassLoaded3 is loaded after requiring it (it has an @ISA but no methods or $VERSION)' );
+}
+
+{
+ {
+ package Not::Loaded;
+ our @ISA;
+ }
+
+ ok( ! Class::MOP::is_class_loaded('Not::Loaded'),
+ 'the mere existence of an @ISA for a package does not mean a class is loaded' );
+}
+
+{
+ {
+ package Loaded::Ish;
+ our @ISA = 'Foo';
+ }
+
+ ok( Class::MOP::is_class_loaded('Loaded::Ish'),
+ 'an @ISA with members does mean a class is loaded' );
+}
+
+{
+ {
+ package Class::WithVersion;
+ our $VERSION = 23;
+ };
+
+ ok( Class::MOP::is_class_loaded('Class::WithVersion', { -version => 13 }),
+ 'version 23 satisfies version requirement 13' );
+
+ ok( !Class::MOP::is_class_loaded('Class::WithVersion', { -version => 42 }),
+ 'version 23 does not satisfy version requirement 42' );
+
+ like( exception {
+ Class::MOP::load_first_existing_class('Affe', 'Tiger', 'Class::WithVersion' => { -version => 42 });
+ }, qr/Class::WithVersion version 42 required--this is only version 23/, 'load_first_existing_class gives correct exception on old version' );
+
+ is( exception {
+ Class::MOP::load_first_existing_class('Affe', 'Tiger', 'Class::WithVersion' => { -version => 13 });
+ }, undef, 'loading class with required version with load_first_existing_class' );
+
+ like( exception {
+ Class::MOP::load_class('Class::WithVersion' => { -version => 42 });
+ }, qr/Class::WithVersion version 42 required--this is only version 23/, 'load_class gives correct exception on old version' );
+
+ is( exception {
+ Class::MOP::load_class('Class::WithVersion' => { -version => 13 });
+ }, undef, 'loading class with required version with load_class' );
+
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin;
+use File::Spec::Functions;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+use lib catdir($FindBin::Bin, 'lib');
+
+is( exception {
+ Class::MOP::load_class('TestClassLoaded::Sub');
+}, undef );
+
+TestClassLoaded->can('a_method');
+
+is( exception {
+ Class::MOP::load_class('TestClassLoaded');
+}, undef );
+
+is( exception {
+ TestClassLoaded->a_method;
+}, undef );
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Class::MOP;
+
+my @calls;
+
+do {
+ package My::Meta::Class;
+ use base 'Class::MOP::Class';
+
+ sub rebless_instance_away {
+ push @calls, [@_];
+ shift->SUPER::rebless_instance_away(@_);
+ }
+};
+
+do {
+ package Parent;
+ use metaclass 'My::Meta::Class';
+
+ package Child;
+ use metaclass 'My::Meta::Class';
+ use base 'Parent';
+};
+
+my $person = Parent->meta->new_object;
+Child->meta->rebless_instance($person);
+
+is(@calls, 1, "one call to rebless_instance_away");
+is($calls[0][0]->name, 'Parent', 'rebless_instance_away is called on the old metaclass');
+is($calls[0][1], $person, 'with the instance');
+is($calls[0][2]->name, 'Child', 'and the new metaclass');
+splice @calls;
+
+Child->meta->rebless_instance($person, foo => 1);
+is($calls[0][0]->name, 'Child');
+is($calls[0][1], $person);
+is($calls[0][2]->name, 'Child');
+is($calls[0][3], 'foo');
+is($calls[0][4], 1);
+splice @calls;
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Class::MOP;
+
+do {
+ package Grandparent;
+ use metaclass;
+
+ package Parent;
+ use metaclass;
+ use base 'Grandparent';
+
+ package Uncle;
+ use metaclass;
+ use base 'Grandparent';
+
+ package Son;
+ use metaclass;
+ use base 'Parent';
+
+ package Daughter;
+ use metaclass;
+ use base 'Parent';
+
+ package Cousin;
+ use metaclass;
+ use base 'Uncle';
+};
+
+is_deeply([sort Grandparent->meta->subclasses], ['Cousin', 'Daughter', 'Parent', 'Son', 'Uncle']);
+is_deeply([sort Parent->meta->subclasses], ['Daughter', 'Son']);
+is_deeply([sort Uncle->meta->subclasses], ['Cousin']);
+is_deeply([sort Son->meta->subclasses], []);
+is_deeply([sort Daughter->meta->subclasses], []);
+is_deeply([sort Cousin->meta->subclasses], []);
+
+is_deeply([sort Grandparent->meta->direct_subclasses], ['Parent', 'Uncle']);
+is_deeply([sort Parent->meta->direct_subclasses], ['Daughter', 'Son']);
+is_deeply([sort Uncle->meta->direct_subclasses], ['Cousin']);
+is_deeply([sort Son->meta->direct_subclasses], []);
+is_deeply([sort Daughter->meta->direct_subclasses], []);
+is_deeply([sort Cousin->meta->direct_subclasses], []);
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+use Class::MOP;
+
+{
+ can_ok('Class::MOP::Class', 'meta');
+ isa_ok(Class::MOP::Class->meta->find_method_by_name('meta'),
+ 'Class::MOP::Method::Meta');
+
+ {
+ package Baz;
+ use metaclass;
+ }
+ can_ok('Baz', 'meta');
+ isa_ok(Baz->meta->find_method_by_name('meta'),
+ 'Class::MOP::Method::Meta');
+
+ my $meta = Class::MOP::Class->create('Quux');
+ can_ok('Quux', 'meta');
+ isa_ok(Quux->meta->find_method_by_name('meta'),
+ 'Class::MOP::Method::Meta');
+}
+
+{
+ {
+ package Blarg;
+ use metaclass meta_name => 'blarg';
+ }
+ ok(!Blarg->can('meta'));
+ can_ok('Blarg', 'blarg');
+ isa_ok(Blarg->blarg->find_method_by_name('blarg'),
+ 'Class::MOP::Method::Meta');
+
+ my $meta = Class::MOP::Class->create('Blorg', meta_name => 'blorg');
+ ok(!Blorg->can('meta'));
+ can_ok('Blorg', 'blorg');
+ isa_ok(Blorg->blorg->find_method_by_name('blorg'),
+ 'Class::MOP::Method::Meta');
+}
+
+{
+ {
+ package Foo;
+ use metaclass meta_name => undef;
+ }
+
+ my $meta = Class::MOP::class_of('Foo');
+ ok(!$meta->has_method('meta'), "no meta method was installed");
+ $meta->add_method(meta => sub { die 'META' });
+ is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" );
+ is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" );
+ is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" );
+}
+
+{
+ my $meta = Class::MOP::Class->create('Bar', meta_name => undef);
+ ok(!$meta->has_method('meta'), "no meta method was installed");
+ $meta->add_method(meta => sub { die 'META' });
+ is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" );
+ is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" );
+ is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin;
+use File::Spec::Functions;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+use lib catdir($FindBin::Bin, 'lib');
+
+## ----------------------------------------------------------------------------
+## These are all tests which are derived from the Tree::Binary test suite
+## ----------------------------------------------------------------------------
+
+ok(!Class::MOP::is_class_loaded('BinaryTree'), '... the binary tree class is not loaded');
+
+is( exception {
+ Class::MOP::load_class('BinaryTree');
+}, undef, '... loaded the BinaryTree class without dying' );
+
+ok(Class::MOP::is_class_loaded('BinaryTree'), '... the binary tree class is now loaded');
+
+## ----------------------------------------------------------------------------
+## t/10_Tree_Binary_test.t
+
+can_ok("BinaryTree", 'new');
+can_ok("BinaryTree", 'setLeft');
+can_ok("BinaryTree", 'setRight');
+
+my $btree = BinaryTree->new("/")
+ ->setLeft(
+ BinaryTree->new("+")
+ ->setLeft(
+ BinaryTree->new("2")
+ )
+ ->setRight(
+ BinaryTree->new("2")
+ )
+ )
+ ->setRight(
+ BinaryTree->new("*")
+ ->setLeft(
+ BinaryTree->new("4")
+ )
+ ->setRight(
+ BinaryTree->new("5")
+ )
+ );
+isa_ok($btree, 'BinaryTree');
+
+## informational methods
+
+can_ok($btree, 'isRoot');
+ok($btree->isRoot(), '... this is the root');
+
+can_ok($btree, 'isLeaf');
+ok(!$btree->isLeaf(), '... this is not a leaf node');
+ok($btree->getLeft()->getLeft()->isLeaf(), '... this is a leaf node');
+
+can_ok($btree, 'hasLeft');
+ok($btree->hasLeft(), '... this has a left node');
+
+can_ok($btree, 'hasRight');
+ok($btree->hasRight(), '... this has a right node');
+
+## accessors
+
+can_ok($btree, 'getUID');
+
+{
+ my $UID = $btree->getUID();
+ is(("$btree" =~ /\((.*?)\)$/)[0], $UID, '... our UID is derived from the stringified object');
+}
+
+can_ok($btree, 'getNodeValue');
+is($btree->getNodeValue(), '/', '... got what we expected');
+
+{
+ can_ok($btree, 'getLeft');
+ my $left = $btree->getLeft();
+
+ isa_ok($left, 'BinaryTree');
+
+ is($left->getNodeValue(), '+', '... got what we expected');
+
+ can_ok($left, 'getParent');
+
+ my $parent = $left->getParent();
+ isa_ok($parent, 'BinaryTree');
+
+ is($parent, $btree, '.. got what we expected');
+}
+
+{
+ can_ok($btree, 'getRight');
+ my $right = $btree->getRight();
+
+ isa_ok($right, 'BinaryTree');
+
+ is($right->getNodeValue(), '*', '... got what we expected');
+
+ can_ok($right, 'getParent');
+
+ my $parent = $right->getParent();
+ isa_ok($parent, 'BinaryTree');
+
+ is($parent, $btree, '.. got what we expected');
+}
+
+## mutators
+
+can_ok($btree, 'setUID');
+$btree->setUID("Our UID for this tree");
+
+is($btree->getUID(), 'Our UID for this tree', '... our UID is not what we expected');
+
+can_ok($btree, 'setNodeValue');
+$btree->setNodeValue('*');
+
+is($btree->getNodeValue(), '*', '... got what we expected');
+
+
+{
+ can_ok($btree, 'removeLeft');
+ my $left = $btree->removeLeft();
+ isa_ok($left, 'BinaryTree');
+
+ ok(!$btree->hasLeft(), '... we dont have a left node anymore');
+ ok(!$btree->isLeaf(), '... and we are not a leaf node');
+
+ $btree->setLeft($left);
+
+ ok($btree->hasLeft(), '... we have our left node again');
+ is($btree->getLeft(), $left, '... and it is what we told it to be');
+}
+
+{
+ # remove left leaf
+ my $left_leaf = $btree->getLeft()->removeLeft();
+ isa_ok($left_leaf, 'BinaryTree');
+
+ ok($left_leaf->isLeaf(), '... our left leaf is a leaf');
+
+ ok(!$btree->getLeft()->hasLeft(), '... we dont have a left leaf node anymore');
+
+ $btree->getLeft()->setLeft($left_leaf);
+
+ ok($btree->getLeft()->hasLeft(), '... we have our left leaf node again');
+ is($btree->getLeft()->getLeft(), $left_leaf, '... and it is what we told it to be');
+}
+
+{
+ can_ok($btree, 'removeRight');
+ my $right = $btree->removeRight();
+ isa_ok($right, 'BinaryTree');
+
+ ok(!$btree->hasRight(), '... we dont have a right node anymore');
+ ok(!$btree->isLeaf(), '... and we are not a leaf node');
+
+ $btree->setRight($right);
+
+ ok($btree->hasRight(), '... we have our right node again');
+ is($btree->getRight(), $right, '... and it is what we told it to be')
+}
+
+{
+ # remove right leaf
+ my $right_leaf = $btree->getRight()->removeRight();
+ isa_ok($right_leaf, 'BinaryTree');
+
+ ok($right_leaf->isLeaf(), '... our right leaf is a leaf');
+
+ ok(!$btree->getRight()->hasRight(), '... we dont have a right leaf node anymore');
+
+ $btree->getRight()->setRight($right_leaf);
+
+ ok($btree->getRight()->hasRight(), '... we have our right leaf node again');
+ is($btree->getRight()->getRight(), $right_leaf, '... and it is what we told it to be');
+}
+
+# some of the recursive informational methods
+
+{
+
+ my $btree = BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setRight(BinaryTree->new("o"))
+ )
+ )
+ )
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setRight(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ )
+ )
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ ->setRight(BinaryTree->new("o"))
+ )
+ );
+ isa_ok($btree, 'BinaryTree');
+
+ can_ok($btree, 'size');
+ cmp_ok($btree->size(), '==', 14, '... we have 14 nodes in the tree');
+
+ can_ok($btree, 'height');
+ cmp_ok($btree->height(), '==', 6, '... the tree is 6 nodes tall');
+
+}
+
+## ----------------------------------------------------------------------------
+## t/13_Tree_Binary_mirror_test.t
+
+sub inOrderTraverse {
+ my $tree = shift;
+ my @results;
+ my $_inOrderTraverse = sub {
+ my ($tree, $traversal_function) = @_;
+ $traversal_function->($tree->getLeft(), $traversal_function) if $tree->hasLeft();
+ push @results => $tree->getNodeValue();
+ $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight();
+ };
+ $_inOrderTraverse->($tree, $_inOrderTraverse);
+ @results;
+}
+
+# test it on a simple well balanaced tree
+{
+ my $btree = BinaryTree->new(4)
+ ->setLeft(
+ BinaryTree->new(2)
+ ->setLeft(
+ BinaryTree->new(1)
+ )
+ ->setRight(
+ BinaryTree->new(3)
+ )
+ )
+ ->setRight(
+ BinaryTree->new(6)
+ ->setLeft(
+ BinaryTree->new(5)
+ )
+ ->setRight(
+ BinaryTree->new(7)
+ )
+ );
+ isa_ok($btree, 'BinaryTree');
+
+ is_deeply(
+ [ inOrderTraverse($btree) ],
+ [ 1 .. 7 ],
+ '... check that our tree starts out correctly');
+
+ can_ok($btree, 'mirror');
+ $btree->mirror();
+
+ is_deeply(
+ [ inOrderTraverse($btree) ],
+ [ reverse(1 .. 7) ],
+ '... check that our tree ends up correctly');
+}
+
+# test is on a more chaotic tree
+{
+ my $btree = BinaryTree->new(4)
+ ->setLeft(
+ BinaryTree->new(20)
+ ->setLeft(
+ BinaryTree->new(1)
+ ->setRight(
+ BinaryTree->new(10)
+ ->setLeft(
+ BinaryTree->new(5)
+ )
+ )
+ )
+ ->setRight(
+ BinaryTree->new(3)
+ )
+ )
+ ->setRight(
+ BinaryTree->new(6)
+ ->setLeft(
+ BinaryTree->new(5)
+ ->setRight(
+ BinaryTree->new(7)
+ ->setLeft(
+ BinaryTree->new(90)
+ )
+ ->setRight(
+ BinaryTree->new(91)
+ )
+ )
+ )
+ );
+ isa_ok($btree, 'BinaryTree');
+
+ my @results = inOrderTraverse($btree);
+
+ $btree->mirror();
+
+ is_deeply(
+ [ inOrderTraverse($btree) ],
+ [ reverse(@results) ],
+ '... this should be the reverse of the original');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+
+use Class::MOP;
+
+BEGIN {
+ require_ok(File::Spec->catfile('examples', 'InstanceCountingClass.pod'));
+}
+
+=pod
+
+This is a trivial and contrived example of how to
+make a metaclass which will count all the instances
+created. It is not meant to be anything more than
+a simple demonstration of how to make a metaclass.
+
+=cut
+
+{
+ package Foo;
+
+ use metaclass 'InstanceCountingClass';
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+
+ our @ISA = ('Foo');
+}
+
+is(Foo->meta->get_count(), 0, '... our Foo count is 0');
+is(Bar->meta->get_count(), 0, '... our Bar count is 0');
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is(Foo->meta->get_count(), 1, '... our Foo count is now 1');
+is(Bar->meta->get_count(), 0, '... our Bar count is still 0');
+
+my $bar = Bar->new();
+isa_ok($bar, 'Bar');
+
+is(Foo->meta->get_count(), 1, '... our Foo count is still 1');
+is(Bar->meta->get_count(), 1, '... our Bar count is now 1');
+
+for (2 .. 10) {
+ Foo->new();
+}
+
+is(Foo->meta->get_count(), 10, '... our Foo count is now 10');
+is(Bar->meta->get_count(), 1, '... our Bar count is still 1');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+use Scalar::Util 'reftype';
+
+BEGIN {use Class::MOP;
+ require_ok(File::Spec->catfile('examples', 'InsideOutClass.pod'));
+}
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+
+ use metaclass (
+ 'attribute_metaclass' => 'InsideOutClass::Attribute',
+ 'instance_metaclass' => 'InsideOutClass::Instance'
+ );
+
+ Foo->meta->add_attribute('foo' => (
+ accessor => 'foo',
+ predicate => 'has_foo',
+ ));
+
+ Foo->meta->add_attribute('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ default => 'FOO is BAR'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+ use metaclass (
+ 'attribute_metaclass' => 'InsideOutClass::Attribute',
+ 'instance_metaclass' => 'InsideOutClass::Instance'
+ );
+
+ use strict;
+ use warnings;
+
+ use base 'Foo';
+
+ Bar->meta->add_attribute('baz' => (
+ accessor => 'baz',
+ predicate => 'has_baz',
+ ));
+
+ package Baz;
+
+ use strict;
+ use warnings;
+ use metaclass (
+ 'attribute_metaclass' => 'InsideOutClass::Attribute',
+ 'instance_metaclass' => 'InsideOutClass::Instance'
+ );
+
+ Baz->meta->add_attribute('bling' => (
+ accessor => 'bling',
+ default => 'Baz::bling'
+ ));
+
+ package Bar::Baz;
+ use metaclass (
+ 'attribute_metaclass' => 'InsideOutClass::Attribute',
+ 'instance_metaclass' => 'InsideOutClass::Instance'
+ );
+
+ use strict;
+ use warnings;
+
+ use base 'Bar', 'Baz';
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is(reftype($foo), 'SCALAR', '... Foo is made with SCALAR');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'has_foo');
+can_ok($foo, 'get_bar');
+can_ok($foo, 'set_bar');
+
+ok(!$foo->has_foo, '... Foo::foo is not defined yet');
+is($foo->foo(), undef, '... Foo::foo is not defined yet');
+is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized');
+
+$foo->foo('This is Foo');
+
+ok($foo->has_foo, '... Foo::foo is defined now');
+is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"');
+
+$foo->set_bar(42);
+is($foo->get_bar(), 42, '... Foo::bar == 42');
+
+my $foo2 = Foo->new();
+isa_ok($foo2, 'Foo');
+
+is(reftype($foo2), 'SCALAR', '... Foo is made with SCALAR');
+
+ok(!$foo2->has_foo, '... Foo2::foo is not defined yet');
+is($foo2->foo(), undef, '... Foo2::foo is not defined yet');
+is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized');
+
+$foo2->set_bar('DONT PANIC');
+is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC');
+
+is($foo->get_bar(), 42, '... Foo::bar == 42');
+
+# now Bar ...
+
+my $bar = Bar->new();
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is(reftype($bar), 'SCALAR', '... Bar is made with SCALAR');
+
+can_ok($bar, 'foo');
+can_ok($bar, 'has_foo');
+can_ok($bar, 'get_bar');
+can_ok($bar, 'set_bar');
+can_ok($bar, 'baz');
+can_ok($bar, 'has_baz');
+
+ok(!$bar->has_foo, '... Bar::foo is not defined yet');
+is($bar->foo(), undef, '... Bar::foo is not defined yet');
+is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized');
+ok(!$bar->has_baz, '... Bar::baz is not defined yet');
+is($bar->baz(), undef, '... Bar::baz is not defined yet');
+
+$bar->foo('This is Bar::foo');
+
+ok($bar->has_foo, '... Bar::foo is defined now');
+is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"');
+is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized');
+
+$bar->baz('This is Bar::baz');
+
+ok($bar->has_baz, '... Bar::baz is defined now');
+is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"');
+is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"');
+is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized');
+
+# now Baz ...
+
+my $baz = Bar::Baz->new();
+isa_ok($baz, 'Bar::Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+isa_ok($baz, 'Baz');
+
+is(reftype($baz), 'SCALAR', '... Bar::Baz is made with SCALAR');
+
+can_ok($baz, 'foo');
+can_ok($baz, 'has_foo');
+can_ok($baz, 'get_bar');
+can_ok($baz, 'set_bar');
+can_ok($baz, 'baz');
+can_ok($baz, 'has_baz');
+can_ok($baz, 'bling');
+
+is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized');
+is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized');
+
+ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet');
+is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet');
+ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet');
+is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet');
+
+$baz->foo('This is Bar::Baz::foo');
+
+ok($baz->has_foo, '... Bar::Baz::foo is defined now');
+is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"');
+is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized');
+is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized');
+
+$baz->baz('This is Bar::Baz::baz');
+
+ok($baz->has_baz, '... Bar::Baz::baz is defined now');
+is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"');
+is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"');
+is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized');
+is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized');
+
+{
+ no strict 'refs';
+
+ ok(*{'Foo::foo'}{HASH}, '... there is a foo package variable in Foo');
+ ok(*{'Foo::bar'}{HASH}, '... there is a bar package variable in Foo');
+
+ is(scalar(keys(%{'Foo::foo'})), 4, '... got the right number of entries for Foo::foo');
+ is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar');
+
+ ok(!*{'Bar::foo'}{HASH}, '... no foo package variable in Bar');
+ ok(!*{'Bar::bar'}{HASH}, '... no bar package variable in Bar');
+ ok(*{'Bar::baz'}{HASH}, '... there is a baz package variable in Bar');
+
+ is(scalar(keys(%{'Bar::foo'})), 0, '... got the right number of entries for Bar::foo');
+ is(scalar(keys(%{'Bar::bar'})), 0, '... got the right number of entries for Bar::bar');
+ is(scalar(keys(%{'Bar::baz'})), 2, '... got the right number of entries for Bar::baz');
+
+ ok(*{'Baz::bling'}{HASH}, '... there is a bar package variable in Baz');
+
+ is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling');
+
+ ok(!*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz');
+ ok(!*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz');
+ ok(!*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz');
+ ok(!*{'Bar::Baz::bling'}{HASH}, '... no bar package variable in Baz::Baz');
+
+ is(scalar(keys(%{'Bar::Baz::foo'})), 0, '... got the right number of entries for Bar::Baz::foo');
+ is(scalar(keys(%{'Bar::Baz::bar'})), 0, '... got the right number of entries for Bar::Baz::bar');
+ is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz');
+ is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+
+use Class::MOP;
+
+BEGIN {
+ require_ok(File::Spec->catfile('examples', 'Perl6Attribute.pod'));
+}
+
+{
+ package Foo;
+
+ use metaclass;
+
+ Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
+ Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));
+ Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'bar');
+can_ok($foo, 'baz');
+
+is($foo->foo, undef, '... Foo.foo == undef');
+
+$foo->foo(42);
+is($foo->foo, 42, '... Foo.foo == 42');
+
+is_deeply($foo->bar, [], '... Foo.bar == []');
+is_deeply($foo->baz, {}, '... Foo.baz == {}');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+
+use Class::MOP;
+
+BEGIN {
+ require_ok(File::Spec->catfile('examples', 'AttributesWithHistory.pod'));
+}
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('foo' => (
+ accessor => 'foo',
+ history_accessor => 'get_foo_history',
+ )));
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ history_accessor => 'get_bar_history',
+ )));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'get_foo_history');
+can_ok($foo, 'set_bar');
+can_ok($foo, 'get_bar');
+can_ok($foo, 'get_bar_history');
+
+my $foo2 = Foo->new();
+isa_ok($foo2, 'Foo');
+
+is($foo->foo, undef, '... foo is not yet defined');
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ ],
+ '... got correct empty history for foo');
+
+is($foo2->foo, undef, '... foo2 is not yet defined');
+is_deeply(
+ [ $foo2->get_foo_history() ],
+ [ ],
+ '... got correct empty history for foo2');
+
+$foo->foo(42);
+is($foo->foo, 42, '... foo == 42');
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42 ],
+ '... got correct history for foo');
+
+is($foo2->foo, undef, '... foo2 is still not yet defined');
+is_deeply(
+ [ $foo2->get_foo_history() ],
+ [ ],
+ '... still got correct empty history for foo2');
+
+$foo2->foo(100);
+is($foo->foo, 42, '... foo is still == 42');
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42 ],
+ '... still got correct history for foo');
+
+is($foo2->foo, 100, '... foo2 == 100');
+is_deeply(
+ [ $foo2->get_foo_history() ],
+ [ 100 ],
+ '... got correct empty history for foo2');
+
+$foo->foo(43);
+$foo->foo(44);
+$foo->foo(45);
+$foo->foo(46);
+
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42, 43, 44, 45, 46 ],
+ '... got correct history for foo');
+
+is($foo->get_bar, undef, '... bar is not yet defined');
+is_deeply(
+ [ $foo->get_bar_history() ],
+ [ ],
+ '... got correct empty history for foo');
+
+
+$foo->set_bar("FOO");
+is($foo->get_bar, "FOO", '... bar == "FOO"');
+is_deeply(
+ [ $foo->get_bar_history() ],
+ [ "FOO" ],
+ '... got correct history for foo');
+
+$foo->set_bar("BAR");
+$foo->set_bar("BAZ");
+
+is_deeply(
+ [ $foo->get_bar_history() ],
+ [ qw/FOO BAR BAZ/ ],
+ '... got correct history for bar');
+
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42, 43, 44, 45, 46 ],
+ '... still have the correct history for foo');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+
+use Class::MOP;
+
+BEGIN {
+ require_ok(File::Spec->catfile('examples', 'ClassEncapsulatedAttributes.pod'));
+}
+
+{
+ package Foo;
+
+ use metaclass 'ClassEncapsulatedAttributes';
+
+ Foo->meta->add_attribute('foo' => (
+ accessor => 'foo',
+ predicate => 'has_foo',
+ default => 'init in FOO'
+ ));
+
+ Foo->meta->add_attribute('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ default => 'init in FOO'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ Bar->meta->add_attribute('foo' => (
+ accessor => 'foo',
+ predicate => 'has_foo',
+ default => 'init in BAR'
+ ));
+
+ Bar->meta->add_attribute('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ default => 'init in BAR'
+ ));
+
+ sub SUPER_foo { (shift)->SUPER::foo(@_) }
+ sub SUPER_has_foo { (shift)->SUPER::foo(@_) }
+ sub SUPER_get_bar { (shift)->SUPER::get_bar() }
+ sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) }
+
+}
+
+{
+ my $foo = Foo->new();
+ isa_ok($foo, 'Foo');
+
+ can_ok($foo, 'foo');
+ can_ok($foo, 'has_foo');
+ can_ok($foo, 'get_bar');
+ can_ok($foo, 'set_bar');
+
+ my $bar = Bar->new();
+ isa_ok($bar, 'Bar');
+
+ can_ok($bar, 'foo');
+ can_ok($bar, 'has_foo');
+ can_ok($bar, 'get_bar');
+ can_ok($bar, 'set_bar');
+
+ ok($foo->has_foo, '... Foo::has_foo == 1');
+ ok($bar->has_foo, '... Bar::has_foo == 1');
+
+ is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo');
+ is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo');
+
+ is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo');
+
+ $bar->SUPER_foo(undef);
+
+ is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo');
+ ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0');
+
+ ok($foo->has_foo, '... Foo::has_foo (is still) 1');
+}
+
+{
+ my $bar = Bar->new(
+ 'Foo' => { 'foo' => 'Foo::foo' },
+ 'Bar' => { 'foo' => 'Bar::foo' }
+ );
+ isa_ok($bar, 'Bar');
+
+ can_ok($bar, 'foo');
+ can_ok($bar, 'has_foo');
+ can_ok($bar, 'get_bar');
+ can_ok($bar, 'set_bar');
+
+ ok($bar->has_foo, '... Bar::has_foo == 1');
+ ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1');
+
+ is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo');
+ is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+
+use Class::MOP;
+
+BEGIN {
+ require_ok(File::Spec->catfile('examples', 'LazyClass.pod'));
+}
+
+{
+ package BinaryTree;
+
+ use metaclass (
+ 'attribute_metaclass' => 'LazyClass::Attribute',
+ 'instance_metaclass' => 'LazyClass::Instance',
+ );
+
+ BinaryTree->meta->add_attribute('node' => (
+ accessor => 'node',
+ init_arg => 'node'
+ ));
+
+ BinaryTree->meta->add_attribute('left' => (
+ reader => 'left',
+ default => sub { BinaryTree->new() }
+ ));
+
+ BinaryTree->meta->add_attribute('right' => (
+ reader => 'right',
+ default => sub { BinaryTree->new() }
+ ));
+
+ sub new {
+ my $class = shift;
+ bless $class->meta->new_object(@_) => $class;
+ }
+}
+
+my $root = BinaryTree->new('node' => 0);
+isa_ok($root, 'BinaryTree');
+
+ok(exists($root->{'node'}), '... node attribute has been initialized yet');
+ok(!exists($root->{'left'}), '... left attribute has not been initialized yet');
+ok(!exists($root->{'right'}), '... right attribute has not been initialized yet');
+
+isa_ok($root->left, 'BinaryTree');
+isa_ok($root->right, 'BinaryTree');
+
+ok(exists($root->{'left'}), '... left attribute has now been initialized');
+ok(exists($root->{'right'}), '... right attribute has now been initialized');
+
+ok(!exists($root->left->{'node'}), '... node attribute has not been initialized yet');
+ok(!exists($root->left->{'left'}), '... left attribute has not been initialized yet');
+ok(!exists($root->left->{'right'}), '... right attribute has not been initialized yet');
+
+ok(!exists($root->right->{'node'}), '... node attribute has not been initialized yet');
+ok(!exists($root->right->{'left'}), '... left attribute has not been initialized yet');
+ok(!exists($root->right->{'right'}), '... right attribute has not been initialized yet');
+
+is($root->left->node(), undef, '... the left node is uninitialized');
+
+ok(exists($root->left->{'node'}), '... node attribute has now been initialized');
+
+$root->left->node(1);
+is($root->left->node(), 1, '... the left node == 1');
+
+ok(!exists($root->left->{'left'}), '... left attribute still has not been initialized yet');
+ok(!exists($root->left->{'right'}), '... right attribute still has not been initialized yet');
+
+is($root->right->node(), undef, '... the right node is uninitialized');
+
+ok(exists($root->right->{'node'}), '... node attribute has now been initialized');
+
+$root->right->node(2);
+is($root->right->node(), 2, '... the right node == 1');
+
+ok(!exists($root->right->{'left'}), '... left attribute still has not been initialized yet');
+ok(!exists($root->right->{'right'}), '... right attribute still has not been initialized yet');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+use Class::MOP;
+
+use Test::Requires {
+ 'Algorithm::C3' => '0.01', # skip all if not installed
+};
+
+BEGIN {
+ require_ok(File::Spec->catfile('examples', 'C3MethodDispatchOrder.pod'));
+}
+
+{
+ package Diamond_A;
+ use metaclass 'C3MethodDispatchOrder';
+
+ sub hello { 'Diamond_A::hello' }
+
+ package Diamond_B;
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_A');
+
+ package Diamond_C;
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_A');
+
+ sub hello { 'Diamond_C::hello' }
+
+ package Diamond_D;
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C');
+}
+
+is_deeply(
+ [ Diamond_D->meta->class_precedence_list ],
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order');
+is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+use Scalar::Util 'reftype';
+use Class::MOP;
+
+BEGIN {
+ require_ok(File::Spec->catfile('examples', 'ArrayBasedStorage.pod'));
+}
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+ use metaclass (
+ 'instance_metaclass' => 'ArrayBasedStorage::Instance',
+ );
+
+ Foo->meta->add_attribute('foo' => (
+ accessor => 'foo',
+ clearer => 'clear_foo',
+ predicate => 'has_foo',
+ ));
+
+ Foo->meta->add_attribute('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ default => 'FOO is BAR'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+ use metaclass (
+ 'instance_metaclass' => 'ArrayBasedStorage::Instance',
+ );
+
+ use strict;
+ use warnings;
+
+ use base 'Foo';
+
+ Bar->meta->add_attribute('baz' => (
+ accessor => 'baz',
+ predicate => 'has_baz',
+ ));
+
+ package Baz;
+ use metaclass (
+ 'instance_metaclass' => 'ArrayBasedStorage::Instance',
+ );
+
+ use strict;
+ use warnings;
+ use metaclass (
+ 'instance_metaclass' => 'ArrayBasedStorage::Instance',
+ );
+
+ Baz->meta->add_attribute('bling' => (
+ accessor => 'bling',
+ default => 'Baz::bling'
+ ));
+
+ package Bar::Baz;
+ use metaclass (
+ 'instance_metaclass' => 'ArrayBasedStorage::Instance',
+ );
+
+ use strict;
+ use warnings;
+
+ use base 'Bar', 'Baz';
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is(reftype($foo), 'ARRAY', '... Foo is made with ARRAY');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'has_foo');
+can_ok($foo, 'get_bar');
+can_ok($foo, 'set_bar');
+can_ok($foo, 'clear_foo');
+
+ok(!$foo->has_foo, '... Foo::foo is not defined yet');
+is($foo->foo(), undef, '... Foo::foo is not defined yet');
+is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized');
+
+$foo->foo('This is Foo');
+
+ok($foo->has_foo, '... Foo::foo is defined now');
+is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"');
+
+$foo->clear_foo;
+
+ok(!$foo->has_foo, '... Foo::foo is not defined anymore');
+is($foo->foo(), undef, '... Foo::foo is not defined anymore');
+
+$foo->set_bar(42);
+is($foo->get_bar(), 42, '... Foo::bar == 42');
+
+my $foo2 = Foo->new();
+isa_ok($foo2, 'Foo');
+
+is(reftype($foo2), 'ARRAY', '... Foo is made with ARRAY');
+
+ok(!$foo2->has_foo, '... Foo2::foo is not defined yet');
+is($foo2->foo(), undef, '... Foo2::foo is not defined yet');
+is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized');
+
+$foo2->set_bar('DONT PANIC');
+is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC');
+
+is($foo->get_bar(), 42, '... Foo::bar == 42');
+
+# now Bar ...
+
+my $bar = Bar->new();
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is(reftype($bar), 'ARRAY', '... Bar is made with ARRAY');
+
+can_ok($bar, 'foo');
+can_ok($bar, 'has_foo');
+can_ok($bar, 'get_bar');
+can_ok($bar, 'set_bar');
+can_ok($bar, 'baz');
+can_ok($bar, 'has_baz');
+
+ok(!$bar->has_foo, '... Bar::foo is not defined yet');
+is($bar->foo(), undef, '... Bar::foo is not defined yet');
+is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized');
+ok(!$bar->has_baz, '... Bar::baz is not defined yet');
+is($bar->baz(), undef, '... Bar::baz is not defined yet');
+
+$bar->foo('This is Bar::foo');
+
+ok($bar->has_foo, '... Bar::foo is defined now');
+is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"');
+is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized');
+
+$bar->baz('This is Bar::baz');
+
+ok($bar->has_baz, '... Bar::baz is defined now');
+is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"');
+is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"');
+is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized');
+
+# now Baz ...
+
+my $baz = Bar::Baz->new();
+isa_ok($baz, 'Bar::Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+isa_ok($baz, 'Baz');
+
+is(reftype($baz), 'ARRAY', '... Bar::Baz is made with ARRAY');
+
+can_ok($baz, 'foo');
+can_ok($baz, 'has_foo');
+can_ok($baz, 'get_bar');
+can_ok($baz, 'set_bar');
+can_ok($baz, 'baz');
+can_ok($baz, 'has_baz');
+can_ok($baz, 'bling');
+
+is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized');
+is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized');
+
+ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet');
+is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet');
+ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet');
+is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet');
+
+$baz->foo('This is Bar::Baz::foo');
+
+ok($baz->has_foo, '... Bar::Baz::foo is defined now');
+is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"');
+is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized');
+is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized');
+
+$baz->baz('This is Bar::Baz::baz');
+
+ok($baz->has_baz, '... Bar::Baz::baz is defined now');
+is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"');
+is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"');
+is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized');
+is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized');
+
+Foo->meta->add_attribute( forgotten => is => "rw" );
+
+my $new_baz = Bar::Baz->new;
+
+cmp_ok( scalar(@$new_baz), ">", scalar(@$baz), "additional slot due to refreshed meta instance" );
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests that Class::MOP works correctly
+with Class::C3 and it's somewhat insane
+approach to method resolution.
+
+=cut
+
+use Class::MOP;
+
+{
+ package Diamond_A;
+ use mro 'c3';
+ use metaclass; # everyone will just inherit this now :)
+
+ sub hello { 'Diamond_A::hello' }
+}
+{
+ package Diamond_B;
+ use mro 'c3';
+ use base 'Diamond_A';
+}
+{
+ package Diamond_C;
+ use mro 'c3';
+ use base 'Diamond_A';
+
+ sub hello { 'Diamond_C::hello' }
+}
+{
+ package Diamond_D;
+ use mro 'c3';
+ use base ('Diamond_B', 'Diamond_C');
+}
+
+# we have to manually initialize
+# Class::C3 since we potentially
+# skip this test if it is not present
+Class::C3::initialize();
+
+is_deeply(
+# [ Class::C3::calculateMRO('Diamond_D') ],
+ [ Diamond_D->meta->class_precedence_list ],
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+ok(Diamond_A->meta->has_method('hello'), '... A has a method hello');
+ok(!Diamond_B->meta->has_method('hello'), '... B does not have a method hello');
+
+ok(Diamond_C->meta->has_method('hello'), '... C has a method hello');
+ok(!Diamond_D->meta->has_method('hello'), '... D does not have a method hello');
+
+SKIP: {
+ skip "C3 does not make aliases on 5.9.5+", 2 if $] > 5.009_004;
+ ok(defined &Diamond_B::hello, '... B does have an alias to the method hello');
+ ok(defined &Diamond_D::hello, '... D does have an alias to the method hello');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use Class::MOP;
+
+=pod
+
+This tests a bug which is fixed in 0.22 by
+localizing all the $@'s around any evals.
+This a real pain to track down.
+
+Moral of the story:
+
+ ALWAYS localize your globals :)
+
+=cut
+
+{
+ package Company;
+ use strict;
+ use warnings;
+ use metaclass;
+
+ sub new {
+ my ($class) = @_;
+ return bless {} => $class;
+ }
+
+ sub employees {
+ die "This didnt work";
+ }
+
+ sub DESTROY {
+ my $self = shift;
+ foreach
+ my $method ( $self->meta->find_all_methods_by_name('DEMOLISH') ) {
+ $method->{code}->($self);
+ }
+ }
+}
+
+eval {
+ my $c = Company->new();
+ $c->employees();
+};
+ok( $@, '... we die correctly with bad args' );
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use Class::MOP;
+
+=pod
+
+This tests a bug sent via RT #27329
+
+=cut
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute('foo' => (
+ init_arg => 'foo',
+ reader => 'get_foo',
+ default => 'BAR',
+ ));
+
+}
+
+my $foo = Foo->meta->new_object;
+isa_ok($foo, 'Foo');
+
+is($foo->get_foo, 'BAR', '... got the right default value');
+
+{
+ my $clone = $foo->meta->clone_object($foo, foo => 'BAZ');
+ isa_ok($clone, 'Foo');
+ isnt($clone, $foo, '... and it is a clone');
+
+ is($clone->get_foo, 'BAZ', '... got the right cloned value');
+}
+
+{
+ my $clone = $foo->meta->clone_object($foo, foo => undef);
+ isa_ok($clone, 'Foo');
+ isnt($clone, $foo, '... and it is a clone');
+
+ ok(!defined($clone->get_foo), '... got the right cloned value');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+my @calls;
+
+{
+ package Parent;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ use Carp 'confess';
+
+ sub method { push @calls, 'Parent::method' }
+
+ package Child;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ use base 'Parent';
+
+ Child->meta->add_around_method_modifier(
+ 'method' => sub {
+ my $orig = shift;
+ push @calls, 'before Child::method';
+ $orig->(@_);
+ push @calls, 'after Child::method';
+ }
+ );
+}
+
+Parent->method;
+
+is_deeply(
+ [ splice @calls ],
+ [
+ 'Parent::method',
+ ]
+);
+
+Child->method;
+
+is_deeply(
+ [ splice @calls ],
+ [
+ 'before Child::method',
+ 'Parent::method',
+ 'after Child::method',
+ ]
+);
+
+{
+ package Parent;
+
+ Parent->meta->add_around_method_modifier(
+ 'method' => sub {
+ my $orig = shift;
+ push @calls, 'before Parent::method';
+ $orig->(@_);
+ push @calls, 'after Parent::method';
+ }
+ );
+}
+
+Parent->method;
+
+is_deeply(
+ [ splice @calls ],
+ [
+ 'before Parent::method',
+ 'Parent::method',
+ 'after Parent::method',
+ ]
+);
+
+Child->method;
+
+TODO: {
+ local $TODO = "pending fix";
+ is_deeply(
+ [ splice @calls ],
+ [
+ 'before Child::method',
+ 'before Parent::method',
+ 'Parent::method',
+ 'after Parent::method',
+ 'after Child::method',
+ ],
+ "cache is correctly invalidated when the parent method is wrapped"
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+=pod
+
+This tests a bug sent via RT #39001
+
+=cut
+
+{
+ package Foo;
+ use metaclass;
+}
+
+like( exception {
+ Foo->meta->superclasses('Foo');
+}, qr/^Recursive inheritance detected/, "error occurs when extending oneself" );
+
+{
+ package Bar;
+ use metaclass;
+}
+
+# reset @ISA, so that calling methods like ->isa won't die (->meta does this
+# if DEBUG_NO_META is set)
+@Foo::ISA = ();
+
+is( exception {
+ Foo->meta->superclasses('Bar');
+}, undef, "regular subclass" );
+
+like( exception {
+ Bar->meta->superclasses('Foo');
+}, qr/^Recursive inheritance detected/, "error occurs when Bar extends Foo, when Foo is a Bar" );
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use Class::MOP;
+
+{
+ package Foo;
+ use constant FOO => 'bar';
+}
+
+my $meta = Class::MOP::Class->initialize('Foo');
+
+my $syms = $meta->get_all_package_symbols('CODE');
+is(ref $syms->{FOO}, 'CODE', 'get constant symbol');
+
+undef $syms;
+
+$syms = $meta->get_all_package_symbols('CODE');
+is(ref $syms->{FOO}, 'CODE', 'constant symbol still there, although we dropped our reference');
+
+done_testing;
--- /dev/null
+use strict;
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+{
+ package BaseClass;
+ sub m1 { 1 }
+ sub m2 { 2 }
+ sub m3 { 3 }
+ sub m4 { 4 }
+ sub m5 { 5 }
+
+ package Derived;
+ use base qw(BaseClass);
+
+ sub m1;
+ sub m2 ();
+ sub m3 :method;
+ sub m4; m4() if 0;
+ sub m5; our $m5;;
+}
+
+my $meta = Class::MOP::Class->initialize('Derived');
+my %methods = map { $_ => $meta->find_method_by_name($_) } 'm1' .. 'm5';
+
+while (my ($name, $meta_method) = each %methods) {
+ is $meta_method->fully_qualified_name, "Derived::${name}";
+ like( exception { $meta_method->execute }, qr/Undefined subroutine .* called at/ );
+}
+
+{
+ package Derived;
+ eval <<'EOC';
+
+ sub m1 { 'affe' }
+ sub m2 () { 'apan' }
+ sub m3 :method { 'tiger' }
+ sub m4 { 'birne' }
+ sub m5 { 'apfel' }
+
+EOC
+}
+
+while (my ($name, $meta_method) = each %methods) {
+ is $meta_method->fully_qualified_name, "Derived::${name}";
+ is( exception { $meta_method->execute }, undef );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Class::MOP;
+
+do {
+ package Without::Overloading;
+ sub new { bless {}, shift }
+
+ package With::Overloading;
+ use base 'Without::Overloading';
+ use overload q{""} => sub { "overloaded" };
+};
+
+my $without = bless {}, "Without::Overloading";
+like("$without", qr/^Without::Overloading/, "no overloading");
+
+my $with = With::Overloading->new;
+is("$with", "overloaded", "initial overloading works");
+
+
+my $meta = Class::MOP::Class->initialize('With::Overloading');
+
+$meta->rebless_instance($without);
+is("$without", "overloaded", "overloading after reblessing works");
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Class::MOP;
+my $non = Class::MOP::Class->initialize('Non::Existent::Package');
+$non->get_method('foo');
+
+pass("empty stashes don't segfault");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Class::MOP;
+
+my $Point = Class::MOP::Class->create('Point' => (
+ version => '0.01',
+ attributes => [
+ Class::MOP::Attribute->new('x' => (
+ reader => 'x',
+ init_arg => 'x'
+ )),
+ Class::MOP::Attribute->new('y' => (
+ accessor => 'y',
+ init_arg => 'y'
+ )),
+ ],
+ methods => {
+ 'new' => sub {
+ my $class = shift;
+ my $instance = $class->meta->new_object(@_);
+ bless $instance => $class;
+ },
+ 'clear' => sub {
+ my $self = shift;
+ $self->{'x'} = 0;
+ $self->{'y'} = 0;
+ }
+ }
+));
+
+is($Point->get_attribute('x')->insertion_order, 0, 'Insertion order of Attribute "x"');
+is($Point->get_attribute('y')->insertion_order, 1, 'Insertion order of Attribute "y"');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use Class::MOP;
+
+{
+
+ package Origin;
+ sub bar { ( caller(0) )[3] }
+
+ package Foo;
+}
+
+my $Foo = Class::MOP::Class->initialize('Foo');
+
+$Foo->add_method( foo => sub { ( caller(0) )[3] } );
+
+is_deeply(
+ [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ],
+ [ "Foo", "foo" ],
+ "subname applied to anonymous method",
+);
+
+is( Foo->foo, "Foo::foo", "caller() aggrees" );
+
+$Foo->add_method( bar => \&Origin::bar );
+
+is( Origin->bar, "Origin::bar", "normal caller() operation in unrelated class" );
+
+is_deeply(
+ [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ],
+ [ "Foo", "foo" ],
+ "subname not applied if a name already exists",
+);
+
+is( Foo->bar, "Origin::bar", "caller aggrees" );
+
+is( Origin->bar, "Origin::bar", "unrelated class untouched" );
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use Test::Requires {
+ 'Test::Output' => '0.01', # skip all if not installed
+};
+
+use Class::MOP;
+
+{
+ package HasConstructor;
+
+ sub new { bless {}, $_[0] }
+
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $meta->superclasses('NotMoose');
+
+ ::stderr_like(
+ sub { $meta->make_immutable },
+ qr/\QNot inlining a constructor for HasConstructor since it defines its own constructor.\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to HasConstructor->meta->make_immutable\E/,
+ 'got a warning that Foo will not have an inlined constructor because it defines its own new method'
+ );
+
+ ::is(
+ $meta->find_method_by_name('new')->body,
+ HasConstructor->can('new'),
+ 'HasConstructor->new was untouched'
+ );
+}
+
+{
+ package My::Constructor;
+
+ use base 'Class::MOP::Method::Constructor';
+
+ sub _expected_method_class { 'Base::Class' }
+}
+
+{
+ package No::Constructor;
+}
+
+{
+ package My::Constructor2;
+
+ use base 'Class::MOP::Method::Constructor';
+
+ sub _expected_method_class { 'No::Constructor' }
+}
+
+{
+ package Base::Class;
+
+ sub new { bless {}, $_[0] }
+ sub DESTROY { }
+}
+
+{
+ package NotMoose;
+
+ sub new {
+ my $class = shift;
+
+ return bless { not_moose => 1 }, $class;
+ }
+}
+
+{
+ package Foo;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $meta->superclasses('NotMoose');
+
+ ::stderr_like(
+ sub { $meta->make_immutable( constructor_class => 'My::Constructor' ) },
+ qr/\QNot inlining 'new' for Foo since it is not inheriting the default Base::Class::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/,
+ 'got a warning that Foo will not have an inlined constructor'
+ );
+
+ ::is(
+ $meta->find_method_by_name('new')->body,
+ NotMoose->can('new'),
+ 'Foo->new is inherited from NotMoose'
+ );
+}
+
+{
+ package Bar;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $meta->superclasses('NotMoose');
+
+ ::stderr_is(
+ sub { $meta->make_immutable( replace_constructor => 1 ) },
+ q{},
+ 'no warning when replace_constructor is true'
+ );
+
+ ::is(
+ $meta->find_method_by_name('new')->package_name,
+ 'Bar',
+ 'Bar->new is inlined, and not inherited from NotMoose'
+ );
+}
+
+{
+ package Baz;
+ Class::MOP::Class->initialize(__PACKAGE__)->make_immutable;
+}
+
+{
+ package Quux;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $meta->superclasses('Baz');
+
+ ::stderr_is(
+ sub { $meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
+
+{
+ package Whatever;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ ::stderr_like(
+ sub { $meta->make_immutable( constructor_class => 'My::Constructor2' ) },
+ qr/\QNot inlining 'new' for Whatever since No::Constructor::new is not defined/,
+ 'got a warning that Whatever will not have an inlined constructor because its expected inherited method does not exist'
+ );
+}
+
+{
+ package My::Constructor3;
+
+ use base 'Class::MOP::Method::Constructor';
+}
+
+{
+ package CustomCons;
+
+ Class::MOP::Class->initialize(__PACKAGE__)->make_immutable( constructor_class => 'My::Constructor3' );
+}
+
+{
+ package Subclass;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $meta->superclasses('CustomCons');
+
+ ::stderr_is(
+ sub { $meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
+
+{
+ package ModdedNew;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ sub new { bless {}, shift }
+
+ $meta->add_before_method_modifier( 'new' => sub { } );
+}
+
+{
+ package ModdedSub;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $meta->superclasses('ModdedNew');
+
+ ::stderr_like(
+ sub { $meta->make_immutable },
+ qr/\QNot inlining 'new' for ModdedSub since it has method modifiers which would be lost if it were inlined/,
+ 'got a warning that ModdedSub will not have an inlined constructor since it inherited a wrapped new'
+ );
+}
+
+{
+ package My::Destructor;
+
+ use base 'Class::MOP::Method::Inlined';
+
+ sub new {
+ my $class = shift;
+ my %options = @_;
+
+ my $self = bless \%options, $class;
+ $self->_inline_destructor;
+
+ return $self;
+ }
+
+ sub _inline_destructor {
+ my $self = shift;
+
+ my $code = $self->_compile_code('sub { }');
+
+ $self->{body} = $code;
+ }
+
+ sub is_needed { 1 }
+ sub associated_metaclass { $_[0]->{metaclass} }
+ sub body { $_[0]->{body} }
+ sub _expected_method_class { 'Base::Class' }
+}
+
+{
+ package HasDestructor;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ sub DESTROY { }
+
+ ::stderr_like(
+ sub {
+ $meta->make_immutable(
+ inline_destructor => 1,
+ destructor_class => 'My::Destructor',
+ );
+ },
+ qr/Not inlining a destructor for HasDestructor since it defines its own destructor./,
+ 'got a warning when trying to inline a destructor for a class that already defines DESTROY'
+ );
+
+ ::is(
+ $meta->find_method_by_name('DESTROY')->body,
+ HasDestructor->can('DESTROY'),
+ 'HasDestructor->DESTROY was untouched'
+ );
+}
+
+{
+ package HasDestructor2;
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ sub DESTROY { }
+
+ $meta->make_immutable(
+ inline_destructor => 1,
+ destructor_class => 'My::Destructor',
+ replace_destructor => 1
+ );
+
+ ::stderr_is(
+ sub {
+ $meta->make_immutable(
+ inline_destructor => 1,
+ destructor_class => 'My::Destructor',
+ replace_destructor => 1
+ );
+ },
+ q{},
+ 'no warning when replace_destructor is true'
+ );
+
+ ::isnt(
+ $meta->find_method_by_name('new')->body,
+ HasConstructor2->can('new'),
+ 'HasConstructor2->new was replaced'
+ );
+}
+
+{
+ package ParentHasDestructor;
+
+ sub DESTROY { }
+}
+
+{
+ package DestructorChild;
+
+ use base 'ParentHasDestructor';
+
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ ::stderr_like(
+ sub {
+ $meta->make_immutable(
+ inline_destructor => 1,
+ destructor_class => 'My::Destructor',
+ );
+ },
+ qr/Not inlining 'DESTROY' for DestructorChild since it is not inheriting the default Base::Class::DESTROY/,
+ 'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY'
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Class::MOP;
+
+
+{
+ package Foo;
+
+ my $meta = Class::MOP::Class->initialize(__PACKAGE__);
+
+ $@ = 'dollar at';
+
+ $meta->make_immutable;
+
+ ::is( $@, 'dollar at', '$@ is untouched after immutablization' );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Class::MOP;
+use Test::More;
+
+use Test::Requires {
+ 'Test::LeakTrace' => '0.01', # skip all if not installed
+};
+
+# 5.10.0 has a bug on weaken($hash_ref) which leaks an AV.
+my $expected = ( $] == 5.010_000 ? 1 : 0 );
+
+leaks_cmp_ok {
+ Class::MOP::Class->create_anon_class();
+}
+'<=', $expected, 'create_anon_class()';
+
+leaks_cmp_ok {
+ Class::MOP::Class->create_anon_class( superclasses => [qw(Exporter)] );
+}
+'<=', $expected, 'create_anon_class(superclass => [...])';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Class::MOP;
+use Class::MOP::Class;
+use Test::More;
+use Test::Fatal;
+
+my %results;
+
+{
+
+ package Base;
+ use metaclass;
+ sub hey { $results{base}++ }
+}
+
+for my $wrap (qw(before after)) {
+ my $meta = Class::MOP::Class->create_anon_class(
+ superclasses => [ 'Base', 'Class::MOP::Object' ] );
+ my $alter = "add_${wrap}_method_modifier";
+ $meta->$alter(
+ 'hey' => sub {
+ $results{wrapped}++;
+ $_ = 'barf'; # 'barf' would replace the cached wrapper subref
+ }
+ );
+
+ %results = ();
+ my $o = $meta->get_meta_instance->create_instance;
+ isa_ok( $o, 'Base' );
+ is( exception {
+ $o->hey;
+ $o->hey
+ ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use'
+ }, undef, 'wrapped doesn\'t die when $_ gets changed' );
+ is_deeply(
+ \%results, { base => 2, wrapped => 2 },
+ 'saw expected calls to wrappers'
+ );
+}
+
+{
+ my $meta = Class::MOP::Class->create_anon_class(
+ superclasses => [ 'Base', 'Class::MOP::Object' ] );
+ for my $wrap (qw(before after)) {
+ my $alter = "add_${wrap}_method_modifier";
+ $meta->$alter(
+ 'hey' => sub {
+ $results{wrapped}++;
+ $_ = 'barf'; # 'barf' would replace the cached wrapper subref
+ }
+ );
+ }
+
+ %results = ();
+ my $o = $meta->get_meta_instance->create_instance;
+ isa_ok( $o, 'Base' );
+ is( exception {
+ $o->hey;
+ $o->hey
+ ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use'
+ }, undef, 'double-wrapped doesn\'t die when $_ gets changed' );
+ is_deeply(
+ \%results, { base => 2, wrapped => 4 },
+ 'saw expected calls to wrappers'
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Class::MOP;
+use Test::More;
+
+{
+ package Foo;
+
+ sub foo { }
+ sub bar { }
+}
+
+my $meta = Class::MOP::Class->initialize('Foo');
+ok( $meta->is_pristine, 'Foo is still pristine' );
+
+$meta->add_method( baz => sub { } );
+ok( $meta->is_pristine, 'Foo is still pristine after add_method' );
+
+$meta->add_attribute( name => 'attr', reader => 'get_attr' );
+ok( ! $meta->is_pristine, 'Foo is not pristine after add_attribute' );
+
+done_testing;
--- /dev/null
+# Testing magical scalars (using tied scalar)
+# Note that XSUBs do not handle magical scalars automatically.
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Class::MOP;
+
+use Tie::Scalar;
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute('bar' =>
+ reader => 'get_bar',
+ writer => 'set_bar',
+ );
+
+ Foo->meta->add_attribute('baz' =>
+ accessor => 'baz',
+ );
+
+ Foo->meta->make_immutable();
+}
+
+{
+ tie my $foo, 'Tie::StdScalar', Foo->new(bar => 100, baz => 200);
+
+ is $foo->get_bar, 100, 'reader with tied self';
+ is $foo->baz, 200, 'accessor/r with tied self';
+
+ $foo->set_bar(300);
+ $foo->baz(400);
+
+ is $foo->get_bar, 300, 'writer with tied self';
+ is $foo->baz, 400, 'accessor/w with tied self';
+}
+
+{
+ my $foo = Foo->new();
+
+ tie my $value, 'Tie::StdScalar', 42;
+
+ $foo->set_bar($value);
+ $foo->baz($value);
+
+ is $foo->get_bar, 42, 'reader/writer with tied value';
+ is $foo->baz, 42, 'accessor with tied value';
+}
+
+{
+ my $x = tie my $value, 'Tie::StdScalar', 'Class::MOP';
+
+ is( exception { Class::MOP::load_class($value) }, undef, 'load_class(tied scalar)' );
+
+ $value = undef;
+ $x->STORE('Class::MOP'); # reset
+
+ is( exception {
+ ok Class::MOP::is_class_loaded($value);
+ }, undef, 'is_class_loaded(tied scalar)' );
+
+ $value = undef;
+ $x->STORE(\&Class::MOP::get_code_info); # reset
+
+ is( exception {
+ is_deeply [Class::MOP::get_code_info($value)], [qw(Class::MOP get_code_info)], 'get_code_info(tied scalar)';
+ }, undef );
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use B;
+use Class::MOP;
+
+my @int_defaults = (
+ 100,
+ -2,
+ 01234,
+ 0xFF,
+);
+
+my @num_defaults = (
+ 10.5,
+ -20.0,
+ 1e3,
+ 1.3e-10,
+);
+
+my @string_defaults = (
+ 'foo',
+ '',
+ '100',
+ '10.5',
+ '1e3',
+ '0 but true',
+ '01234',
+ '09876',
+ '0xFF',
+);
+
+for my $default (@int_defaults) {
+ my $copy = $default; # so we can print it out without modifying flags
+ my $attr = Class::MOP::Attribute->new(
+ foo => (default => $default, reader => 'foo'),
+ );
+ my $meta = Class::MOP::Class->create_anon_class(
+ attributes => [$attr],
+ methods => {bar => sub { $default }},
+ );
+
+ my $obj = $meta->new_object;
+ for my $meth (qw(foo bar)) {
+ my $val = $obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy)");
+ }
+
+ $meta->make_immutable;
+
+ my $immutable_obj = $meta->name->new;
+ for my $meth (qw(foo bar)) {
+ my $val = $immutable_obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy) (immutable)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)");
+ }
+}
+
+for my $default (@num_defaults) {
+ my $copy = $default; # so we can print it out without modifying flags
+ my $attr = Class::MOP::Attribute->new(
+ foo => (default => $default, reader => 'foo'),
+ );
+ my $meta = Class::MOP::Class->create_anon_class(
+ attributes => [$attr],
+ methods => {bar => sub { $default }},
+ );
+
+ my $obj = $meta->new_object;
+ for my $meth (qw(foo bar)) {
+ my $val = $obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy)");
+ }
+
+ $meta->make_immutable;
+
+ my $immutable_obj = $meta->name->new;
+ for my $meth (qw(foo bar)) {
+ my $val = $immutable_obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy) (immutable)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)");
+ }
+}
+
+for my $default (@string_defaults) {
+ my $copy = $default; # so we can print it out without modifying flags
+ my $attr = Class::MOP::Attribute->new(
+ foo => (default => $default, reader => 'foo'),
+ );
+ my $meta = Class::MOP::Class->create_anon_class(
+ attributes => [$attr],
+ methods => {bar => sub { $default }},
+ );
+
+ my $obj = $meta->new_object;
+ for my $meth (qw(foo bar)) {
+ my $val = $obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_POK, "it's a string ($copy)");
+ }
+
+ $meta->make_immutable;
+
+ my $immutable_obj = $meta->name->new;
+ for my $meth (qw(foo bar)) {
+ my $val = $immutable_obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_POK, "it's a string ($copy) (immutable)");
+ }
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Carp;
+
+$SIG{__WARN__} = \&croak;
+
+{
+ package Foo;
+
+ ::like( ::exception {
+ Class::MOP::in_global_destruction();
+ }, qr/\b deprecated \b/xmsi, 'Class::MOP::in_global_destruction is deprecated' );
+}
+
+{
+ package Bar;
+
+ use Class::MOP::Deprecated -api_version => 0.93;
+
+ ::like( ::exception {
+ Class::MOP::in_global_destruction();
+ }, qr/\b deprecated \b/xmsi, 'Class::MOP::in_global_destruction is deprecated with 0.93 compatibility' );
+}
+
+{
+ package Baz;
+
+ use Class::MOP::Deprecated -api_version => 0.92;
+
+ ::is( ::exception {
+ Class::MOP::in_global_destruction();
+ }, undef, 'Class::MOP::in_global_destruction is not deprecated with 0.92 compatibility' );
+}
+
+{
+ package Foo2;
+
+ use metaclass;
+
+ ::like( ::exception { Foo2->meta->get_attribute_map }, qr/\Qget_attribute_map method has been deprecated/, 'get_attribute_map is deprecated' );
+}
+
+{
+ package Quux;
+
+ use Class::MOP::Deprecated -api_version => 0.92;
+ use Scalar::Util qw( blessed );
+
+ use metaclass;
+
+ sub foo {42}
+
+ Quux->meta->add_method( bar => sub {84} );
+
+ my $map = Quux->meta->get_method_map;
+ my @method_objects = grep { blessed($_) } values %{$map};
+
+ ::is(
+ scalar @method_objects, 3,
+ 'get_method_map still returns all values as method object'
+ );
+ ::is_deeply(
+ [ sort keys %{$map} ],
+ [qw( bar foo meta )],
+ 'get_method_map returns expected methods'
+ );
+}
+
+done_testing;
--- /dev/null
+
+package BinaryTree;
+
+use strict;
+use warnings;
+use Carp qw/confess/;
+
+use metaclass;
+
+
+BinaryTree->meta->add_attribute('uid' => (
+ reader => 'getUID',
+ writer => 'setUID',
+ default => sub {
+ my $instance = shift;
+ ("$instance" =~ /\((.*?)\)$/)[0];
+ }
+));
+
+BinaryTree->meta->add_attribute('node' => (
+ reader => 'getNodeValue',
+ writer => 'setNodeValue',
+ clearer => 'clearNodeValue',
+ init_arg => ':node'
+));
+
+BinaryTree->meta->add_attribute('parent' => (
+ predicate => 'hasParent',
+ reader => 'getParent',
+ writer => 'setParent',
+ clearer => 'clearParent',
+));
+
+BinaryTree->meta->add_attribute('left' => (
+ predicate => 'hasLeft',
+ clearer => 'clearLeft',
+ reader => 'getLeft',
+ writer => {
+ 'setLeft' => sub {
+ my ($self, $tree) = @_;
+ confess "undef left" unless defined $tree;
+ $tree->setParent($self) if defined $tree;
+ $self->{'left'} = $tree;
+ $self;
+ }
+ },
+));
+
+BinaryTree->meta->add_attribute('right' => (
+ predicate => 'hasRight',
+ clearer => 'clearRight',
+ reader => 'getRight',
+ writer => {
+ 'setRight' => sub {
+ my ($self, $tree) = @_;
+ confess "undef right" unless defined $tree;
+ $tree->setParent($self) if defined $tree;
+ $self->{'right'} = $tree;
+ $self;
+ }
+ }
+));
+
+sub new {
+ my $class = shift;
+ $class->meta->new_object(':node' => shift);
+}
+
+sub removeLeft {
+ my ($self) = @_;
+ my $left = $self->getLeft();
+ $left->clearParent;
+ $self->clearLeft;
+ return $left;
+}
+
+sub removeRight {
+ my ($self) = @_;
+ my $right = $self->getRight;
+ $right->clearParent;
+ $self->clearRight;
+ return $right;
+}
+
+sub isLeaf {
+ my ($self) = @_;
+ return (!$self->hasLeft && !$self->hasRight);
+}
+
+sub isRoot {
+ my ($self) = @_;
+ return !$self->hasParent;
+}
+
+sub traverse {
+ my ($self, $func) = @_;
+ $func->($self);
+ $self->getLeft->traverse($func) if $self->hasLeft;
+ $self->getRight->traverse($func) if $self->hasRight;
+}
+
+sub mirror {
+ my ($self) = @_;
+ # swap left for right
+ if( $self->hasLeft && $self->hasRight) {
+ my $left = $self->getLeft;
+ my $right = $self->getRight;
+ $self->setLeft($right);
+ $self->setRight($left);
+ } elsif( $self->hasLeft && !$self->hasRight){
+ my $left = $self->getLeft;
+ $self->clearLeft;
+ $self->setRight($left);
+ } elsif( !$self->hasLeft && $self->hasRight){
+ my $right = $self->getRight;
+ $self->clearRight;
+ $self->setLeft($right);
+ }
+
+ # and recurse
+ $self->getLeft->mirror if $self->hasLeft;
+ $self->getRight->mirror if $self->hasRight;
+ $self;
+}
+
+sub size {
+ my ($self) = @_;
+ my $size = 1;
+ $size += $self->getLeft->size if $self->hasLeft;
+ $size += $self->getRight->size if $self->hasRight;
+ return $size;
+}
+
+sub height {
+ my ($self) = @_;
+ my ($left_height, $right_height) = (0, 0);
+ $left_height = $self->getLeft->height() if $self->hasLeft();
+ $right_height = $self->getRight->height() if $self->hasRight();
+ return 1 + (($left_height > $right_height) ? $left_height : $right_height);
+}
+
+1;
--- /dev/null
+
+package MyMetaClass;
+
+use strict;
+use warnings;
+
+use base 'Class::MOP::Class';
+
+sub mymetaclass_attributes{
+ my $self = shift;
+ return grep { $_->isa("MyMetaClass::Attribute") }
+ $self->get_all_attributes;
+}
+
+1;
--- /dev/null
+
+package MyMetaClass::Attribute;
+
+use strict;
+use warnings;
+
+use base 'Class::MOP::Attribute';
+
+1;
--- /dev/null
+
+package MyMetaClass::Instance;
+
+use strict;
+use warnings;
+
+use base 'Class::MOP::Instance';
+
+1;
--- /dev/null
+
+package MyMetaClass::Method;
+
+use strict;
+use warnings;
+
+use base 'Class::MOP::Method';
+
+1;
--- /dev/null
+
+package MyMetaClass::Random;
+
+use strict;
+use warnings;
+
+1;
--- /dev/null
+#!/usr/bin/env perl
+package SyntaxError;
+use strict;
+use warnings;
+
+# this syntax error is intentional!
+
+ {
+
+1;
+
--- /dev/null
+package TestClassLoaded;
+use strict;
+use warnings;
+
+sub a_method { 'a_method' }
+
+1;
+
--- /dev/null
+package TestClassLoaded::Sub;
+use strict;
+use warnings;
+
+sub ver_test { return "TestClassLoaded ver $TestClassLoaded::VERSION" }
+
+1;
--- /dev/null
+package TestClassLoaded2;
+use strict;
+use warnings;
+
+
+1;
+
--- /dev/null
+package TestClassLoaded3;
+use strict;
+use warnings;
+
+our @ISA = 'Foo';
+
+1;
+
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Attribute PACKAGE = Class::MOP::Attribute
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Attribute, associated_class);
+ INSTALL_SIMPLE_READER(Attribute, associated_methods);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Mixin::AttributeCore PACKAGE = Class::MOP::Mixin::AttributeCore
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, name);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, accessor);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, reader);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, writer);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, predicate);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, clearer);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, builder);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, init_arg);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, initializer);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, definition_context);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, insertion_order);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Class, instance_metaclass);
+ INSTALL_SIMPLE_READER(Class, immutable_trait);
+ INSTALL_SIMPLE_READER(Class, constructor_class);
+ INSTALL_SIMPLE_READER(Class, constructor_name);
+ INSTALL_SIMPLE_READER(Class, destructor_class);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Method::Generated PACKAGE = Class::MOP::Method::Generated
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Method::Generated, is_inline);
+ INSTALL_SIMPLE_READER(Method::Generated, definition_context);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Mixin::HasAttributes PACKAGE = Class::MOP::Mixin::HasAttributes
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Mixin::HasAttributes, attribute_metaclass);
+ INSTALL_SIMPLE_READER_WITH_KEY(Mixin::HasAttributes, _attribute_map, attributes);
--- /dev/null
+#include "mop.h"
+
+SV *mop_method_metaclass;
+SV *mop_associated_metaclass;
+SV *mop_wrap;
+
+static void
+mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
+{
+ char *method_name;
+ I32 method_name_len;
+ SV *method;
+ HV *symbols;
+
+ symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
+ sv_2mortal((SV*)symbols);
+
+ (void)hv_iterinit(map);
+ while ((method = hv_iternextsv(map, &method_name, &method_name_len))) {
+ SV *body;
+ SV *stash_slot;
+
+ if (!SvROK(method)) {
+ continue;
+ }
+
+ if (sv_isobject(method)) {
+ /* $method_object->body() */
+ body = mop_call0(aTHX_ method, KEY_FOR(body));
+ }
+ else {
+ body = method;
+ }
+
+ stash_slot = *hv_fetch(symbols, method_name, method_name_len, TRUE);
+ if (SvROK(stash_slot) && ((CV*)SvRV(body)) == ((CV*)SvRV(stash_slot))) {
+ continue;
+ }
+
+ /* $map->{$method_name} = undef */
+ sv_setsv(method, &PL_sv_undef);
+ }
+}
+
+MODULE = Class::MOP::Mixin::HasMethods PACKAGE = Class::MOP::Mixin::HasMethods
+
+PROTOTYPES: DISABLE
+
+void
+_method_map(self)
+ SV *self
+ PREINIT:
+ HV *const obj = (HV *)SvRV(self);
+ SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
+ HV *const stash = gv_stashsv(class_name, 0);
+ UV current;
+ SV *cache_flag;
+ SV *map_ref;
+ PPCODE:
+ if (!stash) {
+ mXPUSHs(newRV_noinc((SV *)newHV()));
+ return;
+ }
+
+ current = mop_check_package_cache_flag(aTHX_ stash);
+ cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
+ map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
+
+ /* $self->{methods} does not yet exist (or got deleted) */
+ if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
+ SV *new_map_ref = newRV_noinc((SV *)newHV());
+ sv_2mortal(new_map_ref);
+ sv_setsv(map_ref, new_map_ref);
+ }
+
+ if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
+ mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
+ sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
+ }
+
+ XPUSHs(map_ref);
+
+BOOT:
+ mop_method_metaclass = newSVpvs("method_metaclass");
+ mop_associated_metaclass = newSVpvs("associated_metaclass");
+ mop_wrap = newSVpvs("wrap");
+ INSTALL_SIMPLE_READER(Mixin::HasMethods, method_metaclass);
+ INSTALL_SIMPLE_READER(Mixin::HasMethods, wrapped_method_metaclass);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Method::Inlined PACKAGE = Class::MOP::Method::Inlined
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Method::Inlined, _expected_method_class);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Instance, associated_metaclass);
--- /dev/null
+#include "mop.h"
+
+static bool
+find_method (const char *key, STRLEN keylen, SV *val, void *ud)
+{
+ bool *found_method = (bool *)ud;
+ PERL_UNUSED_ARG(key);
+ PERL_UNUSED_ARG(keylen);
+ PERL_UNUSED_ARG(val);
+ *found_method = TRUE;
+ return FALSE;
+}
+
+static bool
+check_version (SV *klass, SV *required_version)
+{
+ bool ret = 0;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(klass);
+ PUSHs(required_version);
+ PUTBACK;
+
+ call_method("VERSION", G_DISCARD|G_VOID|G_EVAL);
+
+ SPAGAIN;
+
+ if (!SvTRUE(ERRSV)) {
+ ret = 1;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return ret;
+}
+
+MODULE = Class::MOP PACKAGE = Class::MOP
+
+PROTOTYPES: DISABLE
+
+# use prototype here to be compatible with get_code_info from Sub::Identify
+void
+get_code_info(coderef)
+ SV *coderef
+ PROTOTYPE: $
+ PREINIT:
+ char *pkg = NULL;
+ char *name = NULL;
+ PPCODE:
+ SvGETMAGIC(coderef);
+ if (mop_get_code_info(coderef, &pkg, &name)) {
+ EXTEND(SP, 2);
+ mPUSHs(newSVpv(pkg, 0));
+ mPUSHs(newSVpv(name, 0));
+ }
+
+void
+is_class_loaded(klass, options=NULL)
+ SV *klass
+ HV *options
+ PREINIT:
+ HV *stash;
+ bool found_method = FALSE;
+ PPCODE:
+ SvGETMAGIC(klass);
+ if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
+ XSRETURN_NO;
+ }
+
+ stash = gv_stashsv(klass, 0);
+ if (!stash) {
+ XSRETURN_NO;
+ }
+
+ if (options && hv_exists_ent(options, KEY_FOR(_version), HASH_FOR(_version))) {
+ HE *required_version = hv_fetch_ent(options, KEY_FOR(_version), 0, HASH_FOR(_version));
+ if (check_version (klass, HeVAL(required_version))) {
+ XSRETURN_YES;
+ }
+
+ XSRETURN_NO;
+ }
+
+ if (hv_exists_ent (stash, KEY_FOR(VERSION), HASH_FOR(VERSION))) {
+ HE *version = hv_fetch_ent(stash, KEY_FOR(VERSION), 0, HASH_FOR(VERSION));
+ SV *version_sv;
+ if (version && HeVAL(version) && (version_sv = GvSV(HeVAL(version)))) {
+ if (SvROK(version_sv)) {
+ SV *version_sv_ref = SvRV(version_sv);
+
+ if (SvOK(version_sv_ref)) {
+ XSRETURN_YES;
+ }
+ }
+ else if (SvOK(version_sv)) {
+ XSRETURN_YES;
+ }
+ }
+ }
+
+ if (hv_exists_ent (stash, KEY_FOR(ISA), HASH_FOR(ISA))) {
+ HE *isa = hv_fetch_ent(stash, KEY_FOR(ISA), 0, HASH_FOR(ISA));
+ if (isa && HeVAL(isa) && GvAV(HeVAL(isa)) && av_len(GvAV(HeVAL(isa))) != -1) {
+ XSRETURN_YES;
+ }
+ }
+
+ mop_get_package_symbols(stash, TYPE_FILTER_CODE, find_method, &found_method);
+ if (found_method) {
+ XSRETURN_YES;
+ }
+
+ XSRETURN_NO;
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Method PACKAGE = Class::MOP::Method
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Method, name);
+ INSTALL_SIMPLE_READER(Method, package_name);
+ INSTALL_SIMPLE_READER(Method, body);
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ppport.h"
+#include "mop.h"
+
+#ifndef MGf_COPY
+# define MGf_COPY 0
+#endif
+
+#ifndef MGf_DUP
+# define MGf_DUP 0
+#endif
+
+#ifndef MGf_LOCAL
+# define MGf_LOCAL 0
+#endif
+
+STATIC int unset_export_flag (pTHX_ SV *sv, MAGIC *mg);
+
+STATIC MGVTBL export_flag_vtbl = {
+ NULL, /* get */
+ unset_export_flag, /* set */
+ NULL, /* len */
+ NULL, /* clear */
+ NULL, /* free */
+#if MGf_COPY
+ NULL, /* copy */
+#endif
+#if MGf_DUP
+ NULL, /* dup */
+#endif
+#if MGf_LOCAL
+ NULL, /* local */
+#endif
+};
+
+STATIC bool
+export_flag_is_set (pTHX_ SV *sv)
+{
+ MAGIC *mg, *moremagic;
+
+ if (SvTYPE(SvRV(sv)) != SVt_PVGV) {
+ return 0;
+ }
+
+ for (mg = SvMAGIC(SvRV(sv)); mg; mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+
+ if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &export_flag_vtbl) {
+ break;
+ }
+ }
+
+ return !!mg;
+}
+
+STATIC int
+unset_export_flag (pTHX_ SV *sv, MAGIC *mymg)
+{
+ MAGIC *mg, *prevmagic = NULL, *moremagic = NULL;
+
+ for (mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+
+ if (mg == mymg) {
+ break;
+ }
+ }
+
+ if (!mg) {
+ return 0;
+ }
+
+ if (prevmagic) {
+ prevmagic->mg_moremagic = moremagic;
+ }
+ else {
+ SvMAGIC_set(sv, moremagic);
+ }
+
+ mg->mg_moremagic = NULL;
+
+ Safefree (mg);
+
+ return 0;
+}
+
+EXTERN_C XS(boot_Class__MOP);
+EXTERN_C XS(boot_Class__MOP__Mixin__HasAttributes);
+EXTERN_C XS(boot_Class__MOP__Mixin__HasMethods);
+EXTERN_C XS(boot_Class__MOP__Package);
+EXTERN_C XS(boot_Class__MOP__Mixin__AttributeCore);
+EXTERN_C XS(boot_Class__MOP__Method);
+EXTERN_C XS(boot_Class__MOP__Method__Inlined);
+EXTERN_C XS(boot_Class__MOP__Method__Generated);
+EXTERN_C XS(boot_Class__MOP__Class);
+EXTERN_C XS(boot_Class__MOP__Attribute);
+EXTERN_C XS(boot_Class__MOP__Instance);
+
+MODULE = Moose PACKAGE = Moose::Exporter
+
+BOOT:
+ mop_prehash_keys();
+
+ MOP_CALL_BOOT (boot_Class__MOP);
+ MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasAttributes);
+ MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasMethods);
+ MOP_CALL_BOOT (boot_Class__MOP__Package);
+ MOP_CALL_BOOT (boot_Class__MOP__Mixin__AttributeCore);
+ MOP_CALL_BOOT (boot_Class__MOP__Method);
+ MOP_CALL_BOOT (boot_Class__MOP__Method__Inlined);
+ MOP_CALL_BOOT (boot_Class__MOP__Method__Generated);
+ MOP_CALL_BOOT (boot_Class__MOP__Class);
+ MOP_CALL_BOOT (boot_Class__MOP__Attribute);
+ MOP_CALL_BOOT (boot_Class__MOP__Instance);
+
+void
+_flag_as_reexport (SV *sv)
+ CODE:
+ sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, &export_flag_vtbl, NULL, 0);
+
+bool
+_export_is_flagged (SV *sv)
+ CODE:
+ RETVAL = export_flag_is_set(aTHX_ sv);
+ OUTPUT:
+ RETVAL
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
--- /dev/null
+type_filter_t T_TYPE_FILTER
+
+INPUT
+
+T_TYPE_FILTER
+ {
+ const char *__tMp = SvPV_nolen($arg);
+ switch (*__tMp) {
+ case 'C': $var = TYPE_FILTER_CODE; break;
+ case 'A': $var = TYPE_FILTER_ARRAY; break;
+ case 'I': $var = TYPE_FILTER_IO; break;
+ case 'H': $var = TYPE_FILTER_HASH; break;
+ case 'S': $var = TYPE_FILTER_SCALAR; break;
+ default:
+ croak(\"Unknown type %s\\n\", __tMp);
+ }
+ }
projects / gitmo/Moose.git / commitdiff