From: Dave Rolsky Date: Mon, 27 Dec 2010 14:48:08 +0000 (-0600) Subject: Merged CMOP into Moose X-Git-Tag: 1.9900~3^2~34 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=38bf2a2585e26a47c919fd4c286b7716acb51c00;p=gitmo%2FMoose.git Merged CMOP into Moose This involved tweaking the XS code a bit so that the Moose XS takes care of booting the CMOP XS. It also meant changing Class::MOP to load Moose.so. Most tests pass, except one which is probably related to the earlier dzilification. We will probably need an additional dzil plugin to customize the Makefile.PL generation to do all the funky XS stuff that the hand-written one currently does. --- diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..a2917a8 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,76 @@ +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 () { + (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 +} diff --git a/Moose.xs b/Moose.xs deleted file mode 100644 index 874e9e0..0000000 --- a/Moose.xs +++ /dev/null @@ -1,102 +0,0 @@ -#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 diff --git a/benchmarks/cmop/all.yml b/benchmarks/cmop/all.yml new file mode 100644 index 0000000..13ec57f --- /dev/null +++ b/benchmarks/cmop/all.yml @@ -0,0 +1,30 @@ +--- +- 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 ] + diff --git a/benchmarks/cmop/foo.pl b/benchmarks/cmop/foo.pl new file mode 100755 index 0000000..e99365b --- /dev/null +++ b/benchmarks/cmop/foo.pl @@ -0,0 +1,5 @@ +#!perl -wd:NYTProf +# a moose using script for profiling +# Usage: perl bench/profile.pl + +require KiokuDB; diff --git a/benchmarks/cmop/lib/Bench/Accessor.pm b/benchmarks/cmop/lib/Bench/Accessor.pm new file mode 100644 index 0000000..3f30239 --- /dev/null +++ b/benchmarks/cmop/lib/Bench/Accessor.pm @@ -0,0 +1,49 @@ +#!/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__ diff --git a/benchmarks/cmop/lib/Bench/Construct.pm b/benchmarks/cmop/lib/Bench/Construct.pm new file mode 100644 index 0000000..c290304 --- /dev/null +++ b/benchmarks/cmop/lib/Bench/Construct.pm @@ -0,0 +1,36 @@ +#!/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__ diff --git a/benchmarks/cmop/lib/Bench/Run.pm b/benchmarks/cmop/lib/Bench/Run.pm new file mode 100644 index 0000000..09ac1b6 --- /dev/null +++ b/benchmarks/cmop/lib/Bench/Run.pm @@ -0,0 +1,55 @@ +#!/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__ diff --git a/benchmarks/cmop/lib/MOP/Immutable/Point.pm b/benchmarks/cmop/lib/MOP/Immutable/Point.pm new file mode 100644 index 0000000..d19d3a9 --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Immutable/Point.pm @@ -0,0 +1,21 @@ + +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__ diff --git a/benchmarks/cmop/lib/MOP/Immutable/Point3D.pm b/benchmarks/cmop/lib/MOP/Immutable/Point3D.pm new file mode 100644 index 0000000..5c9f9fb --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Immutable/Point3D.pm @@ -0,0 +1,22 @@ + +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 diff --git a/benchmarks/cmop/lib/MOP/Installed/Point.pm b/benchmarks/cmop/lib/MOP/Installed/Point.pm new file mode 100644 index 0000000..4ad669a --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Installed/Point.pm @@ -0,0 +1,26 @@ + +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 diff --git a/benchmarks/cmop/lib/MOP/Installed/Point3D.pm b/benchmarks/cmop/lib/MOP/Installed/Point3D.pm new file mode 100644 index 0000000..1a8bf03 --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Installed/Point3D.pm @@ -0,0 +1,22 @@ + +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 diff --git a/benchmarks/cmop/lib/MOP/Point.pm b/benchmarks/cmop/lib/MOP/Point.pm new file mode 100644 index 0000000..b07b8fd --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Point.pm @@ -0,0 +1,24 @@ + +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 diff --git a/benchmarks/cmop/lib/MOP/Point3D.pm b/benchmarks/cmop/lib/MOP/Point3D.pm new file mode 100644 index 0000000..2bd544d --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Point3D.pm @@ -0,0 +1,20 @@ + +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 diff --git a/benchmarks/cmop/lib/Plain/Point.pm b/benchmarks/cmop/lib/Plain/Point.pm new file mode 100644 index 0000000..fca27b0 --- /dev/null +++ b/benchmarks/cmop/lib/Plain/Point.pm @@ -0,0 +1,45 @@ +#!/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__ + diff --git a/benchmarks/cmop/lib/Plain/Point3D.pm b/benchmarks/cmop/lib/Plain/Point3D.pm new file mode 100644 index 0000000..7ec0aba --- /dev/null +++ b/benchmarks/cmop/lib/Plain/Point3D.pm @@ -0,0 +1,36 @@ +#!/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__ + diff --git a/benchmarks/cmop/loading-benchmark.pl b/benchmarks/cmop/loading-benchmark.pl new file mode 100755 index 0000000..612ae63 --- /dev/null +++ b/benchmarks/cmop/loading-benchmark.pl @@ -0,0 +1,27 @@ +#!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; + }, +}; diff --git a/benchmarks/cmop/profile.pl b/benchmarks/cmop/profile.pl new file mode 100755 index 0000000..4ea5b01 --- /dev/null +++ b/benchmarks/cmop/profile.pl @@ -0,0 +1,25 @@ +#!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"; diff --git a/benchmarks/cmop/run_yml.pl b/benchmarks/cmop/run_yml.pl new file mode 100644 index 0000000..9ec14d6 --- /dev/null +++ b/benchmarks/cmop/run_yml.pl @@ -0,0 +1,20 @@ +#!/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"; +} + + diff --git a/dist.ini b/dist.ini index 6cf4320..a08cb3f 100644 --- a/dist.ini +++ b/dist.ini @@ -8,6 +8,9 @@ version = 1.9900 [@Basic] +[PruneFiles] +filenames = Makefile.PL + [PkgVersion] [Metadata] @@ -34,14 +37,18 @@ namespace = Moose::Meta::Method::Accessor::Native [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 @@ -52,6 +59,7 @@ Test::More = 0.88 Test::Requires = 0.05 [Prereqs / DevelopRequires] +Algorithm::C3 = 0 DateTime = 0 DateTime::Calendar::Mayan = 0 DateTime::Format::MySQL = 0 @@ -68,6 +76,7 @@ Params::Coerce = 0 Regexp::Common = 0 Test::Deep = 0 Test::Inline = 0 +Test::LeakTrace = 0 Test::Output = 0 URI = 0 diff --git a/eg/class_browser.pl b/eg/class_browser.pl new file mode 100644 index 0000000..095234d --- /dev/null +++ b/eg/class_browser.pl @@ -0,0 +1,288 @@ +#!/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 "" => ; + 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 %] + + + +Class::MOP Browser + + + +

Class::MOP Browser

+ + + + + + + + + + + +[% IF q.param('class') && area %] + +[% meta = get_metaclass_by_name(q.param('class')) %] + + +[% END %] + + +
+ [% FOREACH metaclass IN get_all_metaclasses() %] + + [% IF q.param('class') == metaclass.name %] + + [% ELSE %] + + [% END %] + + [% END %] +
[% metaclass.name %][% metaclass.name %]
 + + [% FOREACH area_name IN [ 'attributes', 'methods', 'superclasses' ] %] + [% IF q.param('class') %] + [% IF area == area_name %] + + [% ELSE %] + + [% END %] + [% ELSE %] + + [% END %] + [% END %] + +
[% area_name %][% area_name %][% area_name %]
 + + + + + + [% 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() %] + + + + + [% 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' ]%] + + + + + [% END %] + + + + + + [% END %] +
[% aspect %][% IF item == undef %]—[% ELSE %]
[% deparse_item(item) %]
[% END %]
[% aspect %][% method.$aspect() %]
body
[% deparse_method(method) %]
+ + [% IF area == 'methods' %] + [% FOREACH method IN meta.get_method_list.sort %] + + [% IF q.param('method') == method %] + + [% ELSE %] + + [% END %] + + [% END %] + [% END %] + [% IF area == 'attributes' %] + [% FOREACH attr IN meta.get_attribute_list.sort %] + + [% IF q.param('attr') == attr %] + + [% ELSE %] + + [% END %] + + [% END %] + [% END %] + [% IF area == 'superclasses' %] + [% FOREACH super IN meta.superclasses.sort %] + + + + [% END %] + [% END %] +
[% method %][% method %]
[% attr %][% attr %]
[% super %]
+ + + diff --git a/examples/ArrayBasedStorage.pod b/examples/ArrayBasedStorage.pod new file mode 100644 index 0000000..5c0369c --- /dev/null +++ b/examples/ArrayBasedStorage.pod @@ -0,0 +1,133 @@ + +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 Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 SEE ALSO + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod new file mode 100644 index 0000000..e7ae1c2 --- /dev/null +++ b/examples/AttributesWithHistory.pod @@ -0,0 +1,136 @@ + +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 Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/examples/C3MethodDispatchOrder.pod b/examples/C3MethodDispatchOrder.pod new file mode 100644 index 0000000..b635f56 --- /dev/null +++ b/examples/C3MethodDispatchOrder.pod @@ -0,0 +1,146 @@ + +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 + # + # + # / \ + # + # \ / + # + + 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. Using the L module, this repleces +the normal depth-first left-to-right perl dispatch order with the C3 method +dispatch order (see the L or L 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 method +which will return a linearized list of classes to dispatch along. + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +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 diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod new file mode 100644 index 0000000..c1ddae8 --- /dev/null +++ b/examples/ClassEncapsulatedAttributes.pod @@ -0,0 +1,151 @@ + +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 Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod new file mode 100644 index 0000000..07da94f --- /dev/null +++ b/examples/InsideOutClass.pod @@ -0,0 +1,195 @@ + +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 and override +the slot operations. This requires +overloading C, C, C, and +C, as well as their inline counterparts. Additionally we +overload C 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-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 Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/examples/InstanceCountingClass.pod b/examples/InstanceCountingClass.pod new file mode 100644 index 0000000..b28fef8 --- /dev/null +++ b/examples/InstanceCountingClass.pod @@ -0,0 +1,73 @@ + +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 Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod new file mode 100644 index 0000000..0c87b3a --- /dev/null +++ b/examples/LazyClass.pod @@ -0,0 +1,163 @@ + +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 Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/examples/Perl6Attribute.pod b/examples/Perl6Attribute.pod new file mode 100644 index 0000000..e03eb71 --- /dev/null +++ b/examples/Perl6Attribute.pod @@ -0,0 +1,83 @@ + +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 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 trait (see +L) 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 Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +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 diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm new file mode 100644 index 0000000..dea5cc9 --- /dev/null +++ b/lib/Class/MOP.pm @@ -0,0 +1,1199 @@ + +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 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 a class builder so much as a I>. 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, which supplies a powerful class +builder system built entirely on top of C. + +=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 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 modules, +this module B require you subclass it, or even that you +C 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 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 and C) and +two metaclasses (C and C) which have correct +metaclass compatibility both upwards and downwards. + + +---------+ +---------+ + | Meta::A |<----| Meta::B | <....... (instance of ) + +---------+ +---------+ <------- (inherits from) + ^ ^ + : : + +---------+ +---------+ + | A |<----| B | + +---------+ +---------+ + +In actuality, I 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 will attempt to fix some simple types of +incompatibilities. If all the metaclasses for the parent class are +I 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. If you +are interested in why this is an issue see the paper I linked to in the L section of +this document. + +=head2 Using custom metaclasses + +Always use the L 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 we encourage you to I use +L pragma, and instead use L to apply +roles to a class's metaclasses. This topic is covered at length in +various L 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 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 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 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 directory included in this distribution. + +See L for more details. + +=head1 FUNCTIONS + +Note that this module does not export any constants or functions. + +=head2 Constants + +=over 4 + +=item I + +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. + +=over 4 + +=item B + +This will load the specified C<$class_name>, if it is not already +loaded (as reported by C). This function can be used +in place of tricks like C or using C +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. + +For historical reasons, this function explicitly returns a true value. + +=item B + +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 modules will +cause most of the rest of the core L modules to falsely report +having been loaded, due to the way the base L 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. + +=item B + +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 + +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 will be +returned. + +=item B + +B + +This will return an integer that is managed by L 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 +variable which is not package specific. + +=item B + +=item B + +B + +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. + +=back + +=head2 Metaclass cache functions + +Class::MOP holds a cache of metaclasses. The following are functions +(B) 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 + +This will return a hash of all the metaclass instances that have +been cached by L, keyed by the package name. + +=item B + +This will return a list of all the metaclass instances that have +been cached by L. + +=item B + +This will return a list of all the metaclass names that have +been cached by L. + +=item B + +This will return a cached L instance, or nothing +if no metaclass exists with that C<$name>. + +=item B + +This will store a metaclass in the cache at the supplied C<$key>. + +=item B + +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 + +Returns true if the metaclass for C<$name> has been weakened +(via C). + +=item B + +This will return true of there exists a metaclass stored in the +C<$name> key, and return false otherwise. + +=item B + +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> +email me and let me know, I would love to hear about them. + +=over 4 + +=item I + +=item I + +=item I + +=item I + +=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 + +=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 + +=back + +=head2 Prior Art + +=over 4 + +=item The Perl 6 MetaModel work in the Pugs project + +=over 4 + +=item L + +=item L + +=back + +=back + +=head2 Articles + +=over 4 + +=item CPAN Module Review of Class::MOP + +L + +=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 and +L. 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, 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, or through the +web interface at L. + +You can also discuss feature requests or possible bugs on the Moose +mailing list (moose@perl.org) or on IRC at +L. + +=head1 ACKNOWLEDGEMENTS + +=over 4 + +=item Rob Kinyon + +Thanks to Rob for actually getting the development of this module kick-started. + +=back + +=cut diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm new file mode 100644 index 0000000..6b7a24f --- /dev/null +++ b/lib/Class/MOP/Attribute.pm @@ -0,0 +1,982 @@ + +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. 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 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 is explicitly set to C, 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 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 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 and C, 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 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, C, C, C and C +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 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 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 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). + +=item * clearer + +This method will uninitialize the attribute. After an attribute is +cleared, its C 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, the line number where the attribute was created, and +either C or C. + +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 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, C, C, C, and C +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 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 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 +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. + +=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 if the C was set to C. + +=item B<< $attr->has_default >> + +This will be I if the C was set to C, since +C is the default C anyway. + +=item B<< $attr->has_builder >> + +=item B<< $attr->has_insertion_order >> + +This will be I 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 method works. + +=item B<< $attr->clear_value($instance) >> + +This will clear the attribute's value in C<$instance>. This is what +the default C 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 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 C +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 +C 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. This method returns +the name of the accessor metaclass that this attribute uses. + +=item B<< $attr->associate_method($method) >> + +This associates a L 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 +C 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. + +=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 instance for this class. + +It should also be noted that L will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=cut + + diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm new file mode 100644 index 0000000..451744e --- /dev/null +++ b/lib/Class/MOP/Class.pm @@ -0,0 +1,2195 @@ + +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 is a subclass of L. + +=head1 METHODS + +=head2 Class construction + +These methods all create new C 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 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 objects. + +=item * meta_name + +Specifies the name to install the C method for this class under. +If it is not passed, C is assumed, and if C 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, C, and C +parameters that C 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 object for the +named package. Unlike C, this method I create a new +class. + +The purpose of this method is to retrieve a C +object for introspecting an existing class. + +If an existing C 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, C, +C, and C. These are all +optional, and default to the appropriate class in the C +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 on the instance's current metaclass. This method +will be passed the instance, the new metaclass, and any parameters +specified to C. By default, C +does nothing; it is merely a hook. + +=item B<< $metaclass->rebless_instance_back($instance) >> + +Does the same thing as C, 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, +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 for more information on the instance +metaclass. + +=item B<< $metaclass->get_meta_instance >> + +Returns an instance of the C 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 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 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) will be included. Similarly, methods named +with a fully qualified name using L 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 for the specified +C<$method_name>. If the class does not have the specified method, it +returns C + +=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 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, 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 object for the method. + +=item B<< $metaclass->method_metaclass >> + +Returns the class name of the method metaclass, see +L for more information on the method metaclass. + +=item B<< $metaclass->wrapped_method_metaclass >> + +Returns the class name of the wrapped method metaclass, see +L 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 objects for this class and its parents. + +=item B<< $metaclass->find_method_by_name($method_name) >> + +This will return a L for the specified +C<$method_name>. If the class does not have the specified method, it +returns C + +Unlike C, this method I look for the named method in +superclasses. + +=item B<< $metaclass->get_all_method_names >> + +This will return a list of method I 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, C, and C. The C key has a +L 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 +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 for the specified +C<$attribute_name>. If the class does not have the specified +attribute, it returns C. + +NOTE that get_attribute does not search superclasses, for that you +need to use C. + +=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 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 objects for this class and its parents. + +=item B<< $metaclass->find_attribute_by_name($attribute_name) >> + +This will return a L for the specified +C<$attribute_name>. If the class does not have the specified +attribute, it returns C. + +Unlike C, this attribute I look for the named +attribute in superclasses. + +=item B<< $metaclass->add_attribute(...) >> + +This method accepts either an existing L +object or parameters suitable for passing to that class's C +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 object. + +Removing an attribute also removes any accessor methods defined by the +attribute. + +However, note that removing an attribute will only affect I +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. + +=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 and C, will +throw an error on an immutable metaclass object. + +The immutabilization system in L 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. + +=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, I and I 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 and C modifiers are +ignored. This is because their purpose is B to filter the input +and output of the primary method (this is done with an I +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 +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 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 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 instance for this class. + +It should also be noted that L will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=cut diff --git a/lib/Class/MOP/Class/Immutable/Trait.pm b/lib/Class/MOP/Class/Immutable/Trait.pm new file mode 100644 index 0000000..aec103e --- /dev/null +++ b/lib/Class/MOP/Class/Immutable/Trait.pm @@ -0,0 +1,97 @@ +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 + diff --git a/lib/Class/MOP/Deprecated.pm b/lib/Class/MOP/Deprecated.pm new file mode 100644 index 0000000..160ca0e --- /dev/null +++ b/lib/Class/MOP/Deprecated.pm @@ -0,0 +1,353 @@ +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. + +=cut diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm new file mode 100644 index 0000000..59e7382 --- /dev/null +++ b/lib/Class/MOP/Instance.pm @@ -0,0 +1,445 @@ + +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 = '<>'; + +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 +and L 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 object for which instances will be created. + +=item * attributes + +An array reference of L 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 clone of the original. + +=back + +=head2 Introspection + +=over 4 + +=item B<< $metainstance->associated_metaclass >> + +This returns the L 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, 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 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 instance for this class. + +It should also be noted that L will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=cut + diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm new file mode 100644 index 0000000..078a434 --- /dev/null +++ b/lib/Class/MOP/Method.pm @@ -0,0 +1,271 @@ + +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 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 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 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 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 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 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 method in the chain +of clones. + +=item B<< $metamethod->attach_to_class($metaclass) >> + +Given a L 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 instance for this class. + +It should also be noted that L will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=cut + diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm new file mode 100644 index 0000000..b191bd3 --- /dev/null +++ b/lib/Class/MOP/Method/Accessor.pm @@ -0,0 +1,322 @@ + +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 which is used by +C 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'ing it. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Accessor->new(%options) >> + +This returns a new C based on the +C<%options> provided. + +=over 4 + +=item * attribute + +This is the C 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. + +=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 object which was passed to +C. + +=item B<< $metamethod->body >> + +The method itself is I when the accessor object is +constructed. + +=back + +=cut + diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm new file mode 100644 index 0000000..bb7d83e --- /dev/null +++ b/lib/Class/MOP/Method/Constructor.pm @@ -0,0 +1,198 @@ + +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 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 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 object for the method. + +=back + +=cut + diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm new file mode 100644 index 0000000..9148cc2 --- /dev/null +++ b/lib/Class/MOP/Method/Generated.pm @@ -0,0 +1,75 @@ + +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 subclass which is subclassed by +C and +C. + +It is not intended to be used directly. + +=cut + diff --git a/lib/Class/MOP/Method/Inlined.pm b/lib/Class/MOP/Method/Inlined.pm new file mode 100644 index 0000000..3764e91 --- /dev/null +++ b/lib/Class/MOP/Method/Inlined.pm @@ -0,0 +1,135 @@ +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 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 + diff --git a/lib/Class/MOP/Method/Meta.pm b/lib/Class/MOP/Method/Meta.pm new file mode 100644 index 0000000..1b388a2 --- /dev/null +++ b/lib/Class/MOP/Method/Meta.pm @@ -0,0 +1,105 @@ + +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 methods + +__END__ + +=pod + +=head1 DESCRIPTION + +This is a L subclass which represents C +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 object and +a hash of options. The options accepted are identical to the ones +accepted by L, except that C cannot be passed +(it will be generated automatically). + +=back + +=cut + diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm new file mode 100644 index 0000000..92d649e --- /dev/null +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -0,0 +1,268 @@ + +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 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 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 object if it is not provided. + +=item * package_name + +The package name for the method. This will be taken from the provided +L object if it is not provided. + +=item * associated_metaclass + +An optional L object. This is the metaclass for the +method's class. + +=back + +=item B<< $metamethod->get_original_method >> + +This returns the L 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 + diff --git a/lib/Class/MOP/MiniTrait.pm b/lib/Class/MOP/MiniTrait.pm new file mode 100644 index 0000000..df065de --- /dev/null +++ b/lib/Class/MOP/MiniTrait.pm @@ -0,0 +1,51 @@ +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, which does a half-assed job +of applying a trait to a class. It exists solely for use inside Class::MOP and +L core classes. + +=cut + diff --git a/lib/Class/MOP/Mixin.pm b/lib/Class/MOP/Mixin.pm new file mode 100644 index 0000000..da23861 --- /dev/null +++ b/lib/Class/MOP/Mixin.pm @@ -0,0 +1,39 @@ +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 object for the mixin class. + +=back + +=cut diff --git a/lib/Class/MOP/Mixin/AttributeCore.pm b/lib/Class/MOP/Mixin/AttributeCore.pm new file mode 100644 index 0000000..6cbcdb8 --- /dev/null +++ b/lib/Class/MOP/Mixin/AttributeCore.pm @@ -0,0 +1,63 @@ +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 documentation for API details. + +=cut diff --git a/lib/Class/MOP/Mixin/HasAttributes.pm b/lib/Class/MOP/Mixin/HasAttributes.pm new file mode 100644 index 0000000..3744d0c --- /dev/null +++ b/lib/Class/MOP/Mixin/HasAttributes.pm @@ -0,0 +1,109 @@ +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 and L). See L for +API details. + +=cut diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm new file mode 100644 index 0000000..7de5e5f --- /dev/null +++ b/lib/Class/MOP/Mixin/HasMethods.pm @@ -0,0 +1,219 @@ +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 and L). See L +for API details. + +=cut diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm new file mode 100644 index 0000000..686ce4a --- /dev/null +++ b/lib/Class/MOP/Module.pm @@ -0,0 +1,116 @@ + +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 with metadata, in our +case the version and authority. + +=head1 INHERITANCE + +B is a subclass of L. + +=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 instance for this class. + +=back + +=cut diff --git a/lib/Class/MOP/Object.pm b/lib/Class/MOP/Object.pm new file mode 100644 index 0000000..0c0e4ca --- /dev/null +++ b/lib/Class/MOP/Object.pm @@ -0,0 +1,128 @@ + +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 object. + +=item B<< $metaobject->dump($max_depth) >> + +This method uses L 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 diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm new file mode 100644 index 0000000..8776f75 --- /dev/null +++ b/lib/Class/MOP/Package.pm @@ -0,0 +1,243 @@ + +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 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. In contrast to C, you may +also pass an existing C 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, 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 instance for this class. + +=back + +=cut diff --git a/lib/Moose.pm b/lib/Moose.pm index ae70c49..f38cac6 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -12,7 +12,7 @@ use Carp 'confess'; use Moose::Deprecated; use Moose::Exporter; -use Class::MOP 1.10; +use Class::MOP; use Moose::Meta::Class; use Moose::Meta::TypeConstraint; diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 0f40570..15a918c 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -5,6 +5,15 @@ use warnings; 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; @@ -12,10 +21,6 @@ use Scalar::Util qw(reftype); use Sub::Exporter 0.980; use Sub::Name qw(subname); -use XSLoader; - -XSLoader::load( 'Moose', $XS_VERSION ); - my %EXPORT_SPEC; sub setup_import_methods { diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index 0dee288..c79c090 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -10,7 +10,7 @@ use Scalar::Util 'blessed'; 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'; diff --git a/lib/metaclass.pm b/lib/metaclass.pm new file mode 100644 index 0000000..16ba5c9 --- /dev/null +++ b/lib/metaclass.pm @@ -0,0 +1,94 @@ + +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 method to your class as well, unless C +is passed to the C option. + +=cut diff --git a/mop.c b/mop.c new file mode 100644 index 0000000..71c043f --- /dev/null +++ b/mop.c @@ -0,0 +1,283 @@ +#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); +} + diff --git a/mop.h b/mop.h new file mode 100644 index 0000000..5547745 --- /dev/null +++ b/mop.h @@ -0,0 +1,96 @@ +#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 diff --git a/t/001_cmop/000_load.t b/t/001_cmop/000_load.t new file mode 100644 index 0000000..f6b3ec4 --- /dev/null +++ b/t/001_cmop/000_load.t @@ -0,0 +1,153 @@ +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; diff --git a/t/001_cmop/001_basic.t b/t/001_cmop/001_basic.t new file mode 100644 index 0000000..b782491 --- /dev/null +++ b/t/001_cmop/001_basic.t @@ -0,0 +1,80 @@ +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; diff --git a/t/001_cmop/002_class_precedence_list.t b/t/001_cmop/002_class_precedence_list.t new file mode 100644 index 0000000..7bc1fd4 --- /dev/null +++ b/t/001_cmop/002_class_precedence_list.t @@ -0,0 +1,160 @@ +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; diff --git a/t/001_cmop/003_methods.t b/t/001_cmop/003_methods.t new file mode 100644 index 0000000..a94ae99 --- /dev/null +++ b/t/001_cmop/003_methods.t @@ -0,0 +1,398 @@ +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; diff --git a/t/001_cmop/004_advanced_methods.t b/t/001_cmop/004_advanced_methods.t new file mode 100644 index 0000000..84aadb8 --- /dev/null +++ b/t/001_cmop/004_advanced_methods.t @@ -0,0 +1,153 @@ +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; diff --git a/t/001_cmop/005_attributes.t b/t/001_cmop/005_attributes.t new file mode 100644 index 0000000..a6df570 --- /dev/null +++ b/t/001_cmop/005_attributes.t @@ -0,0 +1,262 @@ +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; diff --git a/t/001_cmop/006_new_and_clone_metaclasses.t b/t/001_cmop/006_new_and_clone_metaclasses.t new file mode 100644 index 0000000..4b655ac --- /dev/null +++ b/t/001_cmop/006_new_and_clone_metaclasses.t @@ -0,0 +1,127 @@ +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; diff --git a/t/001_cmop/010_self_introspection.t b/t/001_cmop/010_self_introspection.t new file mode 100644 index 0000000..ff2e2c5 --- /dev/null +++ b/t/001_cmop/010_self_introspection.t @@ -0,0 +1,356 @@ +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; diff --git a/t/001_cmop/011_create_class.t b/t/001_cmop/011_create_class.t new file mode 100644 index 0000000..63a31d4 --- /dev/null +++ b/t/001_cmop/011_create_class.t @@ -0,0 +1,113 @@ +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; diff --git a/t/001_cmop/012_package_variables.t b/t/001_cmop/012_package_variables.t new file mode 100644 index 0000000..bcf960a --- /dev/null +++ b/t/001_cmop/012_package_variables.t @@ -0,0 +1,230 @@ +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; diff --git a/t/001_cmop/013_add_attribute_alternate.t b/t/001_cmop/013_add_attribute_alternate.t new file mode 100644 index 0000000..f7ecde1 --- /dev/null +++ b/t/001_cmop/013_add_attribute_alternate.t @@ -0,0 +1,109 @@ +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; diff --git a/t/001_cmop/014_attribute_introspection.t b/t/001_cmop/014_attribute_introspection.t new file mode 100644 index 0000000..6a9bb21 --- /dev/null +++ b/t/001_cmop/014_attribute_introspection.t @@ -0,0 +1,133 @@ +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; diff --git a/t/001_cmop/015_metaclass_inheritance.t b/t/001_cmop/015_metaclass_inheritance.t new file mode 100644 index 0000000..49a5298 --- /dev/null +++ b/t/001_cmop/015_metaclass_inheritance.t @@ -0,0 +1,45 @@ +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; diff --git a/t/001_cmop/016_class_errors_and_edge_cases.t b/t/001_cmop/016_class_errors_and_edge_cases.t new file mode 100644 index 0000000..36a1ac4 --- /dev/null +++ b/t/001_cmop/016_class_errors_and_edge_cases.t @@ -0,0 +1,223 @@ +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; diff --git a/t/001_cmop/017_add_method_modifier.t b/t/001_cmop/017_add_method_modifier.t new file mode 100644 index 0000000..03ba641 --- /dev/null +++ b/t/001_cmop/017_add_method_modifier.t @@ -0,0 +1,135 @@ +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; diff --git a/t/001_cmop/018_anon_class.t b/t/001_cmop/018_anon_class.t new file mode 100644 index 0000000..1b06879 --- /dev/null +++ b/t/001_cmop/018_anon_class.t @@ -0,0 +1,68 @@ +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; diff --git a/t/001_cmop/019_anon_class_keep_alive.t b/t/001_cmop/019_anon_class_keep_alive.t new file mode 100644 index 0000000..4963a56 --- /dev/null +++ b/t/001_cmop/019_anon_class_keep_alive.t @@ -0,0 +1,54 @@ +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; diff --git a/t/001_cmop/020_attribute.t b/t/001_cmop/020_attribute.t new file mode 100644 index 0000000..f23a434 --- /dev/null +++ b/t/001_cmop/020_attribute.t @@ -0,0 +1,248 @@ +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; diff --git a/t/001_cmop/021_attribute_errors_and_edge_cases.t b/t/001_cmop/021_attribute_errors_and_edge_cases.t new file mode 100644 index 0000000..e4a87d6 --- /dev/null +++ b/t/001_cmop/021_attribute_errors_and_edge_cases.t @@ -0,0 +1,232 @@ +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; diff --git a/t/001_cmop/022_attribute_duplication.t b/t/001_cmop/022_attribute_duplication.t new file mode 100644 index 0000000..4c4073f --- /dev/null +++ b/t/001_cmop/022_attribute_duplication.t @@ -0,0 +1,58 @@ +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; diff --git a/t/001_cmop/023_attribute_get_read_write.t b/t/001_cmop/023_attribute_get_read_write.t new file mode 100644 index 0000000..9f621a6 --- /dev/null +++ b/t/001_cmop/023_attribute_get_read_write.t @@ -0,0 +1,114 @@ +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; diff --git a/t/001_cmop/024_attribute_initializer.t b/t/001_cmop/024_attribute_initializer.t new file mode 100644 index 0000000..c61c7cb --- /dev/null +++ b/t/001_cmop/024_attribute_initializer.t @@ -0,0 +1,52 @@ +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; diff --git a/t/001_cmop/025_attribute_non_alpha_name.t b/t/001_cmop/025_attribute_non_alpha_name.t new file mode 100644 index 0000000..98e411e --- /dev/null +++ b/t/001_cmop/025_attribute_non_alpha_name.t @@ -0,0 +1,34 @@ +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; diff --git a/t/001_cmop/030_method.t b/t/001_cmop/030_method.t new file mode 100644 index 0000000..f70df12 --- /dev/null +++ b/t/001_cmop/030_method.t @@ -0,0 +1,149 @@ +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; diff --git a/t/001_cmop/031_method_modifiers.t b/t/001_cmop/031_method_modifiers.t new file mode 100644 index 0000000..cb7078d --- /dev/null +++ b/t/001_cmop/031_method_modifiers.t @@ -0,0 +1,203 @@ +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; diff --git a/t/001_cmop/032_universal_methods.t b/t/001_cmop/032_universal_methods.t new file mode 100644 index 0000000..29d94df --- /dev/null +++ b/t/001_cmop/032_universal_methods.t @@ -0,0 +1,24 @@ +#!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; diff --git a/t/001_cmop/040_metaclass.t b/t/001_cmop/040_metaclass.t new file mode 100644 index 0000000..b2f3835 --- /dev/null +++ b/t/001_cmop/040_metaclass.t @@ -0,0 +1,58 @@ +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; diff --git a/t/001_cmop/041_metaclass_incompatibility.t b/t/001_cmop/041_metaclass_incompatibility.t new file mode 100644 index 0000000..5148c29 --- /dev/null +++ b/t/001_cmop/041_metaclass_incompatibility.t @@ -0,0 +1,256 @@ +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; diff --git a/t/001_cmop/042_metaclass_incompatibility_dyn.t b/t/001_cmop/042_metaclass_incompatibility_dyn.t new file mode 100644 index 0000000..4dab002 --- /dev/null +++ b/t/001_cmop/042_metaclass_incompatibility_dyn.t @@ -0,0 +1,66 @@ +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; diff --git a/t/001_cmop/043_instance_metaclass_incompat.t b/t/001_cmop/043_instance_metaclass_incompat.t new file mode 100644 index 0000000..8439120 --- /dev/null +++ b/t/001_cmop/043_instance_metaclass_incompat.t @@ -0,0 +1,66 @@ +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; diff --git a/t/001_cmop/044_instance_metaclass_incompat_dyn.t b/t/001_cmop/044_instance_metaclass_incompat_dyn.t new file mode 100644 index 0000000..2dbb8d2 --- /dev/null +++ b/t/001_cmop/044_instance_metaclass_incompat_dyn.t @@ -0,0 +1,66 @@ +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; diff --git a/t/001_cmop/045_metaclass_loads_classes.t b/t/001_cmop/045_metaclass_loads_classes.t new file mode 100644 index 0000000..5ae9069 --- /dev/null +++ b/t/001_cmop/045_metaclass_loads_classes.t @@ -0,0 +1,41 @@ +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; diff --git a/t/001_cmop/046_rebless_instance.t b/t/001_cmop/046_rebless_instance.t new file mode 100644 index 0000000..b1bd4e3 --- /dev/null +++ b/t/001_cmop/046_rebless_instance.t @@ -0,0 +1,95 @@ +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; diff --git a/t/001_cmop/047_rebless_with_extra_params.t b/t/001_cmop/047_rebless_with_extra_params.t new file mode 100644 index 0000000..ee29aa3 --- /dev/null +++ b/t/001_cmop/047_rebless_with_extra_params.t @@ -0,0 +1,95 @@ +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; diff --git a/t/001_cmop/048_anon_class_create_init.t b/t/001_cmop/048_anon_class_create_init.t new file mode 100644 index 0000000..b42149a --- /dev/null +++ b/t/001_cmop/048_anon_class_create_init.t @@ -0,0 +1,150 @@ +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; diff --git a/t/001_cmop/049_metaclass_reinitialize.t b/t/001_cmop/049_metaclass_reinitialize.t new file mode 100644 index 0000000..b739836 --- /dev/null +++ b/t/001_cmop/049_metaclass_reinitialize.t @@ -0,0 +1,205 @@ +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; diff --git a/t/001_cmop/050_scala_style_mixin_composition.t b/t/001_cmop/050_scala_style_mixin_composition.t new file mode 100644 index 0000000..b3c5376 --- /dev/null +++ b/t/001_cmop/050_scala_style_mixin_composition.t @@ -0,0 +1,173 @@ +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 + +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; diff --git a/t/001_cmop/060_instance.t b/t/001_cmop/060_instance.t new file mode 100644 index 0000000..5ab6a55 --- /dev/null +++ b/t/001_cmop/060_instance.t @@ -0,0 +1,139 @@ +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; diff --git a/t/001_cmop/061_instance_inline.t b/t/001_cmop/061_instance_inline.t new file mode 100644 index 0000000..7100c80 --- /dev/null +++ b/t/001_cmop/061_instance_inline.t @@ -0,0 +1,48 @@ +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; diff --git a/t/001_cmop/062_custom_instance.t b/t/001_cmop/062_custom_instance.t new file mode 100644 index 0000000..429452f --- /dev/null +++ b/t/001_cmop/062_custom_instance.t @@ -0,0 +1,138 @@ +#!/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; diff --git a/t/001_cmop/070_immutable_metaclass.t b/t/001_cmop/070_immutable_metaclass.t new file mode 100644 index 0000000..ca3ecf9 --- /dev/null +++ b/t/001_cmop/070_immutable_metaclass.t @@ -0,0 +1,292 @@ +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; diff --git a/t/001_cmop/071_immutable_w_custom_metaclass.t b/t/001_cmop/071_immutable_w_custom_metaclass.t new file mode 100644 index 0000000..eda3217 --- /dev/null +++ b/t/001_cmop/071_immutable_w_custom_metaclass.t @@ -0,0 +1,74 @@ +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; diff --git a/t/001_cmop/072_immutable_w_constructors.t b/t/001_cmop/072_immutable_w_constructors.t new file mode 100644 index 0000000..cb95e20 --- /dev/null +++ b/t/001_cmop/072_immutable_w_constructors.t @@ -0,0 +1,301 @@ +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; diff --git a/t/001_cmop/073_make_mutable.t b/t/001_cmop/073_make_mutable.t new file mode 100644 index 0000000..52b3c35 --- /dev/null +++ b/t/001_cmop/073_make_mutable.t @@ -0,0 +1,220 @@ +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; diff --git a/t/001_cmop/074_immutable_custom_trait.t b/t/001_cmop/074_immutable_custom_trait.t new file mode 100644 index 0000000..96ac773 --- /dev/null +++ b/t/001_cmop/074_immutable_custom_trait.t @@ -0,0 +1,76 @@ +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; diff --git a/t/001_cmop/080_meta_package.t b/t/001_cmop/080_meta_package.t new file mode 100644 index 0000000..8e7f76e --- /dev/null +++ b/t/001_cmop/080_meta_package.t @@ -0,0 +1,280 @@ +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; diff --git a/t/001_cmop/081_meta_package_extension.t b/t/001_cmop/081_meta_package_extension.t new file mode 100644 index 0000000..e0f393c --- /dev/null +++ b/t/001_cmop/081_meta_package_extension.t @@ -0,0 +1,95 @@ +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; diff --git a/t/001_cmop/082_get_code_info.t b/t/001_cmop/082_get_code_info.t new file mode 100644 index 0000000..2770b76 --- /dev/null +++ b/t/001_cmop/082_get_code_info.t @@ -0,0 +1,52 @@ +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; diff --git a/t/001_cmop/083_load_class.t b/t/001_cmop/083_load_class.t new file mode 100644 index 0000000..f471fe9 --- /dev/null +++ b/t/001_cmop/083_load_class.t @@ -0,0 +1,176 @@ +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; diff --git a/t/001_cmop/085_load_class_gvstash_detect_bug.t b/t/001_cmop/085_load_class_gvstash_detect_bug.t new file mode 100644 index 0000000..ac2edaf --- /dev/null +++ b/t/001_cmop/085_load_class_gvstash_detect_bug.t @@ -0,0 +1,28 @@ +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; diff --git a/t/001_cmop/086_rebless_instance_away.t b/t/001_cmop/086_rebless_instance_away.t new file mode 100644 index 0000000..c86f416 --- /dev/null +++ b/t/001_cmop/086_rebless_instance_away.t @@ -0,0 +1,45 @@ +#!/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; diff --git a/t/001_cmop/087_subclasses.t b/t/001_cmop/087_subclasses.t new file mode 100644 index 0000000..5a213fb --- /dev/null +++ b/t/001_cmop/087_subclasses.t @@ -0,0 +1,45 @@ +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; diff --git a/t/001_cmop/090_meta_method.t b/t/001_cmop/090_meta_method.t new file mode 100644 index 0000000..f103936 --- /dev/null +++ b/t/001_cmop/090_meta_method.t @@ -0,0 +1,67 @@ +#!/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; diff --git a/t/001_cmop/100_BinaryTree_test.t b/t/001_cmop/100_BinaryTree_test.t new file mode 100644 index 0000000..f6f1c37 --- /dev/null +++ b/t/001_cmop/100_BinaryTree_test.t @@ -0,0 +1,332 @@ +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; diff --git a/t/001_cmop/101_InstanceCountingClass_test.t b/t/001_cmop/101_InstanceCountingClass_test.t new file mode 100644 index 0000000..97bcf67 --- /dev/null +++ b/t/001_cmop/101_InstanceCountingClass_test.t @@ -0,0 +1,59 @@ +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; diff --git a/t/001_cmop/102_InsideOutClass_test.t b/t/001_cmop/102_InsideOutClass_test.t new file mode 100644 index 0000000..bc4c27c --- /dev/null +++ b/t/001_cmop/102_InsideOutClass_test.t @@ -0,0 +1,224 @@ +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; diff --git a/t/001_cmop/103_Perl6Attribute_test.t b/t/001_cmop/103_Perl6Attribute_test.t new file mode 100644 index 0000000..4c0b3dd --- /dev/null +++ b/t/001_cmop/103_Perl6Attribute_test.t @@ -0,0 +1,43 @@ +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; diff --git a/t/001_cmop/104_AttributesWithHistory_test.t b/t/001_cmop/104_AttributesWithHistory_test.t new file mode 100644 index 0000000..45c3887 --- /dev/null +++ b/t/001_cmop/104_AttributesWithHistory_test.t @@ -0,0 +1,121 @@ +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; diff --git a/t/001_cmop/105_ClassEncapsulatedAttributes_test.t b/t/001_cmop/105_ClassEncapsulatedAttributes_test.t new file mode 100644 index 0000000..075f616 --- /dev/null +++ b/t/001_cmop/105_ClassEncapsulatedAttributes_test.t @@ -0,0 +1,109 @@ +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; diff --git a/t/001_cmop/106_LazyClass_test.t b/t/001_cmop/106_LazyClass_test.t new file mode 100644 index 0000000..b380d46 --- /dev/null +++ b/t/001_cmop/106_LazyClass_test.t @@ -0,0 +1,83 @@ +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; diff --git a/t/001_cmop/107_C3MethodDispatchOrder_test.t b/t/001_cmop/107_C3MethodDispatchOrder_test.t new file mode 100644 index 0000000..32db56b --- /dev/null +++ b/t/001_cmop/107_C3MethodDispatchOrder_test.t @@ -0,0 +1,45 @@ +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; diff --git a/t/001_cmop/108_ArrayBasedStorage_test.t b/t/001_cmop/108_ArrayBasedStorage_test.t new file mode 100644 index 0000000..58ff1d4 --- /dev/null +++ b/t/001_cmop/108_ArrayBasedStorage_test.t @@ -0,0 +1,204 @@ +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; diff --git a/t/001_cmop/200_Class_C3_compatibility.t b/t/001_cmop/200_Class_C3_compatibility.t new file mode 100644 index 0000000..24afc9c --- /dev/null +++ b/t/001_cmop/200_Class_C3_compatibility.t @@ -0,0 +1,64 @@ +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; diff --git a/t/001_cmop/300_random_eval_bug.t b/t/001_cmop/300_random_eval_bug.t new file mode 100644 index 0000000..1bf1cca --- /dev/null +++ b/t/001_cmop/300_random_eval_bug.t @@ -0,0 +1,50 @@ +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; diff --git a/t/001_cmop/301_RT_27329_fix.t b/t/001_cmop/301_RT_27329_fix.t new file mode 100644 index 0000000..0c8ee6a --- /dev/null +++ b/t/001_cmop/301_RT_27329_fix.t @@ -0,0 +1,47 @@ +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; diff --git a/t/001_cmop/302_modify_parent_method.t b/t/001_cmop/302_modify_parent_method.t new file mode 100644 index 0000000..2373453 --- /dev/null +++ b/t/001_cmop/302_modify_parent_method.t @@ -0,0 +1,101 @@ +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; diff --git a/t/001_cmop/303_RT_39001_fix.t b/t/001_cmop/303_RT_39001_fix.t new file mode 100644 index 0000000..a3575e8 --- /dev/null +++ b/t/001_cmop/303_RT_39001_fix.t @@ -0,0 +1,40 @@ +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; diff --git a/t/001_cmop/304_constant_codeinfo.t b/t/001_cmop/304_constant_codeinfo.t new file mode 100644 index 0000000..b40cc82 --- /dev/null +++ b/t/001_cmop/304_constant_codeinfo.t @@ -0,0 +1,22 @@ +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; diff --git a/t/001_cmop/305_RT_41255.t b/t/001_cmop/305_RT_41255.t new file mode 100644 index 0000000..0c87b9d --- /dev/null +++ b/t/001_cmop/305_RT_41255.t @@ -0,0 +1,51 @@ +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; diff --git a/t/001_cmop/306_rebless_overload.t b/t/001_cmop/306_rebless_overload.t new file mode 100644 index 0000000..437ebb1 --- /dev/null +++ b/t/001_cmop/306_rebless_overload.t @@ -0,0 +1,27 @@ +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; diff --git a/t/001_cmop/307_null_stash.t b/t/001_cmop/307_null_stash.t new file mode 100644 index 0000000..9aa0ebc --- /dev/null +++ b/t/001_cmop/307_null_stash.t @@ -0,0 +1,12 @@ +#!/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; diff --git a/t/001_cmop/308_insertion_order.t b/t/001_cmop/308_insertion_order.t new file mode 100644 index 0000000..073d3b3 --- /dev/null +++ b/t/001_cmop/308_insertion_order.t @@ -0,0 +1,35 @@ +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; diff --git a/t/001_cmop/309_subname.t b/t/001_cmop/309_subname.t new file mode 100644 index 0000000..6c113cc --- /dev/null +++ b/t/001_cmop/309_subname.t @@ -0,0 +1,42 @@ +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; diff --git a/t/001_cmop/310_inline_structor.t b/t/001_cmop/310_inline_structor.t new file mode 100644 index 0000000..27024ce --- /dev/null +++ b/t/001_cmop/310_inline_structor.t @@ -0,0 +1,294 @@ +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; diff --git a/t/001_cmop/311_inline_and_dollar_at.t b/t/001_cmop/311_inline_and_dollar_at.t new file mode 100644 index 0000000..80af4c9 --- /dev/null +++ b/t/001_cmop/311_inline_and_dollar_at.t @@ -0,0 +1,19 @@ +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; diff --git a/t/001_cmop/312_anon_class_leak.t b/t/001_cmop/312_anon_class_leak.t new file mode 100644 index 0000000..750c584 --- /dev/null +++ b/t/001_cmop/312_anon_class_leak.t @@ -0,0 +1,24 @@ +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; diff --git a/t/001_cmop/313_before_after_dollar_under.t b/t/001_cmop/313_before_after_dollar_under.t new file mode 100644 index 0000000..65f9774 --- /dev/null +++ b/t/001_cmop/313_before_after_dollar_under.t @@ -0,0 +1,70 @@ +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; diff --git a/t/001_cmop/314_class_is_pristine.t b/t/001_cmop/314_class_is_pristine.t new file mode 100644 index 0000000..4ab95c0 --- /dev/null +++ b/t/001_cmop/314_class_is_pristine.t @@ -0,0 +1,23 @@ +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; diff --git a/t/001_cmop/315_magic.t b/t/001_cmop/315_magic.t new file mode 100644 index 0000000..1969253 --- /dev/null +++ b/t/001_cmop/315_magic.t @@ -0,0 +1,75 @@ +# 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; diff --git a/t/001_cmop/316_numeric_defaults.t b/t/001_cmop/316_numeric_defaults.t new file mode 100644 index 0000000..3050df9 --- /dev/null +++ b/t/001_cmop/316_numeric_defaults.t @@ -0,0 +1,125 @@ +#!/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; diff --git a/t/001_cmop/500_deprecated.t b/t/001_cmop/500_deprecated.t new file mode 100644 index 0000000..471fb4a --- /dev/null +++ b/t/001_cmop/500_deprecated.t @@ -0,0 +1,73 @@ +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; diff --git a/t/001_cmop/lib/BinaryTree.pm b/t/001_cmop/lib/BinaryTree.pm new file mode 100644 index 0000000..9933b19 --- /dev/null +++ b/t/001_cmop/lib/BinaryTree.pm @@ -0,0 +1,142 @@ + +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; diff --git a/t/001_cmop/lib/MyMetaClass.pm b/t/001_cmop/lib/MyMetaClass.pm new file mode 100644 index 0000000..b70fe14 --- /dev/null +++ b/t/001_cmop/lib/MyMetaClass.pm @@ -0,0 +1,15 @@ + +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; diff --git a/t/001_cmop/lib/MyMetaClass/Attribute.pm b/t/001_cmop/lib/MyMetaClass/Attribute.pm new file mode 100644 index 0000000..dfb277c --- /dev/null +++ b/t/001_cmop/lib/MyMetaClass/Attribute.pm @@ -0,0 +1,9 @@ + +package MyMetaClass::Attribute; + +use strict; +use warnings; + +use base 'Class::MOP::Attribute'; + +1; diff --git a/t/001_cmop/lib/MyMetaClass/Instance.pm b/t/001_cmop/lib/MyMetaClass/Instance.pm new file mode 100644 index 0000000..1a4a99b --- /dev/null +++ b/t/001_cmop/lib/MyMetaClass/Instance.pm @@ -0,0 +1,9 @@ + +package MyMetaClass::Instance; + +use strict; +use warnings; + +use base 'Class::MOP::Instance'; + +1; diff --git a/t/001_cmop/lib/MyMetaClass/Method.pm b/t/001_cmop/lib/MyMetaClass/Method.pm new file mode 100644 index 0000000..4d606a3 --- /dev/null +++ b/t/001_cmop/lib/MyMetaClass/Method.pm @@ -0,0 +1,9 @@ + +package MyMetaClass::Method; + +use strict; +use warnings; + +use base 'Class::MOP::Method'; + +1; diff --git a/t/001_cmop/lib/MyMetaClass/Random.pm b/t/001_cmop/lib/MyMetaClass/Random.pm new file mode 100644 index 0000000..afa8d46 --- /dev/null +++ b/t/001_cmop/lib/MyMetaClass/Random.pm @@ -0,0 +1,7 @@ + +package MyMetaClass::Random; + +use strict; +use warnings; + +1; diff --git a/t/001_cmop/lib/SyntaxError.pm b/t/001_cmop/lib/SyntaxError.pm new file mode 100644 index 0000000..8d0e1e7 --- /dev/null +++ b/t/001_cmop/lib/SyntaxError.pm @@ -0,0 +1,11 @@ +#!/usr/bin/env perl +package SyntaxError; +use strict; +use warnings; + +# this syntax error is intentional! + + { + +1; + diff --git a/t/001_cmop/lib/TestClassLoaded.pm b/t/001_cmop/lib/TestClassLoaded.pm new file mode 100644 index 0000000..8e89f10 --- /dev/null +++ b/t/001_cmop/lib/TestClassLoaded.pm @@ -0,0 +1,8 @@ +package TestClassLoaded; +use strict; +use warnings; + +sub a_method { 'a_method' } + +1; + diff --git a/t/001_cmop/lib/TestClassLoaded/Sub.pm b/t/001_cmop/lib/TestClassLoaded/Sub.pm new file mode 100644 index 0000000..49a6c17 --- /dev/null +++ b/t/001_cmop/lib/TestClassLoaded/Sub.pm @@ -0,0 +1,7 @@ +package TestClassLoaded::Sub; +use strict; +use warnings; + +sub ver_test { return "TestClassLoaded ver $TestClassLoaded::VERSION" } + +1; diff --git a/t/001_cmop/lib/TestClassLoaded2.pm b/t/001_cmop/lib/TestClassLoaded2.pm new file mode 100644 index 0000000..e66e70b --- /dev/null +++ b/t/001_cmop/lib/TestClassLoaded2.pm @@ -0,0 +1,7 @@ +package TestClassLoaded2; +use strict; +use warnings; + + +1; + diff --git a/t/001_cmop/lib/TestClassLoaded3.pm b/t/001_cmop/lib/TestClassLoaded3.pm new file mode 100644 index 0000000..5fe67eb --- /dev/null +++ b/t/001_cmop/lib/TestClassLoaded3.pm @@ -0,0 +1,8 @@ +package TestClassLoaded3; +use strict; +use warnings; + +our @ISA = 'Foo'; + +1; + diff --git a/xs/Attribute.xs b/xs/Attribute.xs new file mode 100644 index 0000000..6314af8 --- /dev/null +++ b/xs/Attribute.xs @@ -0,0 +1,9 @@ +#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); diff --git a/xs/AttributeCore.xs b/xs/AttributeCore.xs new file mode 100644 index 0000000..d495a16 --- /dev/null +++ b/xs/AttributeCore.xs @@ -0,0 +1,18 @@ +#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); diff --git a/xs/Class.xs b/xs/Class.xs new file mode 100644 index 0000000..5c5d5c9 --- /dev/null +++ b/xs/Class.xs @@ -0,0 +1,12 @@ +#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); diff --git a/xs/Generated.xs b/xs/Generated.xs new file mode 100644 index 0000000..57db324 --- /dev/null +++ b/xs/Generated.xs @@ -0,0 +1,9 @@ +#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); diff --git a/xs/HasAttributes.xs b/xs/HasAttributes.xs new file mode 100644 index 0000000..dc59227 --- /dev/null +++ b/xs/HasAttributes.xs @@ -0,0 +1,9 @@ +#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); diff --git a/xs/HasMethods.xs b/xs/HasMethods.xs new file mode 100644 index 0000000..0e617eb --- /dev/null +++ b/xs/HasMethods.xs @@ -0,0 +1,88 @@ +#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); diff --git a/xs/Inlined.xs b/xs/Inlined.xs new file mode 100644 index 0000000..a7f1f56 --- /dev/null +++ b/xs/Inlined.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Method::Inlined PACKAGE = Class::MOP::Method::Inlined + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Method::Inlined, _expected_method_class); diff --git a/xs/Instance.xs b/xs/Instance.xs new file mode 100644 index 0000000..944caed --- /dev/null +++ b/xs/Instance.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Instance, associated_metaclass); diff --git a/xs/MOP.xs b/xs/MOP.xs new file mode 100644 index 0000000..c500891 --- /dev/null +++ b/xs/MOP.xs @@ -0,0 +1,119 @@ +#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; diff --git a/xs/Method.xs b/xs/Method.xs new file mode 100644 index 0000000..590cd06 --- /dev/null +++ b/xs/Method.xs @@ -0,0 +1,10 @@ +#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); diff --git a/xs/Moose.xs b/xs/Moose.xs new file mode 100644 index 0000000..b4945ef --- /dev/null +++ b/xs/Moose.xs @@ -0,0 +1,128 @@ +#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 diff --git a/xs/Package.xs b/xs/Package.xs new file mode 100644 index 0000000..6c47099 --- /dev/null +++ b/xs/Package.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package); diff --git a/xs/typemap b/xs/typemap new file mode 100644 index 0000000..7ab39e1 --- /dev/null +++ b/xs/typemap @@ -0,0 +1,17 @@ +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); + } + }