├── .gitignore ├── Makefile.PL ├── README.md ├── bench ├── accessor.pl ├── class-definition.pl ├── load.pl ├── method-call.pl └── object-creation.pl ├── extras └── talks │ ├── LPW-2011 │ └── p5-mop.html │ ├── OPW-2012 │ └── p5-mop.html │ ├── PPW-2011 │ └── p5-mop.html │ └── core │ ├── css │ ├── presentazion-print.css │ └── presentazion.css │ ├── images │ └── rjbs.png │ └── js │ ├── jquery-1.7.min.js │ └── presentazion.js ├── lib ├── mop.pm └── mop │ ├── bootstrap.pm │ ├── internal.pm │ ├── internal │ └── instance.pm │ ├── proposal │ ├── internals │ │ ├── attributes.pod │ │ ├── bootstrap.pod │ │ ├── classes.pod │ │ ├── dispatching.pod │ │ ├── instance.pod │ │ ├── intro.pod │ │ ├── methods.pod │ │ └── rants.pod │ ├── intro.pod │ ├── mop │ │ ├── attribute.pod │ │ ├── class.pod │ │ ├── intro.pod │ │ └── method.pod │ └── syntax │ │ ├── attributes.pod │ │ ├── classes.pod │ │ ├── intro.pod │ │ ├── metadata.pod │ │ └── methods.pod │ └── syntax.pm ├── mop.xs ├── t ├── 000-bootstrap.t ├── 000-examples │ ├── 001-basic-example.t │ ├── 002-basic-example.t │ ├── 003-basic-example.t │ ├── 004-basic-example.t │ ├── 005-basic-example.t │ └── 010-throwable.t ├── 010-core │ ├── 100-new.t │ ├── 102-clone.t │ ├── 103-hash-attribute.t │ ├── 104-array-attribute.t │ ├── 110-BUILD.t │ ├── 111-DEMOLISH.t │ ├── 120-super.t │ ├── 130-simple-attributes.t │ ├── 131-attributes-w-defaults.t │ ├── 132-attributes-w-lazy-defaults.t │ ├── 133-attributes-w-lazy-accessor.t │ ├── 140-atttributes-w-defaults-w-refs.t │ ├── 141-attributes-w-complex-defaults.t │ ├── 142-attributes-w-complex-lazy-defaults.t │ ├── 200-attribute-override.t │ ├── 300-UNIVERSAL.t │ └── 400-meta-block.t ├── 020-metaclass │ ├── 100-default-metaclass.t │ ├── 101-import-into.t │ ├── 200-basic-metaclasses.t │ ├── 210-metaclass-w-data.t │ ├── 220-compatibility.t │ ├── 300-cloning.t │ └── 301-metaclass-cloning.t ├── 030-extensions │ ├── 001-class-accessor.t │ ├── 002-validated-accessor.t │ ├── 003-wrapping-methods.t │ └── 004-find_method-example.t ├── 040-packages │ ├── 001-basic.t │ ├── 002-packages-w-exports.t │ ├── 003-fully-qualified-class-name.t │ ├── 004-loading-from-disk.t │ └── 010-package-extensions.t ├── 050-roles │ ├── 001-basic.t │ ├── 002-basic.t │ ├── 010-compose-into-role.t │ ├── 020-example.t │ ├── 100-conflict-edge-cases.t │ ├── anonymous_roles.t │ ├── create_role.t │ └── overriding.t ├── 100-oddities │ ├── 001-syntax-error.t │ ├── 002-lexical-override-attribute.t │ ├── 003-metadata-errors.t │ ├── 003-returning-lexicals.t │ ├── 004-recursive-self.t │ ├── 005-file-line.t │ ├── 006-naming-conflict.t │ └── 010-recursive-self-more.t ├── 200-declare │ ├── 001-class.t │ ├── 002-class-w-method.t │ ├── 003-class-w-attribute.t │ ├── 004-class-w-both.t │ ├── 005-class-w-self-and-class-vars.t │ ├── 006-class-w-metadata.t │ ├── 007-class-w-BUILD.t │ ├── 010-methods.t │ ├── 020-has.t │ ├── 021-has-w-metadata.t │ ├── 022-has-w-block.t │ ├── 023-has-w-object.t │ ├── 030-BUILD.t │ └── 040-smartmatch.t ├── 300-ext │ ├── Class-MOPX │ │ ├── 000-load.t │ │ ├── 001-basic.t │ │ ├── 002-init_arg.t │ │ ├── 003-builder.t │ │ ├── 004-lazy.t │ │ ├── 005-is.t │ │ ├── 006-required.t │ │ ├── 010-associated_class.t │ │ ├── 020-types.t │ │ └── 100-extension.t │ ├── Test-BuilderX │ │ ├── 001-load.t │ │ ├── 010-Test_Builder.t │ │ └── 020-Test_Builder_Test.t │ ├── explicit-override │ │ └── 001-basic.t │ └── mopx-instance-tracking │ │ └── 001-basic.t ├── 400-yapc-eu-examples │ ├── 001-basic.t │ ├── 100-throwable.t │ ├── 101-guarded-attributes.t │ └── lib │ │ ├── GuardedAttribute.pm │ │ └── Throwable.pm ├── ext │ ├── Class-MOPX │ │ └── Class │ │ │ ├── MOPX.pm │ │ │ └── MOPX │ │ │ └── Types.pm │ ├── Test-BuilderX │ │ └── Test │ │ │ ├── BuilderX.pm │ │ │ └── BuilderX │ │ │ ├── Output.pm │ │ │ ├── Test.pm │ │ │ ├── TestPlan.pm │ │ │ └── Tester.pm │ ├── explicit-override │ │ └── explicit │ │ │ └── override.pm │ └── mopx-instance-tracking │ │ └── mopx │ │ └── instance │ │ └── tracking.pm └── lib │ ├── Foo.pm │ └── Foo │ └── Bar.pm └── xt └── author └── leaks.t /.gitignore: -------------------------------------------------------------------------------- 1 | __NOTES__.txt 2 | cover_db 3 | META.* 4 | MYMETA.* 5 | Makefile 6 | blib 7 | inc 8 | pm_to_blib 9 | MANIFEST 10 | Makefile.old 11 | nytprof.out 12 | MANIFEST.bak 13 | *.sw[po] 14 | .DS_Store 15 | .build 16 | *.bs 17 | *.o 18 | mop.c 19 | callparser0.h 20 | callparser1.h 21 | env.sh 22 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use ExtUtils::MakeMaker; 4 | 5 | BEGIN { require 5.014 } 6 | 7 | use Devel::CallParser (); 8 | 9 | { 10 | open my $fh, '>', 'callparser1.h' 11 | or die "Couldn't open callparser1.h for writing: $!"; 12 | $fh->print(Devel::CallParser::callparser1_h); 13 | $fh->close 14 | or die "Couldn't close callparser1.h: $!"; 15 | } 16 | 17 | WriteMakefile( 18 | NAME => 'mop', 19 | VERSION_FROM => 'lib/mop.pm', 20 | PREREQ_PM => { 21 | 'Package::Anon' => 0.01, 22 | 'Sub::Name' => 0, 23 | 'PadWalker' => 0, 24 | 'Scope::Guard' => 0, 25 | 'Carp' => 0, 26 | 'UUID::Tiny' => 0, 27 | 'Scalar::Util' => 0, 28 | }, 29 | BUILD_REQUIRES => { 30 | 'Test::More' => 0, 31 | 'Test::Fatal' => 0, 32 | }, 33 | test => { 34 | TESTS => 't/*.t t/*/*.t t/*/*/*.t', 35 | }, 36 | clean => { 37 | FILES => 'callparser1.h', 38 | }, 39 | # XXX: not sure if this is correct 40 | OBJECT => join(' ', Devel::CallParser::callparser_linkable), 41 | ); 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **NOTE: This project has been restarted under a different name, see https://github.com/stevan/p5-mop-redux for more info** 2 | 3 | # A MOP for Perl 5 4 | 5 | This repository contains an ever evolving proposal and a 6 | functioning prototype for a Meta Object Protocol, or MOP, 7 | to be perhaps included in a future version of Perl 5. 8 | 9 | The core goal is to provide a simple, lightweight and 10 | highly Perl-ish MOP that will provide the same degree of 11 | flexibility and TIMTOWTDI of the original Perl 5 object 12 | model, but with more a formalized class model. 13 | 14 | This proposal will be developed in the open and comments 15 | are welcome. 16 | 17 | ----------------------------- 18 | Prototype notes ... 19 | ----------------------------- 20 | 21 | This is a prototype of the proposed MOP for Perl 5. The 22 | main purpose of this prototypes is to work out a few 23 | of key things; the syntax/semantics of the object 24 | system, the underlying MOP API and the extensibility 25 | of the MOP itself. 26 | 27 | Ideally this will also provide the starts of a test 28 | suite that can be ported to the final implementation. 29 | 30 | This prototype, for the most part, accurately 31 | reflects the proposed syntax/semanitics of the object 32 | system, however the implementation is another story. 33 | Basically, any implementation found in these folders 34 | should *NEVER* be considered a proposal for a *specific* 35 | implementation technique. In fact, much of what you might 36 | find in here will likely use scary and tricky techniques 37 | to accomplish desired behaviors, and it would be 38 | expected that a real implementation would *NOT* use 39 | such scary and tricky techniques. 40 | -------------------------------------------------------------------------------- /bench/accessor.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Benchmark ':hireswallclock', 'cmpthese'; 6 | 7 | use mop; 8 | 9 | class MopClass { 10 | has $foo; 11 | method foo { $foo } 12 | } 13 | 14 | { 15 | package MooseClass; 16 | use Moose; 17 | has foo => (is => 'ro'); 18 | } 19 | 20 | { 21 | package MouseClass; 22 | use Mouse; 23 | has foo => (is => 'ro'); 24 | } 25 | 26 | { 27 | package MooseImmutableClass; 28 | use Moose; 29 | has foo => (is => 'ro'); 30 | __PACKAGE__->meta->make_immutable; 31 | } 32 | 33 | { 34 | package MouseImmutableClass; 35 | use Mouse; 36 | has foo => (is => 'ro'); 37 | __PACKAGE__->meta->make_immutable; 38 | } 39 | 40 | my $mop = MopClass->new(foo => 'FOO'); 41 | my $moose = MooseClass->new(foo => 'FOO'); 42 | my $mouse = MouseClass->new(foo => 'FOO'); 43 | my $moosei = MooseImmutableClass->new(foo => 'FOO'); 44 | my $mousei = MouseImmutableClass->new(foo => 'FOO'); 45 | 46 | cmpthese(1000000, { 47 | mop => sub { $mop->foo }, 48 | moose => sub { $moose->foo }, 49 | mouse => sub { $mouse->foo }, 50 | moose_immutable => sub { $moosei->foo }, 51 | mouse_immutable => sub { $mousei->foo }, 52 | }); 53 | -------------------------------------------------------------------------------- /bench/class-definition.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Benchmark ':hireswallclock', 'cmpthese'; 6 | 7 | use mop (); 8 | use Moose (); 9 | use Mouse (); 10 | 11 | use constant N => 10000; 12 | use constant DEBUG => 0; 13 | 14 | my @mop_classes = map { mop_class($_) } 1..N; 15 | my @moose_classes = map { moose_class($_) } 1..N; 16 | my @mouse_classes = map { mouse_class($_) } 1..N; 17 | my @moose_immutable_classes = map { moose_class($_, 1) } 1..N; 18 | my @mouse_immutable_classes = map { mouse_class($_, 1) } 1..N; 19 | 20 | { 21 | my ($mop, $moose, $mouse, $moosei, $mousei) = (0) x 5; 22 | cmpthese(N, { 23 | mop => sub { 24 | eval $mop_classes[$mop++]; 25 | if (DEBUG) { 26 | die $@ if $@; 27 | my $class = eval "MopClass::m$mop()"; 28 | my $obj = $class->new(foo => 'FOO'); 29 | die unless $obj->foo eq 'FOO'; 30 | } 31 | }, 32 | moose => sub { 33 | eval $moose_classes[$moose++]; 34 | if (DEBUG) { 35 | die $@ if $@; 36 | my $obj = "MooseClass$moose"->new(foo => 'FOO'); 37 | die unless $obj->foo eq 'FOO'; 38 | } 39 | }, 40 | mouse => sub { 41 | eval $mouse_classes[$mouse++]; 42 | if (DEBUG) { 43 | die $@ if $@; 44 | my $obj = "MouseClass$mouse"->new(foo => 'FOO'); 45 | die unless $obj->foo eq 'FOO'; 46 | } 47 | }, 48 | moose_immutable => sub { 49 | eval $moose_immutable_classes[$moosei++]; 50 | if (DEBUG) { 51 | die $@ if $@; 52 | my $obj = "MooseClass${\($moosei+N)}"->new(foo => 'FOO'); 53 | die unless $obj->foo eq 'FOO'; 54 | } 55 | }, 56 | mouse_immutable => sub { 57 | eval $mouse_immutable_classes[$mousei++]; 58 | if (DEBUG) { 59 | die $@ if $@; 60 | my $obj = "MouseClass${\($mousei+N)}"->new(foo => 'FOO'); 61 | die unless $obj->foo eq 'FOO'; 62 | } 63 | }, 64 | }); 65 | } 66 | 67 | sub mop_class { 68 | my ($i) = @_; 69 | return sprintf(<<'CLASS', $i); 70 | use mop; 71 | class MopClass::m%d { 72 | has $foo; 73 | method foo { $foo } 74 | } 75 | CLASS 76 | } 77 | 78 | sub moose_class { 79 | my ($i, $immutable) = @_; 80 | $i += N if $immutable; 81 | return sprintf(<<'CLASS', $i, $immutable ? "__PACKAGE__->meta->make_immutable;" : ""); 82 | package MooseClass%d; 83 | use Moose; 84 | 85 | has foo => (is => 'ro'); 86 | %s 87 | CLASS 88 | } 89 | 90 | sub mouse_class { 91 | my ($i, $immutable) = @_; 92 | $i += N if $immutable; 93 | return sprintf(<<'CLASS', $i, $immutable ? "__PACKAGE__->meta->make_immutable;" : ""); 94 | package MouseClass%d; 95 | use Mouse; 96 | 97 | has foo => (is => 'ro'); 98 | %s 99 | CLASS 100 | } 101 | -------------------------------------------------------------------------------- /bench/load.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Benchmark ':hireswallclock', 'cmpthese'; 6 | 7 | my $inc = join ' ', map { "-I '$_'" } @INC; 8 | 9 | cmpthese(50, { 10 | mop => sub { system("$^X $inc -e 'package Foo; use mop'") }, 11 | Moose => sub { system("$^X $inc -e 'package Foo; use Moose'") }, 12 | Mouse => sub { system("$^X $inc -e 'package Foo; use Mouse'") }, 13 | }); 14 | -------------------------------------------------------------------------------- /bench/method-call.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Benchmark ':hireswallclock', 'cmpthese'; 6 | 7 | use mop; 8 | 9 | class Foo { 10 | method foo { 'FOO' } 11 | method bar ($x, $y) { $x + $y } 12 | } 13 | 14 | { 15 | package Bar; 16 | sub new { bless {}, shift } 17 | sub foo { 'FOO' } 18 | sub bar { my $self = shift; my ($x, $y) = @_; $x + $y } 19 | } 20 | 21 | my $foo = Foo->new; 22 | my $bar = Bar->new; 23 | 24 | cmpthese(1000000, { 25 | mop => sub { $foo->foo }, 26 | mop_args => sub { $foo->bar(1, 2) }, 27 | package => sub { $bar->foo }, 28 | package_args => sub { $bar->bar(1, 2) }, 29 | }); 30 | -------------------------------------------------------------------------------- /bench/object-creation.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Benchmark ':hireswallclock', 'cmpthese'; 6 | 7 | { 8 | package MopClass; 9 | use mop; 10 | 11 | class Class { 12 | has $foo; 13 | method foo { $foo } 14 | } 15 | } 16 | 17 | { 18 | package MooseClass; 19 | use Moose; 20 | 21 | has foo => (is => 'ro'); 22 | } 23 | 24 | { 25 | package MooseImmutableClass; 26 | use Moose; 27 | 28 | has foo => (is => 'ro'); 29 | 30 | __PACKAGE__->meta->make_immutable; 31 | } 32 | 33 | { 34 | package MouseClass; 35 | use Mouse; 36 | 37 | has foo => (is => 'ro'); 38 | } 39 | 40 | { 41 | package MouseImmutableClass; 42 | use Mouse; 43 | 44 | has foo => (is => 'ro'); 45 | 46 | __PACKAGE__->meta->make_immutable; 47 | } 48 | 49 | cmpthese(100000, { 50 | mop => sub { MopClass::Class->new(foo => 'FOO') }, 51 | moose => sub { MooseClass->new(foo => 'FOO') }, 52 | mouse => sub { MouseClass->new(foo => 'FOO') }, 53 | moose_immutable => sub { MooseImmutableClass->new(foo => 'FOO') }, 54 | mouse_immutable => sub { MouseImmutableClass->new(foo => 'FOO') }, 55 | }); 56 | -------------------------------------------------------------------------------- /extras/talks/core/css/presentazion-print.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 0; 3 | padding: 0; 4 | width: 1600px; 5 | height: 1200px; 6 | } 7 | .slide h1 { 8 | font-size: 1.4em; 9 | margin-top: 0.25em; 10 | margin-bottom: 0.25em; 11 | } 12 | .slide h2 { 13 | font-size: 1.3em; 14 | margin-top: 0.2em; 15 | margin-bottom: 0.2em; 16 | } 17 | .slide p { 18 | font-size: 1em; 19 | margin-top: 0.1em; 20 | margin-bottom: 0.1em; 21 | } 22 | .slide pre { 23 | display: block; 24 | font-family: Courier, monospace; 25 | font-size: 1em; 26 | margin-top: 0.1em; 27 | margin-bottom: 0.1em; 28 | } 29 | .slide { 30 | /* border: 1px solid red; */ 31 | width: 1600px; 32 | height: 1200px; 33 | page-break-after: always; 34 | display: inline-block; 35 | white-space: nowrap; 36 | background-color: black; 37 | } 38 | .slideshow { 39 | /*border: 1px solid black;*/ 40 | margin: auto; 41 | text-align: center; 42 | vertical-align: middle; 43 | color: white; 44 | background-color: black; 45 | } 46 | .codewrapper { 47 | text-align: left; 48 | display: inline-block; 49 | } 50 | .olwrapper { 51 | text-align: left; 52 | display: inline-block; 53 | } 54 | .ulwrapper { 55 | text-align: left; 56 | display: inline-block; 57 | } 58 | #mediatype { 59 | display: none; 60 | width: 2px; 61 | } -------------------------------------------------------------------------------- /extras/talks/core/css/presentazion.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 0; 3 | padding: 0; 4 | } 5 | .slide h1 { 6 | font-size: 1.4em; 7 | margin-top: 0.25em; 8 | margin-bottom: 0.25em; 9 | } 10 | .slide h2 { 11 | font-size: 1.3em; 12 | margin-top: 0.2em; 13 | margin-bottom: 0.2em; 14 | } 15 | .slide p { 16 | font-size: 1em; 17 | margin-top: 0.1em; 18 | margin-bottom: 0.1em; 19 | } 20 | .slide pre { 21 | display: block; 22 | font-family: Courier, monospace; 23 | font-size: 1em; 24 | margin-top: 0.1em; 25 | margin-bottom: 0.1em; 26 | } 27 | .slide { 28 | /* border: 1px solid red; */ 29 | display: inline-block; 30 | width: auto; 31 | height: auto; 32 | white-space: nowrap; 33 | } 34 | .slideshow { 35 | /* border: 1px solid black; */ 36 | margin: auto; 37 | text-align: center; 38 | vertical-align: middle; 39 | color: white; 40 | background-color: black; 41 | } 42 | .codewrapper { 43 | text-align: left; 44 | display: inline-block; 45 | } 46 | .olwrapper { 47 | text-align: left; 48 | display: inline-block; 49 | } 50 | .ulwrapper { 51 | text-align: left; 52 | display: inline-block; 53 | } 54 | #mediatype { 55 | display: none; 56 | width: 1px; 57 | } 58 | -------------------------------------------------------------------------------- /extras/talks/core/images/rjbs.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevan/p5-mop-original/aa98294827c5e557f77f22b96bd2bd483cd23cf4/extras/talks/core/images/rjbs.png -------------------------------------------------------------------------------- /lib/mop.pm: -------------------------------------------------------------------------------- 1 | package mop; 2 | 3 | use 5.014; 4 | use strict; 5 | use warnings; 6 | 7 | BEGIN { 8 | our $VERSION = '0.01'; 9 | our $AUTHORITY = 'cpan:STEVAN'; 10 | 11 | # These are global variables of the current invocant 12 | # and current class of the invocant, they are localized 13 | # within the body of the current method being executed. 14 | # These are needed mostly in the bootstrap process so 15 | # that the class Class and class Object can have access 16 | # to them. 17 | $::SELF = undef; 18 | $::CLASS = undef; 19 | 20 | # this is the current method being executed it is mostly 21 | # needed for finding the super-method 22 | $::CALLER = undef; 23 | 24 | # These are global variable that will (post-bootstrap) 25 | # represent the class Class and class Object respectively. 26 | # These are populated in the bootstrap process, but are 27 | # referenced in the syntax modules. 28 | $::Class = undef; 29 | $::Object = undef; 30 | 31 | # these are some of the classes that are also created 32 | # in the bootstrap and are part of the MOP 33 | $::Method = undef; 34 | $::Attribute = undef; 35 | $::Role = undef; 36 | 37 | $::HasMethods = undef; 38 | $::HasAttributes = undef; 39 | $::HasRoles = undef; 40 | $::HasName = undef; 41 | $::HasVersion = undef; 42 | $::HasRequiredMethods = undef; 43 | $::Composable = undef; 44 | $::HasSuperclass = undef; 45 | $::Instantiable = undef; 46 | $::Dispatchable = undef; 47 | $::Cloneable = undef; 48 | } 49 | 50 | use mop::bootstrap; 51 | use mop::syntax; 52 | 53 | use Devel::CallParser; 54 | 55 | BEGIN { XSLoader::load(__PACKAGE__, our $VERSION) } 56 | 57 | mop::bootstrap::init(); 58 | 59 | sub import { 60 | shift; 61 | my %options = @_; 62 | $^H{'mop/default_metaclass'} = $options{'-metaclass'} 63 | if $options{'-metaclass'}; 64 | $^H{'mop/default_role_metaclass'} = $options{'-role_metaclass'} 65 | if $options{'-role_metaclass'}; 66 | mop::syntax->setup_for( $options{'-into'} // caller ) 67 | } 68 | 69 | sub WALKCLASS { 70 | my ($dispatcher, $solver) = @_; 71 | { $solver->( $dispatcher->() || return ); redo } 72 | } 73 | 74 | sub WALKMETH { 75 | my ($dispatcher, $method_name) = @_; 76 | { ( $dispatcher->() || return )->get_local_methods->{ $method_name } || redo } 77 | } 78 | 79 | sub class_of ($) { mop::internal::instance::get_class( shift ) } 80 | sub uuid_of ($) { mop::internal::instance::get_uuid( shift ) } 81 | 82 | 1; 83 | 84 | __END__ 85 | 86 | =pod 87 | 88 | =head1 NAME 89 | 90 | mop - The p5-mop 91 | 92 | =head1 DESCRIPTION 93 | 94 | This is the main module for the mop, it handles the intial 95 | bootstrapping and exporting of the syntactic sugar. 96 | 97 | To find out more about this module you will want to look at 98 | L. 99 | 100 | =head1 AUTHORS 101 | 102 | Stevan Little Estevan.little@iinteractive.comE 103 | 104 | Jesse Luehrs Edoy at tozt dot netE 105 | 106 | =head1 CONTRIBUTORS 107 | 108 | The following is a list of people who have contributed to 109 | the development of this module through discussion and/or 110 | encouragement. 111 | 112 | Jesse Vincent 113 | 114 | Shawn Moore 115 | 116 | chromatic 117 | 118 | Steffen Mueller 119 | 120 | Abigail 121 | 122 | Father Chrysostomos 123 | 124 | Yuki Kimoto 125 | 126 | Nicholas Clark 127 | 128 | Reini Urban 129 | 130 | Andrew Main (Zefram) 131 | 132 | Hugo van der Sanden 133 | 134 | Aarron Crane 135 | 136 | Vyacheslav Matjukhin 137 | 138 | A.Vieth (forwardever) 139 | 140 | Dmitry Karasik 141 | 142 | =head1 COPYRIGHT AND LICENSE 143 | 144 | Copyright 2011 Infinity Interactive, Inc. 145 | 146 | L 147 | 148 | This library is free software; you can redistribute it and/or modify 149 | it under the same terms as Perl itself. 150 | 151 | =cut -------------------------------------------------------------------------------- /lib/mop/internal/instance.pm: -------------------------------------------------------------------------------- 1 | package mop::internal::instance; 2 | 3 | use 5.014; 4 | use strict; 5 | use warnings; 6 | 7 | our $VERSION = '0.01'; 8 | our $AUTHORITY = 'cpan:STEVAN'; 9 | 10 | use UUID::Tiny qw[ create_uuid_as_string UUID_V4 ]; 11 | 12 | sub create { 13 | my ($class, $slots) = @_; 14 | return +{ 15 | uuid => create_uuid_as_string(UUID_V4), 16 | class => $class, 17 | slots => $slots 18 | } 19 | } 20 | 21 | sub get_uuid { (shift)->{'uuid'} } 22 | sub get_class { ${(shift)->{'class'}} } 23 | sub get_slots { (shift)->{'slots'} } 24 | 25 | sub get_slot_at { 26 | my ($instance, $name) = @_; 27 | ${ $instance->{'slots'}->{ $name } || \undef } 28 | } 29 | 30 | sub set_slot_at { 31 | my ($instance, $name, $value) = @_; 32 | $instance->{'slots'}->{ $name } = $value 33 | } 34 | 35 | 1; 36 | 37 | __END__ 38 | 39 | =pod 40 | 41 | =head1 NAME 42 | 43 | mop::internal::instance - The p5-mop instance internals 44 | 45 | =head1 DESCRIPTION 46 | 47 | This module implements an instance type for the p5-mop. 48 | 49 | =head1 AUTHORS 50 | 51 | Stevan Little Estevan.little@iinteractive.comE 52 | 53 | Jesse Luehrs Edoy at tozt dot netE 54 | 55 | =head1 COPYRIGHT AND LICENSE 56 | 57 | Copyright 2011 Infinity Interactive, Inc. 58 | 59 | L 60 | 61 | This library is free software; you can redistribute it and/or modify 62 | it under the same terms as Perl itself. 63 | 64 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/internals/attributes.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Internals - Attributes 6 | 7 | =head1 DESCRIPTION 8 | 9 | =head1 AUTHOR 10 | 11 | Stevan Little Estevan.little@iinteractive.comE 12 | 13 | =head1 COPYRIGHT AND LICENSE 14 | 15 | Copyright 2011 Infinity Interactive, Inc. 16 | 17 | L 18 | 19 | This library is free software; you can redistribute it and/or modify 20 | it under the same terms as Perl itself. 21 | 22 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/internals/bootstrap.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Internals - Boostrap 6 | 7 | =head1 DESCRIPTION 8 | 9 | =head1 AUTHOR 10 | 11 | Stevan Little Estevan.little@iinteractive.comE 12 | 13 | =head1 COPYRIGHT AND LICENSE 14 | 15 | Copyright 2011 Infinity Interactive, Inc. 16 | 17 | L 18 | 19 | This library is free software; you can redistribute it and/or modify 20 | it under the same terms as Perl itself. 21 | 22 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/internals/classes.pod: -------------------------------------------------------------------------------- 1 | 2 | =pod 3 | 4 | =head1 NAME 5 | 6 | Perl 5 MOP - Internals - Classes 7 | 8 | =head1 DESCRIPTION 9 | 10 | Now we have arrived at classes, which really should be thought 11 | of as simply being factories for instances. In this proposal 12 | we treat classes as first class citizens in that they too are 13 | just instances of the class C. 14 | 15 | B 16 | 17 | It is important to note throughout this document the punctuation 18 | used on the word "class". When you see the lowercase "class" it 19 | is referring to the concept of a class, but when you see the 20 | uppercase "Class" this is referring to the specific class whose 21 | name is "Class". 22 | 23 | =head2 The parts of a class 24 | 25 | =over 4 26 | 27 | =item B<$name> 28 | 29 | =item B<$version> 30 | 31 | =item B<$authority> 32 | 33 | =item B<$superclass> 34 | 35 | =item B<%attributes> 36 | 37 | =item B<%methods> 38 | 39 | =item B<$constructor> 40 | 41 | =item B<$destructor> 42 | 43 | =back 44 | 45 | =head1 AUTHOR 46 | 47 | Stevan Little Estevan.little@iinteractive.comE 48 | 49 | =head1 COPYRIGHT AND LICENSE 50 | 51 | Copyright 2011 Infinity Interactive, Inc. 52 | 53 | L 54 | 55 | This library is free software; you can redistribute it and/or modify 56 | it under the same terms as Perl itself. 57 | 58 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/internals/dispatching.pod: -------------------------------------------------------------------------------- 1 | 2 | =pod 3 | 4 | =head1 NAME 5 | 6 | Perl 5 MOP - Internals - Dispatching 7 | 8 | =head1 DESCRIPTION 9 | 10 | The next thing we need to discuss is how methods get dispatched. 11 | This is fundamental part of any object system and the primary 12 | thing which you do with the instances that are discussed in the 13 | previous document. 14 | 15 | Note that we will allude to classes here, but we won't actually 16 | get into the details of them until the next document. 17 | 18 | TODO - need to update this to reflect what we are currently 19 | doing in the prototype 20 | 21 | =head1 NOTES 22 | 23 | =head2 Is dispatching stash based? 24 | 25 | Perhaps. 26 | 27 | I think it entirely possible that if we were to have proper 28 | anonymous stashes whose C<@ISA> and C can both understand 29 | a anonymous stash "object" as well as strings, then it would be 30 | possible to compile, upon class finalization, a set of stashes 31 | which could be used for dispatching on the new style classes. 32 | 33 | This would mean that the above described functions would not 34 | actually be executed at runtime, instead the existing built-in 35 | method dispatching mechanism would be used. 36 | 37 | Not knowing the guts well enough, i am not sure which is 38 | really the saner option, to write a whole new dispatching 39 | mechanism based on the above described spec, or to somehow 40 | try and re-use the existing dispatching mechanism. 41 | 42 | I have experimented somewhat with this using the prototype 43 | and the C experiment created by Florian Ragwitz 44 | but have not produced anything successful yet. 45 | 46 | Some of the details of this are discussed here: 47 | L 48 | 49 | Florian's C experiment is here: 50 | L 51 | 52 | =head1 RELATED 53 | 54 | =over 4 55 | 56 | =item L<100-rants.pod> 57 | 58 | This document contains a section entitled "The problem with Package 59 | based dispatching", which discussed my issues with package based 60 | dispatching (obviously). This should be viewed only as opinion and not 61 | as any guiding principle. 62 | 63 | =back 64 | 65 | =head1 AUTHOR 66 | 67 | Stevan Little Estevan.little@iinteractive.comE 68 | 69 | =head1 COPYRIGHT AND LICENSE 70 | 71 | Copyright 2011 Infinity Interactive, Inc. 72 | 73 | L 74 | 75 | This library is free software; you can redistribute it and/or modify 76 | it under the same terms as Perl itself. 77 | 78 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/internals/instance.pod: -------------------------------------------------------------------------------- 1 | 2 | =pod 3 | 4 | =head1 NAME 5 | 6 | Perl 5 MOP - Internals - The Instance Structure 7 | 8 | =head1 DESCRIPTION 9 | 10 | So the first thing we need to discuss about the internals is the instance 11 | structure itself. Every object in the entire MOP eco-system will be 12 | represented with one of these, so it is important to describe them first. 13 | 14 | =head2 The structure of an instance 15 | 16 | This describes the basic structure of the instance, it is expected that 17 | this is a C-level component. The exact implementation details are still 18 | up for debate, but in some way each instance of a new-style class should 19 | have access the information described here. 20 | 21 | There should also be Perl-level access to this information through the 22 | functions in the L package. These functions 23 | will likely be implemented in C and be what is used internally. 24 | 25 | =over 4 26 | 27 | =item B 28 | 29 | Object identity is a very important thing, especially in the highly 30 | distributed and networked world we live in. Not only should an identity 31 | be thread-safe, but it should also be safe across process boundaries as 32 | well as machine boundaries. These identities should also not be reused when 33 | an object is destroyed, avoiding the problem described in 34 | L 35 | 36 | B 37 | 38 | A UUID or GUID could be used to accomplish this, and is what is used 39 | by the prototype, but it might be become a memory bloat issue. If so, 40 | we could use something else as long as it meet the above described 41 | criteria. 42 | 43 | =item B 44 | 45 | At the most basic level, an object must know what class created it so 46 | that it knows where to find the methods that can be called on it. This 47 | is also very important for programmatic introspection of the MOP. 48 | 49 | =item B 50 | 51 | This is a set of key-value pairs that holds the data for each slot. 52 | 53 | B 54 | 55 | In the prototype this is represented with a HASH ref whose keys all have 56 | a sigil on them and whose values are all SCALAR references. The reason 57 | behind this particular data structure is that it is what is compatible 58 | with the C function. The reason for this 59 | will become more obvious when we discuss methods in that document. 60 | 61 | It should also be noted that this is simply an implementation choice, 62 | and I am very open to other suggestions assuming they can meet the 63 | criteria described here and in later documents. 64 | 65 | =back 66 | 67 | =head1 NOTES 68 | 69 | =head2 What about just blessed HASH refs? 70 | 71 | It is possible that this can simply be a blessed HASH ref with some 72 | slightly different "magic" attached to it. This magic would understand 73 | how to access the other above defined information, dispatch differently, 74 | etc. 75 | 76 | As I am unfamiliar with the perl guts, I am unsure if this is a sane 77 | route or not, but it is most certainly up for discussion. 78 | 79 | =head1 RELATED 80 | 81 | =over 4 82 | 83 | =item L<100-rants.pod> 84 | 85 | Personally I am not a fan of HASH ref based instances, and in 86 | "The problem with HASH based instances" section of the linked 87 | document I explain this in more detail. This should be viewed only 88 | as opinion and not as any guiding principle. 89 | 90 | =back 91 | 92 | =head1 AUTHOR 93 | 94 | Stevan Little Estevan.little@iinteractive.comE 95 | 96 | =head1 COPYRIGHT AND LICENSE 97 | 98 | Copyright 2011 Infinity Interactive, Inc. 99 | 100 | L 101 | 102 | This library is free software; you can redistribute it and/or modify 103 | it under the same terms as Perl itself. 104 | 105 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/internals/intro.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Internals - Introduction 6 | 7 | =head1 DESCRIPTION 8 | 9 | This is an introduction to the internals oriented documents 10 | of this proposal. 11 | 12 | =over 4 13 | 14 | =item L 15 | 16 | =item L 17 | 18 | =item L 19 | 20 | =item L 21 | 22 | =item L 23 | 24 | =item L 25 | 26 | =item L 27 | 28 | =back 29 | 30 | =head1 AUTHOR 31 | 32 | Stevan Little Estevan.little@iinteractive.comE 33 | 34 | =head1 COPYRIGHT AND LICENSE 35 | 36 | Copyright 2011 Infinity Interactive, Inc. 37 | 38 | L 39 | 40 | This library is free software; you can redistribute it and/or modify 41 | it under the same terms as Perl itself. 42 | 43 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/internals/methods.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Internals - Methods 6 | 7 | =head1 DESCRIPTION 8 | 9 | =head1 AUTHOR 10 | 11 | Stevan Little Estevan.little@iinteractive.comE 12 | 13 | =head1 COPYRIGHT AND LICENSE 14 | 15 | Copyright 2011 Infinity Interactive, Inc. 16 | 17 | L 18 | 19 | This library is free software; you can redistribute it and/or modify 20 | it under the same terms as Perl itself. 21 | 22 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/intro.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Introduction 6 | 7 | =head1 SYNOPSIS 8 | 9 | Perl was always designed to be an evolving language. 10 | -- Larry Wall 11 | 12 | =head1 DESCRIPTION 13 | 14 | The following is a proposal for the introduction of a new 15 | object system for Perl 5. The documentation is split into 16 | different parts and are meant to be read in order so as to 17 | build the conceptual understandings necessary for the 18 | subsequent parts. The major parts are as follows: 19 | 20 | =head2 L 21 | 22 | These documents explain some of the core concepts of the 23 | class system. 24 | 25 | This really should be read first in order for the later 26 | documents to make sense. If nothing more, just the intro 27 | document should be read, the rest can be reviewed later on. 28 | 29 | =head2 L 30 | 31 | These documents explain the proposed syntax and semantics for 32 | this new object system. 33 | 34 | =head2 L 35 | 36 | This is a collection of a number of documents detailing some 37 | of the internal mechanisms of this proposal. 38 | 39 | =head1 FAQs 40 | 41 | Much of the details of what and why will be covered in the 42 | individual documents that detail the various parts of the 43 | system. So in this document I have decided to address what 44 | I believe will be frequently asked questions about the proposal 45 | as a whole. 46 | 47 | =head2 Why a completely new object system? 48 | 49 | It is my opinion that this is the best way to both maintain 50 | backwards and forwards compatibility as well as not burden 51 | ourselves with the choices of the past. Allow me expand on 52 | this somewhat. 53 | 54 | How this helps backwards compatibility is fairly obvious since 55 | the system will be completely new and just simply live beside 56 | the old one. But it also helps forward compatibility, by which 57 | I mean the ability for old-style Perl OO and new-style Perl OO 58 | to inter-operate. There are billions of lines of Perl code on 59 | the CPAN which B be left behind. By keeping the two 60 | system separate and assuring that the new system is equally 61 | as flexible as the classic system, an interoperability layer 62 | can be created to bridge the two. 63 | 64 | I also feel that it is critically important that we not burden 65 | ourselves with the past. The classic Perl OO system is almost 66 | 20 years old, and what was state of the art in OO 20 years ago 67 | is not state of the art now. It is my opinion that it is 68 | important for Perl as a language to start fresh. 69 | 70 | =head2 What if I don't like "the way you do it"? 71 | 72 | This is Perl, so obviously there will be "more then one way". 73 | 74 | For starters you can always go back to the classic OO system, 75 | it B. However, this new system 76 | is being designed with the spirit of TIMTOWTDI at the core with a 77 | powerful and flexible fully meta-circular MOP at the core. This, 78 | along with the custom keyword functionality, means that there is 79 | very little you won't be able to change in the end. 80 | 81 | =head1 AUTHOR 82 | 83 | Stevan Little Estevan.little@iinteractive.comE 84 | 85 | =head1 COPYRIGHT AND LICENSE 86 | 87 | Copyright 2011 Infinity Interactive, Inc. 88 | 89 | L 90 | 91 | This library is free software; you can redistribute it and/or modify 92 | it under the same terms as Perl itself. 93 | 94 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/mop/attribute.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Meta Object Protocol - Attribute Sub Protocol 6 | 7 | =head1 DESCRIPTION 8 | 9 | This document will describe the proposed API for the 10 | attribute sub-protocol of the MOP. 11 | 12 | Currently the attribute sub-protocol is very small, and 13 | it will likely stay this way. However, as has been 14 | found with Moose, this sub-protocol is an extremely 15 | powerful extension point. 16 | 17 | =head2 API 18 | 19 | The attribute sub-protocol is (at this stage) completely 20 | immutable. The reason being that we believe it is 21 | dangerous to allow the manipulation of attribute internals 22 | simply for the huge potential impact that could have. 23 | Instead you are encouraged to simply clone an attribute 24 | and change the values during the clone process. 25 | 26 | B This is by no means a comprehensive 27 | list, nor is it a fixed list, of methods. This is simply 28 | the first draft of this. 29 | 30 | =head3 General 31 | 32 | =over 4 33 | 34 | =item C 35 | 36 | This returns the name of the attribute as a string. 37 | 38 | =item C 39 | 40 | This returns the name of the attribute with the sigil 41 | stripped off. 42 | 43 | =item C 44 | 45 | This returns the initial value (if any) that the attribute 46 | was given. 47 | 48 | =item C 49 | 50 | This returns a suitable copy of the initial value of the 51 | attribute to be used in instance construction. 52 | 53 | =item C 54 | 55 | Clone this object and override any internal elements using 56 | the values in C<%params>. 57 | 58 | =back 59 | 60 | =head1 AUTHOR 61 | 62 | Stevan Little Estevan.little@iinteractive.comE 63 | 64 | =head1 COPYRIGHT AND LICENSE 65 | 66 | Copyright 2011 Infinity Interactive, Inc. 67 | 68 | L 69 | 70 | This library is free software; you can redistribute it and/or modify 71 | it under the same terms as Perl itself. 72 | 73 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/mop/class.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Meta Object Protocol - Class Sub Protocol 6 | 7 | =head1 DESCRIPTION 8 | 9 | This document will describe the proposed API for the 10 | class sub-protocol of the MOP. 11 | 12 | =head2 API 13 | 14 | As you will see, we are leaning on the side of immutability 15 | here, and only allowing the class to be changed in certain 16 | specific ways. This may be losened up over time, but we 17 | feel it is a good starting point. 18 | 19 | B This is by no means a comprehensive 20 | list, nor is it a fixed list, of methods. This is simply 21 | the first draft of this, and a rough one at that. 22 | 23 | =head3 General 24 | 25 | These methods are getters for specific metadata about 26 | the class. 27 | 28 | =over 4 29 | 30 | =item C 31 | 32 | This returns the class name as a string. 33 | 34 | =item C 35 | 36 | This returns the class version as a value (type of value is TBD). 37 | 38 | =item C 39 | 40 | This returns the class authority as a string. 41 | 42 | =back 43 | 44 | =head3 Associated Metaobjects 45 | 46 | These are simple getters that store the assciated meta-objects 47 | that are relevant to this class. These are helpful both for 48 | introspection, but also when dynamically adding things to a 49 | class. 50 | 51 | =over 4 52 | 53 | =item C 54 | 55 | This is the base class which other classes will inherit from, this 56 | is typically some variant of Object 57 | 58 | =item C 59 | 60 | This defines the meta-object for attributes that is used by this 61 | class. 62 | 63 | =item C 64 | 65 | This defines the meta-object for methods that is used by this 66 | class. 67 | 68 | =back 69 | 70 | =head3 Utility 71 | 72 | =over 4 73 | 74 | =item C 75 | 76 | This is simply a predicate to determine if a given C<$class> is 77 | in the MRO of this class. 78 | 79 | =item C 80 | 81 | This will compare the internal UUID of class with another one to 82 | determine equality. 83 | 84 | =item C 85 | 86 | Clone this object and override any internal elements using 87 | the values in C<%params>. 88 | 89 | =item C 90 | 91 | This will check and return the most compatible metaclass available. 92 | 93 | =back 94 | 95 | =head3 "Special" Methods 96 | 97 | Right now we only have two "special" methods defined, but it is 98 | possible that we will make more. These are specially named methods 99 | that signify certain events that occur with a class. 100 | 101 | It is expected that these methods, if overridden, will always 102 | call the super-method. 103 | 104 | =over 4 105 | 106 | =item C 107 | 108 | Once a class has been completely constructed, this event method 109 | is called. 110 | 111 | =item C 112 | 113 | When a class must construct an instance, this method is called. 114 | The default action is to loop through all the attributes in the 115 | MRO and add slots to the instance accordingly and fill them with 116 | either the intial value, or a value from the C<%params>. 117 | 118 | =back 119 | 120 | =head3 Superclass 121 | 122 | These methods provide access to the superclass, as well as the 123 | compiled method resolution order of a class and a dispatcher 124 | mechanism. 125 | 126 | =over 4 127 | 128 | =item C 129 | 130 | This returns the superclass for this given class. 131 | 132 | =item C 133 | 134 | This sets the superclass for this given class. 135 | 136 | =item C 137 | 138 | This traverses the inheritance hierarchy to gather up all the 139 | classes in the same order in which method resolution would happen. 140 | 141 | =item C 142 | 143 | This will return a CODE ref iterator which will traverse the MRO 144 | of this class in the order specified through the C<$type> parameter. 145 | 146 | Currently only normal order (C<$type> is undef) and reverse order 147 | (C<$type> is 'reverse') are supported. But more may be supported 148 | later on. 149 | 150 | =back 151 | 152 | =head3 Constructor/Destructor 153 | 154 | We propose that constructors and destructors be implemented 155 | as methods, but not be available through the normal method 156 | dispatch. The following methods provide access to those items. 157 | 158 | =over 4 159 | 160 | =item C 161 | 162 | This returns the method object used for constructing the object. 163 | 164 | =item C 165 | 166 | Given a C<$method>, this sets it to the value of the constructor. 167 | 168 | =item C 169 | 170 | This returns the method object used for destructing the object. 171 | 172 | =item C 173 | 174 | Given a C<$method>, this sets it to the value of the destructor. 175 | 176 | =back 177 | 178 | =head3 Attributes 179 | 180 | =over 4 181 | 182 | =item C 183 | 184 | This returns the set of attributes for this given class. 185 | 186 | =item C 187 | 188 | This will add an C<$attribute> object to the set of attributes 189 | in this class. 190 | 191 | =item C 192 | 193 | Given a C<$name>, this will attempt to locate an attribute by that 194 | name within the MRO of the class. 195 | 196 | =back 197 | 198 | =head3 Methods 199 | 200 | =over 4 201 | 202 | =item C 203 | 204 | This returns the set of method for this given class. 205 | 206 | =item C 207 | 208 | This will add an C<$method> object to the set of methods in this 209 | class. 210 | 211 | =item C 212 | 213 | Given a C<$name>, this will attempt to locate a method by that name 214 | within the MRO of the class. 215 | 216 | =back 217 | 218 | =head1 AUTHOR 219 | 220 | Stevan Little Estevan.little@iinteractive.comE 221 | 222 | =head1 COPYRIGHT AND LICENSE 223 | 224 | Copyright 2011 Infinity Interactive, Inc. 225 | 226 | L 227 | 228 | This library is free software; you can redistribute it and/or modify 229 | it under the same terms as Perl itself. 230 | 231 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/mop/method.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Meta Object Protocol - Method Sub Protocol 6 | 7 | =head1 DESCRIPTION 8 | 9 | This document will describe the proposed API for the 10 | method sub-protocol of the MOP. 11 | 12 | Currently the method sub-protocol is very small, but 13 | it will almost certainly be expanded upon with methods 14 | to introspect the signature and such. 15 | 16 | =head2 API 17 | 18 | The method sub-protocol is (at this stage) completely 19 | immutable. The reason being that we believe it is 20 | dangerous to allow the manipulation of method internals 21 | simply for the huge potential impact that could have. 22 | Instead you are encouraged to simply clone a method 23 | and change the values during the clone process. 24 | 25 | B This is by no means a comprehensive 26 | list, nor is it a fixed list, of methods. This is simply 27 | the first draft of this, and a rough one at that. 28 | 29 | =head3 General 30 | 31 | =over 4 32 | 33 | =item C 34 | 35 | This returns the name of this particular method as a string. 36 | 37 | =item C 38 | 39 | This returns the body of this method as a CODE reference, 40 | which can be called using the normal CODE ref syntax. 41 | 42 | =item C 43 | 44 | Given an C<$invocant> and an optional array of arguments, 45 | this will execute the method within the scope of the 46 | C<$invocant>. 47 | 48 | =item C 49 | 50 | Clone this object and override any internal elements using 51 | the values in C<%params>. 52 | 53 | =back 54 | 55 | =head1 AUTHOR 56 | 57 | Stevan Little Estevan.little@iinteractive.comE 58 | 59 | =head1 COPYRIGHT AND LICENSE 60 | 61 | Copyright 2011 Infinity Interactive, Inc. 62 | 63 | L 64 | 65 | This library is free software; you can redistribute it and/or modify 66 | it under the same terms as Perl itself. 67 | 68 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/syntax/attributes.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Syntax & Semantics - Attributes 6 | 7 | =head1 DESCRIPTION 8 | 9 | This document introduces the proposed attribute syntax for the 10 | new object system for Perl. 11 | 12 | =head1 SYNTAX 13 | 14 | =head2 Attribute definition 15 | 16 | Attributes will be defined using the new C keyword. 17 | 18 | As with the C and C keywords, the C 19 | keyword is simply sugar for the underlying calls to the 20 | MOP. So for instance, the following code: 21 | 22 | has $bar = 10; 23 | 24 | Is (roughly) equivalent to the following raw MOP code: 25 | 26 | Attribute->new( 27 | name => '$bar', 28 | initial_value => sub { 10 } 29 | ); 30 | 31 | The interesting part here is that the initial value 32 | has been wrapped in a CODE ref. The details of this 33 | are explained below. 34 | 35 | =head2 The right-hand side of C<=> 36 | 37 | The value on the right-hand side of the C<=> sign in a 38 | C statement does not behave in the normal assignment 39 | way. Instead the value is stored as the initial value to 40 | be stored in any instance slot which corresponds to the 41 | attribute. 42 | 43 | For those familiar with lazy languages like Haskell, the 44 | value is basically like a thunk (see below for reference). 45 | 46 | =head3 String and Number literals 47 | 48 | Literal non-reference values are perfectly legal on the rhs of 49 | C<=>, meaning the following bits of code are fine: 50 | 51 | has $foo = "a string"; 52 | has $bar = 10; 53 | 54 | The value will be copied (as is the default behavior of Perl) 55 | when the instance is constructed. This is how it works in the 56 | prototype and how it should work in the final. 57 | 58 | =head3 Everything else 59 | 60 | If you want an object, an ARRAY ref, HASH ref or some other 61 | value not described above, then the value is wrapped in a 62 | thunk, so that this: 63 | 64 | has $bar = Some::Object->new; 65 | 66 | Which will essentially get transformed into this: 67 | 68 | has $bar = sub { Some::Object->new }; 69 | 70 | The CODE ref is then called when an instance is constructed 71 | and the return value placed into the instance slot. For the 72 | most part, this technique works and allows you to do all 73 | sorts of tricky stuff when initializing. 74 | 75 | =head1 QUESTIONS 76 | 77 | =head1 SEE ALSO 78 | 79 | =over 4 80 | 81 | =item Thunk (functional programming) 82 | 83 | L 84 | 85 | =back 86 | 87 | =head1 AUTHOR 88 | 89 | Stevan Little Estevan.little@iinteractive.comE 90 | 91 | =head1 COPYRIGHT AND LICENSE 92 | 93 | Copyright 2011 Infinity Interactive, Inc. 94 | 95 | L 96 | 97 | This library is free software; you can redistribute it and/or modify 98 | it under the same terms as Perl itself. 99 | 100 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/syntax/intro.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Syntax & Semantics - Introduction 6 | 7 | =head1 SYNOPSIS 8 | 9 | class Point { 10 | has $x = 0; 11 | has $y = 0; 12 | 13 | method clear { 14 | ($x, $y) = (0, 0); 15 | } 16 | } 17 | 18 | class Point3D ( extends => Point ) { 19 | has $z = 0; 20 | 21 | method clear { 22 | super; 23 | $z = 0; 24 | } 25 | } 26 | 27 | my $p = Point->new( x => 10, y => 10 ); 28 | 29 | my $p3d = Point3D->new( x => 10, y => 10, z => 1 ); 30 | 31 | =head1 DESCRIPTION 32 | 33 | This is an introduction to the syntax oriented documents of 34 | this proposal. 35 | 36 | =over 4 37 | 38 | =item L 39 | 40 | =item L 41 | 42 | =item L 43 | 44 | =item L 45 | 46 | =back 47 | 48 | =head1 AUTHOR 49 | 50 | Stevan Little Estevan.little@iinteractive.comE 51 | 52 | =head1 COPYRIGHT AND LICENSE 53 | 54 | Copyright 2011 Infinity Interactive, Inc. 55 | 56 | L 57 | 58 | This library is free software; you can redistribute it and/or modify 59 | it under the same terms as Perl itself. 60 | 61 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/syntax/metadata.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Syntax - Metadata 6 | 7 | =head1 DESCRIPTION 8 | 9 | A core component of this object system and (IMO) the key to 10 | getting a truly Perlish level of flexibility and extensibility, 11 | is the idea of metadata. Since this is a pretty over-used term, 12 | this document attempts to clarify exactly what this means. 13 | 14 | It would be safe to say that what I am proposing is along the 15 | same lines as Python Decorators, C#/.NET Attributes and Java 16 | Annotations. Which is to say that this is metadata being 17 | declared at compile time and being used by the compiler to 18 | make certain decisions as it does its work. 19 | 20 | However, unlike these other languages though, my proposed syntax 21 | is quite simple and should require nothing beyond what the Perl 22 | lexer can already understand. 23 | 24 | =head2 Metadata (the expression) 25 | 26 | A metadata expression is simply a Perl expression contained 27 | within a set of parentheses which, when evaluated, should 28 | result in metadata (the noun). Here are a few examples: 29 | 30 | ( is => 'rw', default => 100 ) 31 | 32 | ( map { $_ => 1 } qw( lazy closed ) ) 33 | 34 | The context in which this metedata expression is evaluated in 35 | is somewhat tricky since it will happen during compile-time. 36 | However this is not all that different in complexity from how 37 | C and other compile time blocks are dealt with. 38 | 39 | This metadata will be available as parameters to your meta 40 | classes and can be accessed by adding attributes. 41 | 42 | =head2 Metadata (noun) 43 | 44 | Metadata is the result of a metadata expression and simply a 45 | list of normal Perl values. 46 | 47 | It will likely be the common case that it will be a list of 48 | key-value pairs (aka. Perl hash) but it should not be restricted 49 | to be just that. This is a judgement for the consumer of 50 | the metadata to make. 51 | 52 | In later documents I will introduce three keywords; C, 53 | C and C. Each of these keywords should accept 54 | an optional metadata expression which would be feed to the 55 | underlying objects being constructed. 56 | 57 | =head1 NOTES 58 | 59 | In some ways I can see this as being some kind of general 60 | purpose mechanism, however it could get a little messy 61 | where the metadata is passed to the thing being annotated 62 | with the metadata. There would need to be an API for this 63 | and I believe that to be beyond the scope of these 64 | documents. 65 | 66 | =head1 SEE ALSO 67 | 68 | =over 4 69 | 70 | =item Expression evaluation at compile-time 71 | 72 | L 73 | 74 | =item Python Decorators 75 | 76 | L 77 | L 78 | L 79 | 80 | =item C# Attributes 81 | 82 | L 83 | 84 | =item Java Annotations 85 | 86 | L 87 | L 88 | L 89 | 90 | =back 91 | 92 | =head1 AUTHOR 93 | 94 | Stevan Little Estevan.little@iinteractive.comE 95 | 96 | =head1 COPYRIGHT AND LICENSE 97 | 98 | Copyright 2011 Infinity Interactive, Inc. 99 | 100 | L 101 | 102 | This library is free software; you can redistribute it and/or modify 103 | it under the same terms as Perl itself. 104 | 105 | =cut -------------------------------------------------------------------------------- /lib/mop/proposal/syntax/methods.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Perl 5 MOP - Syntax & Semantics - Methods 6 | 7 | =head1 DESCRIPTION 8 | 9 | This document introduces the proposed method syntax for the 10 | new object system for Perl. 11 | 12 | =head1 SYNTAX 13 | 14 | =head2 Method definition 15 | 16 | Methods will be defined using the new C keyword. 17 | 18 | As with the C keyword, the C keyword is 19 | simply sugar for the underlying calls to the MOP. So for 20 | instance, the following code: 21 | 22 | method foo ( $bar ) { $bar + 10 } 23 | 24 | Is (roughly) equivalent to the following raw MOP code: 25 | 26 | Method->new( 27 | name => 'foo', 28 | body => sub { 29 | my ($bar) = @_; 30 | $bar + 10; 31 | } 32 | ); 33 | 34 | The tricky part here is exactly how the body of a method 35 | is defined. 36 | 37 | =head1 QUESTIONS 38 | 39 | =head2 How do create a private method? 40 | 41 | Actually, private methods are not needed, allow me to explain. 42 | 43 | In most object systems that have true private methods, the private 44 | methods are completely hidden from the method dispatcher outside 45 | the scope of the defining class. This is different then most 46 | implementations of private methods that appear on CPAN because in 47 | most of those if the method is dispatched to from outside of the 48 | defining class, an error is thrown. 49 | 50 | In this proposed system we have a third alternative, which has 51 | the privacy necessary and can not be dispatched to. Here is some 52 | example code to illustrate. 53 | 54 | package Foo; 55 | use strict; 56 | use warnings; 57 | 58 | sub my_private_routine { ... } 59 | 60 | class Bar { 61 | method baz { 62 | my_private_routine( $self, ... ); 63 | } 64 | } 65 | 66 | Since classes can live inside packages, and share the package 67 | scope, there is nothing stopping a method in a class from calling 68 | a subroutine defined in the package. The result is that we have 69 | code which is visible inside the class, but which does not 70 | participate in the dispatching. 71 | 72 | The only drawback here is that these are subroutines and not 73 | methods, so if they need to access the instance, it will need 74 | to be passed to them explicitly. 75 | 76 | Additionally, while this subroutine is private to the class, it 77 | is still public within the package. Exactly how much this matters 78 | is up for debate and if it does present a problem it is simple 79 | enough to place a guard at the beginning of the subroutine like 80 | so: 81 | 82 | sub my_private_routine { 83 | die "This is a private routine" 84 | unless caller() eq __PACKAGE__; 85 | # ... 86 | } 87 | 88 | This should work correctly because the value of C<__PACKAGE__> 89 | within class should be that of the containing class. 90 | 91 | =head2 How do I create a protected method? 92 | 93 | I would propose that since private methods would be replaced 94 | by package subroutines, then protected methods could take the 95 | "prefix method name with an underscore" convention. There would 96 | be no actual enforcement of this, as with classic Perl OO it 97 | would purely be convention. 98 | 99 | =head1 AUTHOR 100 | 101 | Stevan Little Estevan.little@iinteractive.comE 102 | 103 | =head1 COPYRIGHT AND LICENSE 104 | 105 | Copyright 2011 Infinity Interactive, Inc. 106 | 107 | L 108 | 109 | This library is free software; you can redistribute it and/or modify 110 | it under the same terms as Perl itself. 111 | 112 | =cut -------------------------------------------------------------------------------- /lib/mop/syntax.pm: -------------------------------------------------------------------------------- 1 | package mop::syntax; 2 | 3 | use 5.014; 4 | use strict; 5 | use warnings; 6 | 7 | our $VERSION = '0.01'; 8 | our $AUTHORITY = 'cpan:STEVAN'; 9 | 10 | use Sub::Name (); 11 | 12 | sub setup_for { 13 | my $class = shift; 14 | my $pkg = shift; 15 | { 16 | no strict 'refs'; 17 | *{ $pkg . '::class' } = \&class; 18 | *{ $pkg . '::role' } = \&role; 19 | *{ $pkg . '::method' } = \&method; 20 | *{ $pkg . '::has' } = \&has; 21 | *{ $pkg . '::BUILD' } = \&BUILD; 22 | *{ $pkg . '::DEMOLISH' } = \&DEMOLISH; 23 | *{ $pkg . '::super' } = \&super; 24 | } 25 | } 26 | 27 | sub class { } 28 | 29 | sub role { } 30 | 31 | sub method { 32 | my ($name, $body) = @_; 33 | $::CLASS->add_method( 34 | $::CLASS->method_class->new( 35 | name => $name, 36 | ($body 37 | ? (body => Sub::Name::subname( $name, $body )) 38 | : ()), 39 | ) 40 | ) 41 | } 42 | 43 | sub has { 44 | my ($name, $ref, $metadata, $default) = @_; 45 | $::CLASS->add_attribute( 46 | $::CLASS->attribute_class->new( 47 | name => $name, 48 | initial_value => \$default, 49 | ($metadata ? %$metadata : ()), 50 | ) 51 | ); 52 | } 53 | 54 | sub BUILD { 55 | my ($body) = @_; 56 | $::CLASS->set_constructor( 57 | $::CLASS->method_class->new( 58 | name => 'BUILD', 59 | body => Sub::Name::subname( 'BUILD', $body ) 60 | ) 61 | ) 62 | } 63 | 64 | sub DEMOLISH { 65 | my ($body) = @_; 66 | $::CLASS->set_destructor( 67 | $::CLASS->method_class->new( 68 | name => 'DEMOLISH', 69 | body => Sub::Name::subname( 'DEMOLISH', $body ) 70 | ) 71 | ) 72 | } 73 | 74 | sub super { 75 | die "Cannot call super() outside of a method" unless defined $::SELF; 76 | my $invocant = $::SELF; 77 | my $method_name = (split '::' => ((caller(1))[3]))[-1]; 78 | my $dispatcher = $::CLASS->get_dispatcher; 79 | # find the method currently being called 80 | my $method = mop::WALKMETH( $dispatcher, $method_name ); 81 | while ( $method != $::CALLER ) { 82 | $method = mop::WALKMETH( $dispatcher, $method_name ); 83 | } 84 | # and advance past it by one 85 | $method = mop::WALKMETH( $dispatcher, $method_name ) 86 | || die "No super method ($method_name) found"; 87 | $method->execute( $invocant, @_ ); 88 | } 89 | 90 | sub build_class { 91 | my ($name, $metadata, $caller) = @_; 92 | my %metadata = %{ $metadata || {} }; 93 | 94 | my $class_Class = $^H{'mop/default_metaclass'} // $::Class; 95 | if ( exists $metadata{ 'metaclass' } ) { 96 | $class_Class = delete $metadata{ 'metaclass' }; 97 | } 98 | 99 | if ( exists $metadata{ 'extends' } ) { 100 | $metadata{ 'superclass' } = delete $metadata{ 'extends' }; 101 | } 102 | 103 | if ( exists $metadata{ 'with' } ) { 104 | $metadata{ 'roles' } = delete $metadata{ 'with' }; 105 | } 106 | 107 | if ( exists $metadata{ 'does' } ) { 108 | $metadata{ 'roles' } = delete $metadata{ 'does' }; 109 | } 110 | 111 | my $superclass = $metadata{ 'superclass' }; 112 | 113 | if ( $superclass ) { 114 | my $compatible = $class_Class->get_compatible_class( 115 | mop::internal::instance::get_class( $superclass ) 116 | ); 117 | $class_Class = $compatible 118 | if defined $compatible; 119 | } 120 | 121 | $class_Class->new( 122 | name => ($caller eq 'main' ? $name : "${caller}::${name}"), 123 | %metadata 124 | ); 125 | } 126 | 127 | sub build_role { 128 | my ($name, $metadata, $caller) = @_; 129 | my %metadata = %{ $metadata || {} }; 130 | 131 | my $role_Class = $^H{'mop/default_role_metaclass'} // $::Role; 132 | if ( exists $metadata{ 'metaclass' } ) { 133 | $role_Class = delete $metadata{ 'metaclass' }; 134 | } 135 | 136 | if ( exists $metadata{ 'with' } ) { 137 | $metadata{ 'roles' } = delete $metadata{ 'with' }; 138 | } 139 | 140 | if ( exists $metadata{ 'does' } ) { 141 | $metadata{ 'roles' } = delete $metadata{ 'does' }; 142 | } 143 | 144 | $role_Class->new( 145 | name => ($caller eq 'main' ? $name : "${caller}::${name}"), 146 | %metadata 147 | ); 148 | } 149 | 150 | sub finalize_class { 151 | my ($name, $class, $caller) = @_; 152 | 153 | $class->FINALIZE; 154 | 155 | { 156 | no strict 'refs'; 157 | *{"${caller}::${name}"} = Sub::Name::subname( $name, sub () { $class } ); 158 | } 159 | } 160 | 161 | sub finalize_role { 162 | my ($name, $role, $caller) = @_; 163 | 164 | $role->FINALIZE; 165 | 166 | { 167 | no strict 'refs'; 168 | *{"${caller}::${name}"} = Sub::Name::subname( $name, sub () { $role } ); 169 | } 170 | } 171 | 172 | 1; 173 | 174 | __END__ 175 | 176 | =pod 177 | 178 | =head1 NAME 179 | 180 | mop::syntax - The syntax module for the p5-mop 181 | 182 | =head1 SYNOPSIS 183 | 184 | use mop::syntax; 185 | 186 | =head1 DESCRIPTION 187 | 188 | This module uses Devel::CallParser to provide the desired 189 | syntax for the p5-mop. 190 | 191 | =head1 AUTHORS 192 | 193 | Stevan Little Estevan.little@iinteractive.comE 194 | 195 | Jesse Luehrs Edoy at tozt dot netE 196 | 197 | =head1 COPYRIGHT AND LICENSE 198 | 199 | Copyright 2011 Infinity Interactive, Inc. 200 | 201 | L 202 | 203 | This library is free software; you can redistribute it and/or modify 204 | it under the same terms as Perl itself. 205 | 206 | =cut 207 | -------------------------------------------------------------------------------- /t/000-examples/001-basic-example.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Point { 11 | has $x = 0; 12 | has $y = 0; 13 | 14 | method x { $x } 15 | method y { $y } 16 | 17 | method set_x ($new_x) { 18 | $x = $new_x; 19 | } 20 | 21 | method clear { 22 | ($x, $y) = (0, 0); 23 | } 24 | 25 | method dump { 26 | +{ x => $self->x, y => $self->y } 27 | } 28 | } 29 | 30 | # ... subclass it ... 31 | 32 | class Point3D (extends => Point) { 33 | has $z = 0; 34 | 35 | method z { $z } 36 | 37 | method dump { 38 | my $orig = super; 39 | $orig->{'z'} = $z; 40 | $orig; 41 | } 42 | } 43 | 44 | ## Test the class 45 | 46 | like mop::uuid_of( Point ), qr/[0-9A-Z]{8}-[0-9A-Z]{4}-[0-9A-Z]{4}-[0-9A-Z]{4}-[0-9A-Z]{12}/i, '... got the expected uuid format'; 47 | is mop::class_of( Point ), $::Class, '... got the class we expected'; 48 | ok Point->isa( $::Object ), '... class Point is a Object'; 49 | ok Point->is_subclass_of( $::Object ), '... class Point is a subclass of Object'; 50 | is Point->get_superclass, $::Object, '... got the superclass we expected'; 51 | is_deeply Point->get_mro, [ Point, $::Object ], '... got the mro we expected'; 52 | is_deeply 53 | [ sort { $a cmp $b } map { $_->get_name } values %{ Point->get_all_attributes } ], 54 | [ '$x', '$y' ], 55 | '... got the attribute list we expected'; 56 | 57 | ## Test an instance 58 | 59 | my $p = Point->new( x => 100, y => 320 ); 60 | ok $p->isa( Point ), '... p is a Point'; 61 | 62 | like mop::uuid_of( $p ), qr/[0-9A-Z]{8}-[0-9A-Z]{4}-[0-9A-Z]{4}-[0-9A-Z]{4}-[0-9A-Z]{12}/i, '... got the expected uuid format'; 63 | is mop::class_of( $p ), Point, '... got the class we expected'; 64 | 65 | is $p->x, 100, '... got the right value for x'; 66 | is $p->y, 320, '... got the right value for y'; 67 | is_deeply $p->dump, { x => 100, y => 320 }, '... got the right value from dump'; 68 | 69 | $p->set_x(10); 70 | is $p->x, 10, '... got the right value for x'; 71 | 72 | is_deeply $p->dump, { x => 10, y => 320 }, '... got the right value from dump'; 73 | 74 | my $p2 = Point->new( x => 1, y => 30 ); 75 | 76 | isnt mop::uuid_of( $p ), mop::uuid_of( $p2 ), '... not the same instances'; 77 | 78 | is $p2->x, 1, '... got the right value for x'; 79 | is $p2->y, 30, '... got the right value for y'; 80 | is_deeply $p2->dump, { x => 1, y => 30 }, '... got the right value from dump'; 81 | 82 | $p2->set_x(500); 83 | is $p2->x, 500, '... got the right value for x'; 84 | is_deeply $p2->dump, { x => 500, y => 30 }, '... got the right value from dump'; 85 | 86 | is $p->x, 10, '... got the right value for x'; 87 | is $p->y, 320, '... got the right value for y'; 88 | is_deeply $p->dump, { x => 10, y => 320 }, '... got the right value from dump'; 89 | 90 | $p->clear; 91 | is $p->x, 0, '... got the right value for x'; 92 | is $p->y, 0, '... got the right value for y'; 93 | is_deeply $p->dump, { x => 0, y => 0 }, '... got the right value from dump'; 94 | 95 | ## Test the subclass 96 | 97 | is mop::class_of( Point3D ), $::Class, '... got the class we expected'; 98 | ok Point3D->isa( $::Object ), '... class Point3D is a Object'; 99 | ok Point3D->is_subclass_of( Point ), '... class Point3D is a subclass of Point'; 100 | ok Point3D->is_subclass_of( $::Object ), '... class Point3D is a subclass of Object'; 101 | is Point3D->get_superclass, Point, '... got the superclass we expected'; 102 | is_deeply Point3D->get_mro, [ Point3D, Point, $::Object ], '... got the mro we expected'; 103 | is_deeply 104 | [ sort map { $_->get_name } values %{ Point3D->get_all_attributes } ], 105 | [ '$x', '$y', '$z' ], 106 | '... got the attributes we expected'; 107 | 108 | 109 | ## Test the instance 110 | 111 | my $p3d = Point3D->new( x => 1, y => 2, z => 3 ); 112 | ok $p3d->isa( Point3D ), '... p3d is a Point3D'; 113 | ok $p3d->isa( Point ), '... p3d is a Point'; 114 | 115 | is $p3d->x, 1, '... got the right value for x'; 116 | is $p3d->y, 2, '... got the right value for y'; 117 | is $p3d->z, 3, '... got the right value for z'; 118 | 119 | is_deeply $p3d->dump, { x => 1, y => 2, z => 3 }, '... go the right value from dump'; 120 | 121 | ## test the default values 122 | 123 | { 124 | my $p = Point->new; 125 | is_deeply $p->dump, { x => 0, y => 0 }, '... go the right value from dump'; 126 | 127 | my $p3d = Point3D->new; 128 | is_deeply $p3d->dump, { x => 0, y => 0, z => 0 }, '... go the right value from dump'; 129 | } 130 | 131 | done_testing; 132 | 133 | 134 | 135 | -------------------------------------------------------------------------------- /t/000-examples/002-basic-example.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | class BankAccount { 12 | has $balance = 0; 13 | 14 | method balance { $balance } 15 | 16 | method deposit ($amount) { $balance += $amount } 17 | 18 | method withdraw ($amount) { 19 | ($amount <= $balance) 20 | || die "Account overdrawn"; 21 | $balance -= $amount; 22 | } 23 | } 24 | 25 | class CheckingAccount (extends => BankAccount) { 26 | has $overdraft_account; 27 | 28 | method overdraft_account { $overdraft_account } 29 | 30 | method withdraw ($amount) { 31 | 32 | my $overdraft_amount = $amount - $self->balance; 33 | 34 | if ( $overdraft_account && $overdraft_amount > 0 ) { 35 | $overdraft_account->withdraw( $overdraft_amount ); 36 | $self->deposit( $overdraft_amount ); 37 | } 38 | 39 | super( $amount ); 40 | } 41 | } 42 | 43 | ok BankAccount->is_subclass_of( $::Object ), '... BankAccount is a subclass of Object'; 44 | 45 | ok CheckingAccount->is_subclass_of( BankAccount ), '... CheckingAccount is a subclass of BankAccount'; 46 | ok CheckingAccount->is_subclass_of( $::Object ), '... CheckingAccount is a subclass of Object'; 47 | 48 | my $savings = BankAccount->new( balance => 250 ); 49 | is mop::class_of( $savings ), BankAccount, '... got the class we expected'; 50 | ok $savings->isa( BankAccount ), '... savings is an instance of BankAccount'; 51 | 52 | is $savings->balance, 250, '... got the savings balance we expected'; 53 | 54 | $savings->withdraw( 50 ); 55 | is $savings->balance, 200, '... got the savings balance we expected'; 56 | 57 | $savings->deposit( 150 ); 58 | is $savings->balance, 350, '... got the savings balance we expected'; 59 | 60 | like(exception { 61 | $savings->withdraw( 400 ); 62 | }, qr/Account overdrawn/, '... got the expection we expected'); 63 | 64 | my $checking = CheckingAccount->new( 65 | overdraft_account => $savings, 66 | ); 67 | is mop::class_of( $checking ), CheckingAccount, '... got the class we expected'; 68 | ok $checking->isa( CheckingAccount ), '... checking is an instance of BankAccount'; 69 | ok $checking->isa( BankAccount ), '... checking is an instance of BankAccount'; 70 | 71 | is $checking->balance, 0, '... got the checking balance we expected'; 72 | 73 | $checking->deposit( 100 ); 74 | is $checking->balance, 100, '... got the checking balance we expected'; 75 | is $checking->overdraft_account, $savings, '... got the right overdraft account'; 76 | 77 | $checking->withdraw( 50 ); 78 | is $checking->balance, 50, '... got the checking balance we expected'; 79 | is $savings->balance, 350, '... got the savings balance we expected'; 80 | 81 | $checking->withdraw( 200 ); 82 | is $checking->balance, 0, '... got the checking balance we expected'; 83 | is $savings->balance, 200, '... got the savings balance we expected'; 84 | 85 | done_testing; 86 | 87 | 88 | 89 | -------------------------------------------------------------------------------- /t/000-examples/003-basic-example.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | role Eq { 12 | method equal_to; 13 | 14 | method not_equal_to ($other) { 15 | not $self->equal_to($other); 16 | } 17 | } 18 | 19 | role Comparable ( with => [Eq] ) { 20 | method compare; 21 | method equal_to ($other) { 22 | $self->compare($other) == 0; 23 | } 24 | 25 | method greater_than ($other) { 26 | $self->compare($other) == 1; 27 | } 28 | 29 | method less_than ($other) { 30 | $self->compare($other) == -1; 31 | } 32 | 33 | method greater_than_or_equal_to ($other) { 34 | $self->greater_than($other) || $self->equal_to($other); 35 | } 36 | 37 | method less_than_or_equal_to ($other) { 38 | $self->less_than($other) || $self->equal_to($other); 39 | } 40 | } 41 | 42 | role Printable { 43 | method to_string; 44 | } 45 | 46 | class US::Currency ( with => [ Comparable, Printable ] ) { 47 | has $amount = 0; 48 | 49 | method amount { $amount } 50 | 51 | method compare ($other) { 52 | $amount <=> $other->amount; 53 | } 54 | 55 | method to_string { 56 | sprintf '$%0.2f USD' => $amount; 57 | } 58 | } 59 | 60 | is(mop::class_of(Eq), $::Role, '... Eq is a role'); 61 | is(mop::class_of(Comparable), $::Role, '... Comparable is a role'); 62 | ok(Comparable->does_role( Eq ), '... Comparable does the Eq role'); 63 | is(mop::class_of(Printable), $::Role, '... Printable is a role'); 64 | is(mop::class_of(US::Currency), $::Class, '... US::Currency is a class'); 65 | ok(US::Currency->does_role( Eq ), '... US::Currency does Eq'); 66 | ok(US::Currency->does_role( Comparable ), '... US::Currency does Comparable'); 67 | ok(US::Currency->does_role( Printable ), '... US::Currency does Printable'); 68 | 69 | ok(Eq->find_method('equal_to')->is_stub, '... EQ::equal_to is a stub method'); 70 | ok(!Eq->find_method('not_equal_to')->is_stub, '... EQ::not_equal_to is NOT a stub method'); 71 | 72 | my $dollar = US::Currency->new( amount => 10 ); 73 | ok($dollar->isa( US::Currency ), '... the dollar is a US::Currency instance'); 74 | ok($dollar->does( Eq ), '... the dollar does the Eq role'); 75 | ok($dollar->does( Comparable ), '... the dollar does the Comparable role'); 76 | ok($dollar->does( Printable ), '... the dollar does the Printable role'); 77 | 78 | can_ok($dollar, 'equal_to'); 79 | can_ok($dollar, 'not_equal_to'); 80 | 81 | can_ok($dollar, 'greater_than'); 82 | can_ok($dollar, 'greater_than_or_equal_to'); 83 | can_ok($dollar, 'less_than'); 84 | can_ok($dollar, 'less_than_or_equal_to'); 85 | 86 | can_ok($dollar, 'compare'); 87 | can_ok($dollar, 'to_string'); 88 | 89 | is($dollar->to_string, '$10.00 USD', '... got the right to_string value'); 90 | 91 | ok($dollar->equal_to( $dollar ), '... we are equal to ourselves'); 92 | ok(!$dollar->not_equal_to( $dollar ), '... we are not not equal to ourselves'); 93 | 94 | ok(US::Currency->new( amount => 20 )->greater_than( $dollar ), '... 20 is greater than 10'); 95 | ok(!US::Currency->new( amount => 2 )->greater_than( $dollar ), '... 2 is not greater than 10'); 96 | 97 | ok(!US::Currency->new( amount => 10 )->greater_than( $dollar ), '... 10 is not greater than 10'); 98 | ok(US::Currency->new( amount => 10 )->greater_than_or_equal_to( $dollar ), '... 10 is greater than or equal to 10'); 99 | 100 | 101 | done_testing; 102 | -------------------------------------------------------------------------------- /t/000-examples/004-basic-example.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | use Scalar::Util qw[ isweak weaken ]; 11 | 12 | class BinaryTree { 13 | has $node; 14 | has $parent; 15 | has $left; 16 | has $right; 17 | 18 | BUILD { weaken( $parent ) if $parent } 19 | 20 | method node ($n) { 21 | $node = $n if $n; 22 | $node; 23 | } 24 | 25 | method has_parent { defined $parent } 26 | method parent { $parent } 27 | 28 | method left { $left //= $class->new( parent => $self ) } 29 | method has_left { defined $left } 30 | 31 | method right { $right //= $class->new( parent => $self ) } 32 | method has_right { defined $right } 33 | } 34 | 35 | { 36 | my $t = BinaryTree->new; 37 | ok($t->isa(BinaryTree), '... this is a BinaryTree object'); 38 | 39 | ok(!$t->has_parent, '... this tree has no parent'); 40 | 41 | ok(!$t->has_left, '... left node has not been created yet'); 42 | ok(!$t->has_right, '... right node has not been created yet'); 43 | 44 | ok($t->left->isa(BinaryTree), '... left is a BinaryTree object'); 45 | ok($t->right->isa(BinaryTree), '... right is a BinaryTree object'); 46 | 47 | ok($t->has_left, '... left node has now been created'); 48 | ok($t->has_right, '... right node has now been created'); 49 | 50 | ok($t->left->has_parent, '... left has a parent'); 51 | is($t->left->parent, $t, '... and it is us'); 52 | ok(isweak(${ $t->left->{'slots'}->{'$parent'} }), '... the value is weakened'); 53 | 54 | ok($t->right->has_parent, '... right has a parent'); 55 | is($t->right->parent, $t, '... and it is us'); 56 | ok(isweak(${ $t->right->{'slots'}->{'$parent'} }), '... the value is weakened'); 57 | } 58 | 59 | class MyBinaryTree ( extends => BinaryTree ) {} 60 | 61 | { 62 | my $t = MyBinaryTree->new; 63 | ok($t->isa(MyBinaryTree), '... this is a MyBinaryTree object'); 64 | ok($t->isa(BinaryTree), '... this is a BinaryTree object'); 65 | 66 | ok(!$t->has_parent, '... this tree has no parent'); 67 | 68 | ok(!$t->has_left, '... left node has not been created yet'); 69 | ok(!$t->has_right, '... right node has not been created yet'); 70 | 71 | ok($t->left->isa(MyBinaryTree), '... left is a MyBinaryTree object'); 72 | ok($t->right->isa(MyBinaryTree), '... right is a MyBinaryTree object'); 73 | 74 | ok($t->has_left, '... left node has now been created'); 75 | ok($t->has_right, '... right node has now been created'); 76 | } 77 | 78 | done_testing; -------------------------------------------------------------------------------- /t/000-examples/005-basic-example.t: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use mop; 8 | 9 | class LinkedList { 10 | has $head; 11 | has $tail; 12 | has $count = 0; 13 | 14 | method head { $head } 15 | method tail { $tail } 16 | method count { $count } 17 | 18 | method append ($node) { 19 | unless($tail) { 20 | $tail = $node; 21 | $head = $node; 22 | $count++; 23 | return; 24 | } 25 | $tail->set_next($node); 26 | $node->set_previous($tail); 27 | $tail = $node; 28 | $count++; 29 | } 30 | 31 | method insert ($index, $node) { 32 | die "Index ($index) out of bounds" 33 | if $index < 0 or $index > $count - 1; 34 | 35 | my $tmp = $head; 36 | $tmp = $tmp->get_next while($index--); 37 | $node->set_previous($tmp->get_previous); 38 | $node->set_next($tmp); 39 | $tmp->get_previous->set_next($node); 40 | $tmp->set_previous($node); 41 | $count++; 42 | } 43 | 44 | method remove ($index) { 45 | die "Index ($index) out of bounds" 46 | if $index < 0 or $index > $count - 1; 47 | 48 | my $tmp = $head; 49 | $tmp = $tmp->get_next while($index--); 50 | $tmp->get_previous->set_next($tmp->get_next); 51 | $tmp->get_next->set_previous($tmp->get_previous); 52 | $count--; 53 | $tmp->detach(); 54 | } 55 | 56 | method prepend ($node) { 57 | unless($head) { 58 | $tail = $node; 59 | $head = $node; 60 | $count++; 61 | return; 62 | } 63 | $head->set_previous($node); 64 | $node->set_next($head); 65 | $head = $node; 66 | $count++; 67 | } 68 | 69 | method sum { 70 | my $sum = 0; 71 | my $tmp = $head; 72 | do { $sum += $tmp->get_value } while($tmp = $tmp->get_next); 73 | return $sum; 74 | } 75 | } 76 | 77 | class LinkedListNode { 78 | has $previous; 79 | has $next; 80 | has $value; 81 | 82 | method get_previous { $previous } 83 | method get_next { $next } 84 | method get_value { $value } 85 | method set_previous($x) { $previous = $x; } 86 | method set_next($x) { $next = $x; } 87 | method set_value($x) { $value = $x; } 88 | 89 | method detach { ($previous, $next) = (undef) x 2; $self } 90 | } 91 | 92 | { 93 | my $ll = LinkedList->new(); 94 | 95 | for(0..9) { 96 | $ll->append( 97 | LinkedListNode->new(value => $_) 98 | ); 99 | } 100 | 101 | is($ll->head->get_value, 0, '... head is 0'); 102 | is($ll->tail->get_value, 9, '... tail is 9'); 103 | is($ll->count, 10, '... count is 10'); 104 | 105 | $ll->prepend(LinkedListNode->new(value => -1)); 106 | is($ll->count, 11, '... count is now 11'); 107 | 108 | $ll->insert(5, LinkedListNode->new(value => 11)); 109 | is($ll->count, 12, '... count is now 12'); 110 | 111 | my $node = $ll->remove(8); 112 | is($ll->count, 11, '... count is 11 again'); 113 | 114 | ok(!$node->get_next, '... detached node does not have a next'); 115 | ok(!$node->get_previous, '... detached node does not have a previous'); 116 | is($node->get_value, 6, '... detached node has the right value'); 117 | ok($node->isa(LinkedListNode), '... node is a LinkedListNode'); 118 | 119 | ok(exception { $ll->remove(99) }, '... removing out of range produced error'); 120 | ok(exception { $ll->insert(-1, LinkedListNode->new(value => 2)) }, 121 | '... inserting out of range produced error' 122 | ); 123 | 124 | is($ll->sum, 49, '... things sum correctly'); 125 | } 126 | 127 | done_testing; 128 | -------------------------------------------------------------------------------- /t/000-examples/010-throwable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | eval { require Devel::StackTrace; 1 } 10 | or plan skip_all => "Devel::StackTrace is required for this test"; 11 | } 12 | 13 | use mop; 14 | 15 | role Throwable { 16 | 17 | has $message = ''; 18 | has $stack_trace = Devel::StackTrace->new( 19 | frame_filter => sub { 20 | $_[0]->{'caller'}->[3] !~ /^mop\:\:/ && 21 | $_[0]->{'caller'}->[0] !~ /^mop\:\:/ 22 | } 23 | ); 24 | 25 | method message { $message } 26 | method stack_trace { $stack_trace } 27 | method throw { die $self } 28 | method as_string { $message . "\n\n" . $stack_trace->as_string } 29 | } 30 | 31 | class MyError ( with => [Throwable] ) {} 32 | 33 | sub foo { MyError->new( message => "HELLO" )->throw } 34 | sub bar { foo() } 35 | 36 | eval { bar }; 37 | my $e = $@; 38 | 39 | ok( $e->isa( MyError ), '... the exception is a Throwable object' ); 40 | ok( $e->does( Throwable ), '... the exception does the Throwable role' ); 41 | 42 | is( $e->message, 'HELLO', '... got the exception' ); 43 | 44 | isa_ok( $e->stack_trace, 'Devel::StackTrace' ); 45 | 46 | my $file = __FILE__; 47 | $file =~ s/^\.\///; 48 | 49 | is( 50 | $e->stack_trace->as_string, 51 | qq[Trace begun at $file line 34 52 | main::bar at $file line 36 53 | eval {...} at $file line 36 54 | ], 55 | '... got the exception' 56 | ); 57 | 58 | done_testing; 59 | 60 | -------------------------------------------------------------------------------- /t/010-core/100-new.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | =pod 11 | 12 | Every new instance created should be a new reference 13 | but it should link back to the same class data. 14 | 15 | =cut 16 | 17 | class Foo {} 18 | 19 | my $foo = Foo->new; 20 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 21 | ok( $foo->isa( $::Object ), '... the object is derived from class Object' ); 22 | is( mop::class_of( $foo ), Foo, '... the class of this object is Foo' ); 23 | like( "$foo", qr/^Foo/, '... object stringification includes the class name' ); 24 | 25 | { 26 | my $foo2 = Foo->new; 27 | ok( $foo2->isa( Foo ), '... the object is from class Foo' ); 28 | ok( $foo2->isa( $::Object ), '... the object is derived from class Object' ); 29 | is( mop::class_of( $foo2 ), Foo, '... the class of this object is Foo' ); 30 | 31 | isnt( $foo, $foo2, '... these are not the same objects' ); 32 | is( mop::class_of($foo), mop::class_of($foo2), '... these two objects share the same class' ); 33 | } 34 | 35 | done_testing; 36 | -------------------------------------------------------------------------------- /t/010-core/102-clone.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use mop; 7 | 8 | { 9 | my $method = $::Method->new( 10 | name => 'foo', 11 | body => sub { "FOO" }, 12 | ); 13 | my $attribute = $::Attribute->new( 14 | name => '$foo', 15 | initial_value => \sub { "OOF" }, 16 | ); 17 | 18 | my $Foo = do { 19 | my $c = $::Class->new(name => 'Foo'); 20 | $c->add_method($method->clone); 21 | $c->add_attribute($attribute->clone); 22 | $c->FINALIZE; 23 | $c 24 | }; 25 | my $Bar = do { 26 | my $c = $::Class->new(name => 'Bar'); 27 | $c->add_method($method->clone); 28 | $c->add_attribute($attribute->clone); 29 | $c->FINALIZE; 30 | $c 31 | }; 32 | 33 | my $foo = $Foo->new; 34 | can_ok($foo, 'foo'); 35 | is($foo->foo, 'FOO'); 36 | is(mop::internal::instance::get_slot_at($foo, '$foo'), 'OOF'); 37 | 38 | my $bar = $Bar->new; 39 | can_ok($bar, 'foo'); 40 | is($bar->foo, 'FOO'); 41 | is(mop::internal::instance::get_slot_at($bar, '$foo'), 'OOF'); 42 | 43 | is($Foo->find_method('foo')->get_body, $method->get_body); 44 | is($Bar->find_method('foo')->get_body, $method->get_body); 45 | is($Foo->find_method('foo')->get_body, $Bar->find_method('foo')->get_body); 46 | 47 | isnt($Foo->find_method('foo'), $method); 48 | isnt($Bar->find_method('foo'), $method); 49 | isnt($Foo->find_method('foo'), $Bar->find_method('foo')); 50 | 51 | isnt($Foo->find_attribute('$foo'), $attribute); 52 | isnt($Bar->find_attribute('$foo'), $attribute); 53 | isnt($Foo->find_attribute('$foo'), $Bar->find_attribute('$foo')); 54 | } 55 | 56 | { 57 | my $method = $::Method->new( 58 | name => 'bar', 59 | body => sub { "FOO" }, 60 | ); 61 | my $attribute = $::Attribute->new( 62 | name => '$bar', 63 | initial_value => \sub { "OOF" }, 64 | ); 65 | 66 | my $Foo = do { 67 | my $c = $::Class->new(name => 'Foo'); 68 | $c->add_method($method->clone(name => 'foo')); 69 | $c->add_attribute($attribute->clone(name => '$foo')); 70 | $c->FINALIZE; 71 | $c 72 | }; 73 | my $Bar = do { 74 | my $c = $::Class->new(name => 'Bar'); 75 | $c->add_method($method->clone(body => sub { "BAR" })); 76 | $c->add_attribute($attribute->clone(initial_value => \sub { "RAB" })); 77 | $c->FINALIZE; 78 | $c 79 | }; 80 | 81 | my $foo = $Foo->new; 82 | can_ok($foo, 'foo'); 83 | ok(!$foo->can('bar')); 84 | is($foo->foo, 'FOO'); 85 | is(mop::internal::instance::get_slot_at($foo, '$foo'), 'OOF'); 86 | is(mop::internal::instance::get_slot_at($foo, '$bar'), undef); 87 | 88 | my $bar = $Bar->new; 89 | ok(!$bar->can('foo')); 90 | can_ok($bar, 'bar'); 91 | is($bar->bar, 'BAR'); 92 | is(mop::internal::instance::get_slot_at($bar, '$foo'), undef); 93 | is(mop::internal::instance::get_slot_at($bar, '$bar'), 'RAB'); 94 | 95 | is($Foo->find_method('foo')->get_body, $method->get_body); 96 | isnt($Bar->find_method('bar')->get_body, $method->get_body); 97 | isnt($Foo->find_method('foo')->get_body, $Bar->find_method('bar')->get_body); 98 | 99 | isnt($Foo->find_method('foo'), $method); 100 | isnt($Bar->find_method('bar'), $method); 101 | isnt($Foo->find_method('foo'), $Bar->find_method('bar')); 102 | 103 | isnt($Foo->find_attribute('$foo'), $attribute); 104 | isnt($Bar->find_attribute('$bar'), $attribute); 105 | isnt($Foo->find_attribute('$foo'), $Bar->find_attribute('$bar')); 106 | } 107 | 108 | done_testing; 109 | -------------------------------------------------------------------------------- /t/010-core/103-hash-attribute.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | BEGIN { plan skip_all => "hash attributes not yet implemented" } 11 | 12 | my $BAZ = []; 13 | 14 | class Foo { 15 | has %bar = (baz => $BAZ); 16 | method bar { \%bar } 17 | }; 18 | 19 | my $foo = Foo->new; 20 | is_deeply( $foo->bar, { baz => [] }, '... got the expected value' ); 21 | is( $foo->bar->{'baz'}, $BAZ, '... these are the same values' ); 22 | 23 | { 24 | my $foo2 = Foo->new; 25 | is_deeply( $foo2->bar, { baz => [] }, '... got the expected value' ); 26 | 27 | isnt( $foo->bar, $foo2->bar, '... these are not the same values' ); 28 | is( $foo2->bar->{'baz'}, $BAZ, '... these are the same values' ); 29 | is( $foo->bar->{'baz'}, $foo2->bar->{'baz'}, '... these are the same values' ); 30 | } 31 | 32 | done_testing; 33 | 34 | -------------------------------------------------------------------------------- /t/010-core/104-array-attribute.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | BEGIN { plan skip_all => "array attributes not yet implemented" } 11 | 12 | my $BAZ = []; 13 | 14 | class Foo { 15 | has @bar = ('baz', $BAZ); 16 | method bar { \@bar } 17 | }; 18 | 19 | my $foo = Foo->new; 20 | is_deeply( $foo->bar, [ 'baz', [] ], '... got the expected value' ); 21 | is( $foo->bar->[1], $BAZ, '... these are the same values' ); 22 | 23 | { 24 | my $foo2 = Foo->new; 25 | is_deeply( $foo2->bar, [ 'baz', [] ], '... got the expected value' ); 26 | 27 | isnt( $foo->bar, $foo2->bar, '... these are not the same values' ); 28 | is( $foo2->bar->[1], $BAZ, '... these are the same values' ); 29 | is( $foo->bar->[1], $foo2->bar->[1], '... these are the same values' ); 30 | } 31 | 32 | done_testing; 33 | 34 | -------------------------------------------------------------------------------- /t/010-core/110-BUILD.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | 12 | has $collector = []; 13 | 14 | method collector { $collector }; 15 | 16 | method collect ($stuff) { 17 | push @{ $collector } => $stuff; 18 | } 19 | 20 | BUILD { 21 | $self->collect( 'Foo' ); 22 | } 23 | } 24 | 25 | class Bar (extends => Foo) { 26 | 27 | BUILD { 28 | $self->collect( 'Bar' ); 29 | } 30 | } 31 | 32 | class Baz (extends => Bar) { 33 | 34 | BUILD { 35 | $self->collect( 'Baz' ); 36 | } 37 | } 38 | 39 | my $foo = Foo->new; 40 | is_deeply($foo->collector, ['Foo'], '... got the expected collection'); 41 | 42 | { 43 | my $foo2 = Foo->new; 44 | isnt( $foo->collector, $foo2->collector, '... we have two different array refs' ); 45 | } 46 | 47 | my $bar = Bar->new; 48 | is_deeply($bar->collector, ['Foo', 'Bar'], '... got the expected collection'); 49 | isnt( $foo->collector, $bar->collector, '... we have two different array refs' ); 50 | 51 | my $baz = Baz->new; 52 | is_deeply($baz->collector, ['Foo', 'Bar', 'Baz'], '... got the expected collection'); 53 | isnt( $foo->collector, $baz->collector, '... we have two different array refs' ); 54 | isnt( $bar->collector, $baz->collector, '... we have two different array refs' ); 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/010-core/111-DEMOLISH.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my $collector; 11 | 12 | class Foo { 13 | 14 | method collect ($stuff) { 15 | push @{ $collector } => $stuff; 16 | } 17 | 18 | DEMOLISH { 19 | $self->collect( 'Foo' ); 20 | } 21 | } 22 | 23 | class Bar (extends => Foo) { 24 | 25 | DEMOLISH { 26 | $self->collect( 'Bar' ); 27 | } 28 | } 29 | 30 | class Baz (extends => Bar) { 31 | 32 | DEMOLISH { 33 | $self->collect( 'Baz' ); 34 | } 35 | } 36 | 37 | $collector = []; 38 | Foo->new; 39 | is_deeply($collector, ['Foo'], '... got the expected collection'); 40 | 41 | $collector = []; 42 | Bar->new; 43 | is_deeply($collector, ['Bar', 'Foo'], '... got the expected collection'); 44 | 45 | $collector = []; 46 | Baz->new; 47 | is_deeply($collector, ['Baz', 'Bar', 'Foo'], '... got the expected collection'); 48 | 49 | done_testing; 50 | -------------------------------------------------------------------------------- /t/010-core/120-super.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | 11 | class Foo { 12 | method foo { "FOO" } 13 | } 14 | 15 | class FooBar ( extends => Foo ) { 16 | method foo { super . "-FOOBAR" } 17 | } 18 | 19 | class FooBarBaz ( extends => FooBar ) { 20 | method foo { super . "-FOOBARBAZ" } 21 | } 22 | 23 | class FooBarBazGorch ( extends => FooBarBaz ) { 24 | method foo { super . "-FOOBARBAZGORCH" } 25 | } 26 | 27 | my $foo = FooBarBazGorch->new; 28 | ok( $foo->isa( FooBarBazGorch ), '... the object is from class FooBarBazGorch' ); 29 | ok( $foo->isa( FooBarBaz ), '... the object is from class FooBarBaz' ); 30 | ok( $foo->isa( FooBar ), '... the object is from class FooBar' ); 31 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 32 | ok( $foo->isa( $::Object ), '... the object is derived from class Object' ); 33 | is( mop::class_of( $foo ), FooBarBazGorch, '... the class of this object is FooBarBaz' ); 34 | 35 | is( $foo->foo, 'FOO-FOOBAR-FOOBARBAZ-FOOBARBAZGORCH', '... got the chained super calls as expected'); 36 | 37 | done_testing; 38 | -------------------------------------------------------------------------------- /t/010-core/130-simple-attributes.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | ... 14 | 15 | =cut 16 | 17 | class Foo { 18 | has $bar; 19 | method bar { $bar } 20 | 21 | method has_bar { defined $bar } 22 | method set_bar ($b) { $bar = $b } 23 | method init_bar { $bar = 200 } 24 | method clear_bar { undef $bar } 25 | } 26 | 27 | { 28 | my $foo = Foo->new; 29 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 30 | 31 | ok(!$foo->has_bar, '... no bar is set'); 32 | is($foo->bar, undef, '... values are undefined when they are not initialized'); 33 | 34 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 35 | ok($foo->has_bar, '... bar is set'); 36 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 37 | 38 | is(exception{ $foo->set_bar(1000) }, undef, '... set bar without error'); 39 | ok($foo->has_bar, '... bar is set'); 40 | is($foo->bar, 1000, '... value is set by the set_bar method'); 41 | 42 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 43 | ok(!$foo->has_bar, '... no bar is set'); 44 | is($foo->bar, undef, '... values has been cleared'); 45 | } 46 | 47 | { 48 | my $foo = Foo->new( bar => 10 ); 49 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 50 | 51 | ok($foo->has_bar, '... a bar is set'); 52 | is($foo->bar, 10, '... values are initialized via the constructor'); 53 | 54 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 55 | ok($foo->has_bar, '... bar is set'); 56 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 57 | 58 | is(exception{ $foo->set_bar(1000) }, undef, '... set bar without error'); 59 | ok($foo->has_bar, '... bar is set'); 60 | is($foo->bar, 1000, '... value is set by the set_bar method'); 61 | 62 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 63 | ok(!$foo->has_bar, '... no bar is set'); 64 | is($foo->bar, undef, '... values has been cleared'); 65 | } 66 | 67 | 68 | done_testing; 69 | -------------------------------------------------------------------------------- /t/010-core/131-attributes-w-defaults.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | ... 14 | 15 | =cut 16 | 17 | class Foo { 18 | has $bar = 100; 19 | method bar { $bar } 20 | 21 | method has_bar { defined $bar } 22 | method set_bar ($b) { $bar = $b } 23 | method init_bar { $bar = 200 } 24 | method clear_bar { undef $bar } 25 | } 26 | 27 | { 28 | my $foo = Foo->new; 29 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 30 | 31 | ok($foo->has_bar, '... a bar is set'); 32 | is($foo->bar, 100, '... values are defined'); 33 | 34 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 35 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 36 | 37 | is(exception{ $foo->set_bar(1000) }, undef, '... set bar without error'); 38 | is($foo->bar, 1000, '... value is set by the set_bar method'); 39 | 40 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 41 | ok(!$foo->has_bar, '... no bar is set'); 42 | is($foo->bar, undef, '... values has been cleared'); 43 | } 44 | 45 | { 46 | my $foo = Foo->new( bar => 10 ); 47 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 48 | 49 | ok($foo->has_bar, '... a bar is set'); 50 | is($foo->bar, 10, '... values are initialized via the constructor'); 51 | 52 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 53 | ok($foo->has_bar, '... a bar is set'); 54 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 55 | 56 | is(exception{ $foo->set_bar(1000) }, undef, '... set bar without error'); 57 | ok($foo->has_bar, '... a bar is set'); 58 | is($foo->bar, 1000, '... value is set by the set_bar method'); 59 | 60 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 61 | ok(!$foo->has_bar, '... no bar is set'); 62 | is($foo->bar, undef, '... values has been cleared'); 63 | } 64 | 65 | 66 | done_testing; 67 | -------------------------------------------------------------------------------- /t/010-core/132-attributes-w-lazy-defaults.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | ... 14 | 15 | =cut 16 | 17 | class Foo { 18 | has $bar; 19 | method bar { $bar //= 333 } 20 | 21 | method has_bar { defined $bar } 22 | method set_bar ($b) { $bar = $b } 23 | method init_bar { $bar = 200 } 24 | method clear_bar { undef $bar } 25 | } 26 | 27 | { 28 | my $foo = Foo->new; 29 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 30 | 31 | ok(!$foo->has_bar, '... no bar is set'); 32 | is($foo->bar, 333, '... values are defined'); 33 | 34 | ok($foo->has_bar, '... bar is now set'); 35 | 36 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 37 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 38 | 39 | is(exception{ $foo->set_bar(1000) }, undef, '... set bar without error'); 40 | is($foo->bar, 1000, '... value is set by the set_bar method'); 41 | 42 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 43 | ok(!$foo->has_bar, '... no bar is set'); 44 | is($foo->bar, 333, '... lazy value is recalculated'); 45 | 46 | is(exception{ $foo->set_bar(undef) }, undef, '... set bar without error'); 47 | ok(!$foo->has_bar, '... no bar is set'); 48 | is($foo->bar, 333, '... lazy value is recalculated'); 49 | } 50 | 51 | { 52 | my $foo = Foo->new( bar => 10 ); 53 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 54 | 55 | ok($foo->has_bar, '... bar is set'); 56 | is($foo->bar, 10, '... values are initialized via the constructor'); 57 | 58 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 59 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 60 | 61 | is(exception{ $foo->set_bar(1000) }, undef, '... set bar without error'); 62 | is($foo->bar, 1000, '... value is set by the set_bar method'); 63 | 64 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 65 | ok(!$foo->has_bar, '... no bar is set'); 66 | is($foo->bar, 333, '... lazy value is recalculated'); 67 | 68 | is(exception{ $foo->set_bar(undef) }, undef, '... set bar without error'); 69 | ok(!$foo->has_bar, '... no bar is set'); 70 | is($foo->bar, 333, '... lazy value is recalculated'); 71 | } 72 | 73 | 74 | done_testing; 75 | -------------------------------------------------------------------------------- /t/010-core/133-attributes-w-lazy-accessor.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | ... 14 | 15 | =cut 16 | 17 | class Foo { 18 | has $bar; 19 | method bar ($b) { 20 | $bar = $b if $b; 21 | $bar //= 333; 22 | } 23 | 24 | method has_bar { defined $bar } 25 | method init_bar { $bar = 200 } 26 | method clear_bar { undef $bar } 27 | } 28 | 29 | { 30 | my $foo = Foo->new; 31 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 32 | 33 | ok(!$foo->has_bar, '... no bar is set'); 34 | is($foo->bar, 333, '... values are defined'); 35 | 36 | ok($foo->has_bar, '... bar is now set'); 37 | is(exception{ $foo->bar(1000) }, undef, '... set bar without error'); 38 | is($foo->bar, 1000, '... value is set by the set_bar method'); 39 | 40 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 41 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 42 | 43 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 44 | ok(!$foo->has_bar, '... no bar is set'); 45 | is($foo->bar, 333, '... lazy value is recalculated'); 46 | } 47 | 48 | { 49 | my $foo = Foo->new( bar => 10 ); 50 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 51 | 52 | ok($foo->has_bar, '... bar is set'); 53 | is($foo->bar, 10, '... values are initialized via the constructor'); 54 | 55 | is(exception{ $foo->bar(1000) }, undef, '... set bar without error'); 56 | is($foo->bar, 1000, '... value is set by the set_bar method'); 57 | 58 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 59 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 60 | 61 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 62 | ok(!$foo->has_bar, '... no bar is set'); 63 | is($foo->bar, 333, '... lazy value is recalculated'); 64 | } 65 | 66 | 67 | done_testing; 68 | -------------------------------------------------------------------------------- /t/010-core/140-atttributes-w-defaults-w-refs.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | =pod 11 | 12 | Every new instance created should be a new reference 13 | and all attribute data in it should be a clone of the 14 | original data itself. 15 | 16 | =cut 17 | 18 | my $BAZ = []; 19 | 20 | class Foo { 21 | has $bar = { baz => $BAZ }; 22 | method bar { $bar } 23 | }; 24 | 25 | my $foo = Foo->new; 26 | is_deeply( $foo->bar, { baz => [] }, '... got the expected value' ); 27 | is( $foo->bar->{'baz'}, $BAZ, '... these are the same values' ); 28 | 29 | { 30 | my $foo2 = Foo->new; 31 | is_deeply( $foo2->bar, { baz => [] }, '... got the expected value' ); 32 | 33 | isnt( $foo->bar, $foo2->bar, '... these are not the same values' ); 34 | is( $foo2->bar->{'baz'}, $BAZ, '... these are the same values' ); 35 | is( $foo->bar->{'baz'}, $foo2->bar->{'baz'}, '... these are the same values' ); 36 | } 37 | 38 | done_testing; 39 | -------------------------------------------------------------------------------- /t/010-core/141-attributes-w-complex-defaults.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | ... 14 | 15 | =cut 16 | 17 | class Foo { 18 | has $bar = []; 19 | method bar { $bar } 20 | 21 | method has_bar { defined $bar } 22 | method set_bar ($b) { $bar = $b } 23 | method init_bar { $bar = [ 1, 2, 3 ] } 24 | method clear_bar { undef $bar } 25 | } 26 | 27 | { 28 | my $foo = Foo->new; 29 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 30 | 31 | ok($foo->has_bar, '... a bar is set'); 32 | is_deeply($foo->bar, [], '... values are defined'); 33 | 34 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 35 | is_deeply($foo->bar, [ 1, 2, 3 ], '... value is initialized by the init_bar method'); 36 | 37 | is(exception{ $foo->set_bar([1000]) }, undef, '... set bar without error'); 38 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 39 | 40 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 41 | ok(!$foo->has_bar, '... no bar is set'); 42 | is($foo->bar, undef, '... values has been cleared'); 43 | 44 | { 45 | my $foo2 = Foo->new; 46 | isnt($foo->bar, $foo2->bar, '... different instances have different refs'); 47 | } 48 | } 49 | 50 | { 51 | my $foo = Foo->new( bar => [10] ); 52 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 53 | 54 | ok($foo->has_bar, '... a bar is set'); 55 | is_deeply($foo->bar, [10], '... values are initialized via the constructor'); 56 | 57 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 58 | ok($foo->has_bar, '... a bar is set'); 59 | is_deeply($foo->bar, [1, 2, 3], '... value is initialized by the init_bar method'); 60 | 61 | is(exception{ $foo->set_bar([1000]) }, undef, '... set bar without error'); 62 | ok($foo->has_bar, '... a bar is set'); 63 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 64 | 65 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 66 | ok(!$foo->has_bar, '... no bar is set'); 67 | is($foo->bar, undef, '... values has been cleared'); 68 | } 69 | 70 | 71 | done_testing; 72 | -------------------------------------------------------------------------------- /t/010-core/142-attributes-w-complex-lazy-defaults.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | ... 14 | 15 | =cut 16 | 17 | class Foo { 18 | has $bar; 19 | method bar { $bar //= [ 5, 10, 15 ] } 20 | 21 | method has_bar { defined $bar } 22 | method set_bar ($b) { $bar = $b } 23 | method init_bar { $bar = [ 1, 2, 3 ] } 24 | method clear_bar { undef $bar } 25 | } 26 | 27 | { 28 | my $foo = Foo->new; 29 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 30 | 31 | ok(!$foo->has_bar, '... no bar is set'); 32 | is_deeply($foo->bar, [ 5, 10, 15 ], '... values are defined'); 33 | 34 | my $bar_1 = $foo->bar; 35 | 36 | ok($foo->has_bar, '... bar is now set'); 37 | 38 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 39 | is_deeply($foo->bar, [ 1, 2, 3 ], '... value is initialized by the init_bar method'); 40 | 41 | is(exception{ $foo->set_bar([1000]) }, undef, '... set bar without error'); 42 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 43 | 44 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 45 | ok(!$foo->has_bar, '... no bar is set'); 46 | is_deeply($foo->bar, [ 5, 10, 15 ], '... values are defined'); 47 | 48 | isnt($foo->bar, $bar_1, '... new values are regnerated by the lazy init'); 49 | } 50 | 51 | { 52 | my $foo = Foo->new( bar => [10] ); 53 | ok( $foo->isa( Foo ), '... the object is from class Foo' ); 54 | 55 | ok($foo->has_bar, '... a bar is set'); 56 | is_deeply($foo->bar, [10], '... values are initialized via the constructor'); 57 | 58 | is(exception{ $foo->init_bar }, undef, '... initialized bar without error'); 59 | ok($foo->has_bar, '... a bar is set'); 60 | is_deeply($foo->bar, [1, 2, 3], '... value is initialized by the init_bar method'); 61 | 62 | is(exception{ $foo->set_bar([1000]) }, undef, '... set bar without error'); 63 | ok($foo->has_bar, '... a bar is set'); 64 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 65 | 66 | is(exception{ $foo->clear_bar }, undef, '... set bar without error'); 67 | ok(!$foo->has_bar, '... no bar is set'); 68 | is_deeply($foo->bar, [ 5, 10, 15 ], '... values are defined'); 69 | } 70 | 71 | 72 | done_testing; 73 | -------------------------------------------------------------------------------- /t/010-core/200-attribute-override.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | This test illustrates the "virtual" nature of 11 | attributes. While they are not public (meaning 12 | they are not accessible from outside the class) 13 | they are maybe better described as "protected", 14 | however, even that is not quite right. The best 15 | description really is "virtual", and really maps 16 | to what an old school Perl OO programmer might 17 | expect. 18 | 19 | The key thing here is predictability, no one 20 | likes to have to remember complex rules. This 21 | may seem unsophisticated to some, but it is 22 | understandable to everyone else. 23 | 24 | =cut 25 | 26 | use mop; 27 | 28 | class Foo { 29 | has $bar = 10; 30 | method bar { $bar } 31 | } 32 | 33 | class FooBar ( extends => Foo ) { 34 | has $bar = 100; 35 | method derived_bar { $bar } 36 | } 37 | 38 | my $foobar = FooBar->new; 39 | 40 | is($foobar->bar, 100, '... got the expected value (for the superclass method)'); 41 | is($foobar->derived_bar, 100, '... got the expected value (for the derived method)'); 42 | 43 | done_testing; 44 | -------------------------------------------------------------------------------- /t/010-core/300-UNIVERSAL.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use mop; 8 | 9 | my $got; 10 | class Foo (version => 0.02) { 11 | method foo ($thing) { $got = $thing } 12 | } 13 | 14 | isa_ok(Foo->find_method($_), $::Method) 15 | for grep { $_ ne 'VERSION' } keys %UNIVERSAL::; 16 | isa_ok(mop::class_of(Foo)->find_method($_), $::Method) 17 | for qw(VERSION); 18 | 19 | is(Foo->VERSION, 0.02); 20 | is(exception { Foo->VERSION(0.01) }, undef); 21 | like( 22 | exception { Foo->VERSION(0.03) }, 23 | qr/^\QFoo version 0.03 required--this is only version 0.02/ 24 | ); 25 | like( 26 | exception { Foo->VERSION("abc") }, 27 | qr/^\QInvalid version format (non-numeric data)/ 28 | ); 29 | 30 | { 31 | my $foo = Foo->new; 32 | 33 | ok(!$foo->isa('UNIVERSAL')); 34 | 35 | my $code = $foo->can('foo'); 36 | ok($code); 37 | is( 38 | exception { $foo->$code('FOO') }, 39 | undef 40 | ); 41 | is($got, 'FOO'); 42 | 43 | ok($foo->DOES(Foo)); 44 | ok($foo->DOES($::Object)); 45 | ok(!$foo->DOES('UNIVERSAL')); 46 | } 47 | 48 | done_testing; 49 | -------------------------------------------------------------------------------- /t/010-core/400-meta-block.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More; 6 | use Test::Fatal; 7 | 8 | use mop; 9 | 10 | =pod 11 | 12 | class Foo ( extends => Bar ) { 13 | 14 | # without block 15 | meta ( extends => MetaFoo, with => [ Foo, Bar ] ); 16 | 17 | # with block 18 | meta ( with => [ Foo, Bar ] ) { 19 | 20 | method attribute_metaclass { SomeRandomAttribute } 21 | 22 | has $foo; 23 | method BUILDARGS ($params) { 24 | # ... 25 | } 26 | } 27 | 28 | } 29 | 30 | # desugars to 31 | 32 | class Foo ( metaclass => class ( extends => $::Class ) { 33 | method BUILDARGS ($params) { 34 | # ... 35 | } 36 | }) { 37 | 38 | # ... 39 | } 40 | 41 | 42 | =cut 43 | 44 | local $TODO = "not yet implemented"; 45 | fail; 46 | 47 | done_testing; 48 | -------------------------------------------------------------------------------- /t/020-metaclass/100-default-metaclass.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use mop; 7 | 8 | class Meta1 (extends => $::Class) { } 9 | class Meta2 (extends => $::Class) { } 10 | class Meta3 (extends => $::Class) { } 11 | 12 | class Foo { } 13 | { 14 | use mop -metaclass => Meta1; 15 | class Foo1 { } 16 | { 17 | use mop -metaclass => Meta2; 18 | class Foo2 { } 19 | class Foo3 (metaclass => Meta3) { } 20 | } 21 | class Bar1 { } 22 | class Bar3 (metaclass => Meta3) { } 23 | } 24 | class Bar { } 25 | class Baz3 (metaclass => Meta3) { } 26 | 27 | { 28 | ok(Foo->isa($::Class)); 29 | ok(Foo1->isa(Meta1)); 30 | ok(Foo2->isa(Meta2)); 31 | ok(Foo3->isa(Meta3)); 32 | ok(Bar1->isa(Meta1)); 33 | ok(Bar3->isa(Meta3)); 34 | ok(Bar->isa($::Class)); 35 | ok(Baz3->isa(Meta3)); 36 | } 37 | 38 | done_testing; 39 | -------------------------------------------------------------------------------- /t/020-metaclass/101-import-into.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | BEGIN { 7 | package My::Extension; 8 | use mop (); 9 | 10 | sub import { 11 | mop->import(-into => scalar(caller)); 12 | } 13 | 14 | $INC{'My/Extension.pm'} = 1; 15 | } 16 | 17 | BEGIN { 18 | package My::Custom::Extension; 19 | use mop; 20 | 21 | class CustomClass (extends => $::Class) { } 22 | 23 | sub import { 24 | mop->import(-into => scalar(caller), -metaclass => CustomClass); 25 | } 26 | 27 | $INC{'My/Custom/Extension.pm'} = 1; 28 | } 29 | 30 | { 31 | package Foo; 32 | use My::Extension; 33 | 34 | class Foo { } 35 | } 36 | 37 | { 38 | isa_ok(Foo::Foo, $::Class); 39 | } 40 | 41 | { 42 | package Bar; 43 | use My::Custom::Extension; 44 | 45 | class Bar { } 46 | } 47 | 48 | { 49 | isa_ok(Bar::Bar, My::Custom::Extension::CustomClass); 50 | } 51 | 52 | done_testing; 53 | -------------------------------------------------------------------------------- /t/020-metaclass/200-basic-metaclasses.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | This test immitates the Smalltalk style 14 | parallel metaclass way of doing class 15 | methods. 16 | 17 | =cut 18 | 19 | # create a meta-class (class to create classes with) 20 | class FooMeta (extends => $::Class) { 21 | method static_method { 'STATIC' } 22 | } 23 | 24 | is mop::class_of( FooMeta ), $::Class, '... got the class we expected'; 25 | ok FooMeta->isa( $::Object ), '... FooMeta is an Object'; 26 | ok FooMeta->isa( $::Class ), '... FooMeta is a Class'; 27 | ok FooMeta->is_subclass_of( $::Object ), '... FooMeta is a subclass of Object'; 28 | ok FooMeta->is_subclass_of( $::Class ), '... FooMeta is a subclass of Class'; 29 | 30 | # create a class (using our meta-class) 31 | class Foo (metaclass => FooMeta) { 32 | method hello { 'FOO' } 33 | method hello_from_class { $::CLASS->static_method } 34 | } 35 | 36 | is mop::class_of( Foo ), FooMeta, '... got the class we expected'; 37 | ok Foo->isa( $::Object ), '... Foo is an Object'; 38 | ok Foo->isa( $::Class ), '... Foo is a Class'; 39 | ok Foo->isa( FooMeta ), '... Foo is a FooMeta'; 40 | ok Foo->is_subclass_of( $::Object ), '... Foo is a subclass of Object'; 41 | 42 | is Foo->static_method, 'STATIC', '... called the static method on Foo'; 43 | 44 | # create an instance ... 45 | my $foo = Foo->new; 46 | 47 | is mop::class_of( $foo ), Foo, '... got the class we expected'; 48 | ok $foo->isa( Foo ), '... foo is a Foo'; 49 | ok $foo->isa( $::Object ), '... foo is an Object'; 50 | ok !$foo->isa( $::Class ), '... foo is not a Class'; 51 | ok !$foo->isa( FooMeta ), '... foo is not a FooMeta'; 52 | 53 | like exception { $foo->static_method }, qr/^Can\'t locate object method \"static_method\" via package/, '... got an expection here'; 54 | 55 | is $foo->hello_from_class, 'STATIC', '... got the class method via the instance however'; 56 | is mop::class_of( $foo )->static_method, 'STATIC', '... got access to the class method via the mop::class_of function'; 57 | is $foo->hello, 'FOO', '... got the instance method however'; 58 | 59 | done_testing; -------------------------------------------------------------------------------- /t/020-metaclass/210-metaclass-w-data.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | # create a meta-class (class to create classes with) 12 | class MetaWithData (extends => $::Class) { 13 | 14 | has $data = []; 15 | 16 | method get_data { $data } 17 | 18 | method add_to_data ($value) { 19 | push @$data => $value; 20 | } 21 | } 22 | 23 | is mop::class_of( MetaWithData ), $::Class, '... got the class we expected'; 24 | ok MetaWithData->isa( $::Object ), '... MetaWithData is an Object'; 25 | ok MetaWithData->isa( $::Class ), '... MetaWithData is a Class'; 26 | ok MetaWithData->is_subclass_of( $::Object ), '... MetaWithData is a subclass of Object'; 27 | ok MetaWithData->is_subclass_of( $::Class ), '... MetaWithData is a subclass of Class'; 28 | 29 | # create a class (using our meta-class) 30 | class Foo (metaclass => MetaWithData) { 31 | method get_meta_data { 32 | $::CLASS->get_data 33 | } 34 | } 35 | 36 | # create a class (using our meta-class and extra data) 37 | class Bar (metaclass => MetaWithData, data => [ 1, 2, 3 ]) { 38 | method get_meta_data { 39 | $::CLASS->get_data 40 | } 41 | } 42 | 43 | is mop::class_of( Foo ), MetaWithData, '... got the class we expected'; 44 | ok Foo->isa( $::Object ), '... Foo is an Object'; 45 | ok Foo->isa( $::Class ), '... Foo is a Class'; 46 | ok Foo->isa( MetaWithData ), '... Foo is a MetaWithData'; 47 | ok Foo->is_subclass_of( $::Object ), '... Foo is a subclass of Object'; 48 | 49 | is_deeply Foo->get_data, [], '... called the static method on Foo'; 50 | 51 | is mop::class_of( Bar ), MetaWithData, '... got the class we expected'; 52 | ok Bar->isa( $::Object ), '... Bar is an Object'; 53 | ok Bar->isa( $::Class ), '... Bar is a Class'; 54 | ok Bar->isa( MetaWithData ), '... Bar is a MetaWithData'; 55 | ok Bar->is_subclass_of( $::Object ), '... Bar is a subclass of Object'; 56 | 57 | is_deeply Bar->get_data, [ 1, 2, 3 ], '... called the static method on Bar'; 58 | 59 | isnt Foo->get_data, Bar->get_data, '... the two classes share a different class level data'; 60 | 61 | { 62 | my $foo = Foo->new; 63 | ok $foo->isa( Foo ), '... got an instance of Foo'; 64 | is_deeply $foo->get_meta_data, [], '... got the expected foo metadata'; 65 | is $foo->get_meta_data, Foo->get_data, '... and it matches the metadata for Foo'; 66 | 67 | my $foo2 = Foo->new; 68 | ok $foo2->isa( Foo ), '... got an instance of Foo'; 69 | is_deeply $foo2->get_meta_data, [], '... got the expected foo metadata'; 70 | is $foo2->get_meta_data, Foo->get_data, '... and it matches the metadata for Foo'; 71 | is $foo2->get_meta_data, $foo->get_meta_data, '... and it is shared across instances'; 72 | 73 | Foo->add_to_data( 10 ); 74 | is_deeply Foo->get_data, [ 10 ], '... got the expected (changed) Foo metadata'; 75 | 76 | is_deeply $foo->get_meta_data, [ 10 ], '... got the expected (changed) foo metadata'; 77 | is_deeply $foo2->get_meta_data, [ 10 ], '... got the expected (changed) foo metadata'; 78 | 79 | is $foo->get_meta_data, Foo->get_data, '... and it matches the metadata for Foo still'; 80 | is $foo2->get_meta_data, Foo->get_data, '... and it matches the metadata for Foo still'; 81 | is $foo2->get_meta_data, $foo->get_meta_data, '... and it is shared across instances still'; 82 | } 83 | 84 | { 85 | my $bar = Bar->new; 86 | ok $bar->isa( Bar ), '... got an instance of Bar'; 87 | is_deeply $bar->get_meta_data, [ 1, 2, 3 ], '... got the expected bar metadata'; 88 | is $bar->get_meta_data, Bar->get_data, '... and it matches the metadata for Bar'; 89 | 90 | my $bar2 = Bar->new; 91 | ok $bar2->isa( Bar ), '... got an instance of Bar'; 92 | is_deeply $bar2->get_meta_data, [1, 2, 3], '... got the expected bar metadata'; 93 | is $bar2->get_meta_data, Bar->get_data, '... and it matches the metadata for Bar'; 94 | is $bar2->get_meta_data, $bar->get_meta_data, '... and it is shared across instances'; 95 | 96 | Bar->add_to_data( 10 ); 97 | is_deeply Bar->get_data, [ 1, 2, 3, 10 ], '... got the expected (changed) Bar metadata'; 98 | 99 | is_deeply $bar->get_meta_data, [ 1, 2, 3, 10 ], '... got the expected (changed) bar metadata'; 100 | is_deeply $bar2->get_meta_data, [ 1, 2, 3, 10 ], '... got the expected (changed) bar metadata'; 101 | 102 | is $bar->get_meta_data, Bar->get_data, '... and it matches the metadata for Bar still'; 103 | is $bar2->get_meta_data, Bar->get_data, '... and it matches the metadata for Bar still'; 104 | is $bar2->get_meta_data, $bar->get_meta_data, '... and it is shared across instances still'; 105 | 106 | is_deeply Foo->get_data, [ 10 ], '... got the expected (unchanged) Foo metadat'; 107 | } 108 | 109 | 110 | done_testing; -------------------------------------------------------------------------------- /t/020-metaclass/220-compatibility.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | =pod 12 | 13 | Metaclass compatibility is essentially just the concept that an empty subclass 14 | of an existing class should behave identically to the original class (other 15 | than having a different name). In most object systems, this is trivially true, 16 | but when you can declare metaclasses that should be used to construct the 17 | classes, you have to ensure that those metaclasses behave in the same way in 18 | order for this invariant to hold. 19 | 20 | The basic algorithm used is that the metaclass used to construct a class must 21 | be either the same as or a subclass of the metaclass used for its superclass. 22 | If this doesn't hold, an exception will be thrown. 23 | 24 | This doesn't quite get us to our goal of allowing an empty subclass to behave 25 | identically to its parent, because now if the parent uses a custom metaclass, 26 | you can't create an empty subclass without explicitly specifying the same 27 | metaclass (or else it will die). The second step is that when deciding what 28 | metaclass to use, we also have to look at what superclass was specified. If 29 | that superclass's metaclass is a subclass of the metaclass we are currently 30 | using, we can just instead use the superclass's metaclass directly, since this 31 | won't lose any behavior that was requested in the subclass. This allows 32 | 33 | class FooMeta (extends => $::Class) { } 34 | class Foo (metaclass => FooMeta) { } 35 | class FooSub (extends => Foo) { } 36 | 37 | to just work. 38 | 39 | =cut 40 | 41 | # create a meta-class (class to create classes with) 42 | class FooMeta (extends => $::Class) { } 43 | 44 | # create a class (using our meta-class) 45 | class Foo (metaclass => FooMeta) { } 46 | 47 | is mop::class_of( Foo ), FooMeta, '... got the class we expected'; 48 | ok Foo->isa( FooMeta ), '... Foo is a FooMeta'; 49 | 50 | class FooSub (extends => Foo) { } 51 | 52 | is mop::class_of( FooSub ), FooMeta, '... got the class we expected'; 53 | ok FooSub->isa( FooMeta ), '... FooSub is a FooMeta'; 54 | 55 | class BarMeta (extends => $::Class) { } 56 | 57 | like exception { eval "class BarSub (extends => Foo, metaclass => BarMeta) { }; 1" || die $@ }, 58 | qr/While creating class BarSub: Metaclass BarMeta is not compatible with the metaclass of its superclass: FooMeta/, 59 | '... incompatible metaclasses die'; 60 | 61 | done_testing; 62 | -------------------------------------------------------------------------------- /t/020-metaclass/300-cloning.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use mop; 7 | 8 | class Foo (with => [$::Cloneable]) { 9 | has $foo; 10 | has $bar; 11 | method foo { $foo } 12 | method bar { $bar } 13 | } 14 | 15 | ok(Foo->find_method('clone'), "has a clone method"); 16 | 17 | { 18 | my $foo = Foo->new(foo => "FOO", bar => "BAR"); 19 | is($foo->foo, "FOO"); 20 | is($foo->bar, "BAR"); 21 | 22 | my $foo2 = $foo->clone; 23 | is($foo2->foo, "FOO"); 24 | is($foo2->bar, "BAR"); 25 | 26 | my $FOO = []; 27 | my $foo3 = $foo->clone(foo => $FOO); 28 | is($foo3->foo, $FOO); 29 | is($foo3->bar, "BAR"); 30 | 31 | my $foo4 = $foo3->clone; 32 | is($foo4->foo, $FOO); 33 | is($foo4->bar, "BAR"); 34 | } 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/020-metaclass/301-metaclass-cloning.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use mop; 7 | 8 | class Foo { 9 | has $foo; 10 | method foo { $foo * 2 } 11 | } 12 | 13 | { 14 | my $FooClone = Foo->clone; 15 | is($FooClone->get_name, 'Foo'); 16 | is($FooClone->find_method('foo'), Foo->find_method('foo')); 17 | is($FooClone->find_attribute('$foo'), Foo->find_attribute('$foo')); 18 | isnt($FooClone, Foo); 19 | isnt(mop::uuid_of($FooClone), mop::uuid_of(Foo)); 20 | is(mop::class_of($FooClone), mop::class_of(Foo)); 21 | 22 | my $foo = Foo->new; 23 | my $foo_clone = $FooClone->new; 24 | is(mop::class_of($foo), Foo); 25 | is(mop::class_of($foo_clone), $FooClone); 26 | } 27 | 28 | role FooRole { 29 | has $foo; 30 | method foo { $foo * 2 } 31 | } 32 | 33 | { 34 | my $FooClone = FooRole->clone; 35 | is($FooClone->get_name, 'FooRole'); 36 | is($FooClone->find_method('foo'), FooRole->find_method('foo')); 37 | is($FooClone->find_attribute('$foo'), FooRole->find_attribute('$foo')); 38 | isnt($FooClone, FooRole); 39 | isnt(mop::uuid_of($FooClone), mop::uuid_of(FooRole)); 40 | is(mop::class_of($FooClone), mop::class_of(FooRole)); 41 | } 42 | 43 | { 44 | my $method = Foo->find_method('foo'); 45 | Foo->add_method($method->clone(name => 'foo_clone')); 46 | Foo->FINALIZE; 47 | my $foo = Foo->new(foo => 23); 48 | is($foo->foo, 46); 49 | is($foo->foo_clone, 46); 50 | } 51 | 52 | { 53 | my $attribute = Foo->find_attribute('$foo'); 54 | Foo->add_attribute($attribute->clone(name => '$foo_clone')); 55 | Foo->FINALIZE; 56 | my $foo = Foo->new(foo_clone => 21); 57 | is(mop::internal::instance::get_slot_at($foo, '$foo_clone'), 21); 58 | } 59 | 60 | done_testing; 61 | -------------------------------------------------------------------------------- /t/030-extensions/001-class-accessor.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | class ClassAccessorMeta (extends => $::Class) { 12 | method FINALIZE { 13 | 14 | foreach my $attribute ( values %{ $self->get_all_attributes } ) { 15 | my $name = $attribute->get_name; 16 | my $accessor_name = $name; 17 | $accessor_name =~ s/^\$//; 18 | 19 | $self->add_method( 20 | $::Method->new( 21 | name => $accessor_name, 22 | body => sub { 23 | mop::internal::instance::set_slot_at( $::SELF, $name, \(shift) ) if @_; 24 | mop::internal::instance::get_slot_at( $::SELF, $name ) 25 | } 26 | ) 27 | ); 28 | } 29 | 30 | super; 31 | } 32 | } 33 | 34 | class Foo (metaclass => ClassAccessorMeta) { 35 | has $bar; 36 | has $baz; 37 | } 38 | 39 | is mop::class_of( Foo ), ClassAccessorMeta, '... Foo has the right metaclass'; 40 | ok Foo->is_subclass_of( $::Object ), '... Foo is a subtype of Object'; 41 | ok Foo->find_method('bar'), '... the bar method was generated for us'; 42 | ok Foo->find_method('baz'), '... the baz method was generated for us'; 43 | 44 | { 45 | my $foo = Foo->new; 46 | is mop::class_of( $foo ), Foo, '... we are an instance of Foo'; 47 | ok $foo->isa( Foo ), '... we is-a Foo'; 48 | ok $foo->isa( $::Object ), '... we is-a Object'; 49 | 50 | is $foo->bar, undef, '... there is no value for bar'; 51 | is $foo->baz, undef, '... there is no value for baz'; 52 | 53 | is exception { $foo->bar( 100 ) }, undef, '... set the bar value without dying'; 54 | is exception { $foo->baz( 'BAZ' ) }, undef, '... set the baz value without dying'; 55 | 56 | is $foo->bar, 100, '... and got the expected value for bar'; 57 | is $foo->baz, 'BAZ', '... and got the expected value for bar'; 58 | } 59 | 60 | { 61 | my $foo = Foo->new( bar => 100, baz => 'BAZ' ); 62 | is mop::class_of( $foo ), Foo, '... we are an instance of Foo'; 63 | ok $foo->isa( Foo ), '... we is-a Foo'; 64 | ok $foo->isa( $::Object ), '... we is-a Object'; 65 | 66 | is $foo->bar, 100, '... and got the expected value for bar'; 67 | is $foo->baz, 'BAZ', '... and got the expected value for bar'; 68 | 69 | is exception { $foo->bar( 300 ) }, undef, '... set the bar value without dying'; 70 | is exception { $foo->baz( 'baz' ) }, undef, '... set the baz value without dying'; 71 | 72 | is $foo->bar, 300, '... and got the expected value for bar'; 73 | is $foo->baz, 'baz', '... and got the expected value for bar'; 74 | } 75 | 76 | 77 | 78 | done_testing; 79 | -------------------------------------------------------------------------------- /t/030-extensions/002-validated-accessor.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | class ValidatedAttribute (extends => $::Attribute) { 12 | has $validator = sub { 1 }; 13 | 14 | method get_validator { $validator } 15 | } 16 | 17 | class ValidatedAccessorMeta (extends => $::Class) { 18 | 19 | method attribute_class { ValidatedAttribute } 20 | 21 | method FINALIZE { 22 | 23 | foreach my $attribute ( values %{ $self->get_all_attributes } ) { 24 | my $name = $attribute->get_name; 25 | my $validator = $attribute->get_validator; 26 | 27 | my $accessor_name = $name; 28 | $accessor_name =~ s/^\$//; 29 | 30 | $self->add_method( 31 | $::Method->new( 32 | name => $accessor_name, 33 | body => sub { 34 | if (@_) { 35 | my $value = shift; 36 | die "invalid value '$value' for attribute '$name'" 37 | unless $validator->($value); 38 | mop::internal::instance::set_slot_at( $::SELF, $name, \$value ); 39 | } 40 | mop::internal::instance::get_slot_at( $::SELF, $name ) 41 | } 42 | ) 43 | ); 44 | } 45 | 46 | super; 47 | } 48 | } 49 | 50 | class Foo (metaclass => ValidatedAccessorMeta) { 51 | has $bar; 52 | has $baz; 53 | has $age (validator => sub { $_[0] =~ /^\d+$/ }); 54 | } 55 | 56 | is mop::class_of( Foo ), ValidatedAccessorMeta, '... Foo has the right metaclass'; 57 | ok Foo->is_subclass_of( $::Object ), '... Foo is a subtype of Object'; 58 | ok Foo->find_method('bar'), '... the bar method was generated for us'; 59 | ok Foo->find_method('baz'), '... the baz method was generated for us'; 60 | 61 | { 62 | my $foo = Foo->new; 63 | is mop::class_of( $foo ), Foo, '... we are an instance of Foo'; 64 | ok $foo->isa( Foo ), '... we is-a Foo'; 65 | ok $foo->isa( $::Object ), '... we is-a Object'; 66 | 67 | is $foo->bar, undef, '... there is no value for bar'; 68 | is $foo->baz, undef, '... there is no value for baz'; 69 | is $foo->age, undef, '... there is no value for age'; 70 | 71 | is exception { $foo->bar( 100 ) }, undef, '... set the bar value without dying'; 72 | is exception { $foo->baz( 'BAZ' ) }, undef, '... set the baz value without dying'; 73 | is exception { $foo->age( 34 ) }, undef, '... set the age value without dying'; 74 | 75 | is $foo->bar, 100, '... and got the expected value for bar'; 76 | is $foo->baz, 'BAZ', '... and got the expected value for bar'; 77 | is $foo->age, 34, '... and got the expected value for age'; 78 | 79 | like exception { $foo->age( 'not an int' ) }, qr/invalid value 'not an int' for attribute '\$age'/, '... could not set to a non-int value'; 80 | 81 | is $foo->age, 34, '... kept the old value of age'; 82 | } 83 | 84 | done_testing; 85 | 86 | -------------------------------------------------------------------------------- /t/030-extensions/003-wrapping-methods.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my @OUTPUT; 11 | 12 | class WrappedMethod ( extends => $::Method ) { 13 | method execute ( @args ) { 14 | push @OUTPUT => "calling " . $self->get_name; 15 | super( @args ); 16 | } 17 | } 18 | 19 | class WithWrappedMethods ( extends => $::Class ) { 20 | method method_class { WrappedMethod } 21 | } 22 | 23 | class Foo (metaclass => WithWrappedMethods) { 24 | method foo { "FOO" } 25 | method bar { "BAR" } 26 | method baz { "BAZ" } 27 | } 28 | 29 | my $foo = Foo->new; 30 | ok( $foo->isa( Foo ), '... got the expected instance'); 31 | 32 | is( mop::class_of( Foo ), WithWrappedMethods, '... got the right meta class'); 33 | is( Foo->method_class, WrappedMethod, '... got the right method class'); 34 | 35 | $foo->foo; 36 | $foo->bar; 37 | $foo->baz; 38 | 39 | is_deeply( 40 | \@OUTPUT, 41 | [ 42 | 'calling foo', 43 | 'calling bar', 44 | 'calling baz', 45 | ], 46 | '... got the output we expected' 47 | ); 48 | 49 | 50 | done_testing; 51 | -------------------------------------------------------------------------------- /t/030-extensions/004-find_method-example.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | BEGIN { undef *note } 6 | 7 | use mop; 8 | 9 | =pod 10 | 11 | Example stolen from http://6guts.wordpress.com/2011/08/01/a-hint-of-meta-programming/ 12 | 13 | =cut 14 | 15 | my @NOTES; 16 | sub note { push @NOTES, $_[0] } 17 | 18 | BEGIN { 19 | package LoggedDispatch; 20 | use mop; 21 | 22 | class LoggedDispatch (extends => $::Class) { 23 | method find_method ($name) { 24 | ::note "Looking up method $name"; 25 | super($name); 26 | } 27 | method FINALIZE { 28 | # there is no fallback dispatching if our method cache doesn't 29 | # exist, so we need to install one instead of just leaving it empty 30 | # this may change in the future 31 | 32 | my $stash = mop::internal::get_stash_for($self); 33 | $stash->add_method(AUTOLOAD => sub { 34 | (my $name = our $AUTOLOAD) =~ s/.*:://; 35 | $self->find_method($name)->execute(@_); 36 | }); 37 | $stash->add_method(DESTROY => sub { }); 38 | } 39 | } 40 | 41 | sub import { 42 | mop->import(-metaclass => LoggedDispatch); 43 | } 44 | 45 | $INC{'LoggedDispatch.pm'} = 1; 46 | } 47 | 48 | { 49 | use LoggedDispatch; 50 | 51 | class A { 52 | method m1 { note "42" } 53 | method m2 { note "99" } 54 | } 55 | 56 | for (1..2) { 57 | my $a = A->new; 58 | $a->m1; 59 | $a->m2; 60 | } 61 | 62 | is_deeply([@NOTES], [ 63 | # no BUILD showing up here, because that's a perl 6 implementation detail 64 | 'Looking up method m1', 65 | '42', 66 | 'Looking up method m2', 67 | '99', 68 | 'Looking up method m1', 69 | '42', 70 | 'Looking up method m2', 71 | '99', 72 | ]); 73 | } 74 | 75 | done_testing; 76 | -------------------------------------------------------------------------------- /t/040-packages/001-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | { 9 | 10 | package Foo; 11 | 12 | use strict; 13 | use warnings; 14 | use mop; 15 | 16 | class Bar { 17 | has $baz; 18 | } 19 | } 20 | 21 | my $foo = Foo::Bar->new; 22 | ok( $foo->isa( Foo::Bar ), '... the object is from class Foo' ); 23 | ok( $foo->isa( $::Object ), '... the object is derived from class Object' ); 24 | is( mop::class_of( $foo ), Foo::Bar, '... the class of this object is Foo' ); 25 | is( mop::class_of( $foo )->get_name, 'Foo::Bar', '... got the correct (fully qualified) name of the class'); 26 | like( "$foo", qr/^Foo::Bar/, '... object stringification includes fully qualified class name' ); 27 | 28 | 29 | { 30 | package Bar; 31 | 32 | use strict; 33 | use warnings; 34 | use mop; 35 | 36 | our $FOO = 100_000; 37 | sub do_something { $_[0] + $_[1] } 38 | 39 | class Baz { 40 | has $gorch = 10; 41 | method foo { 42 | do_something( $gorch, $FOO ) 43 | } 44 | method my_package { __PACKAGE__ } 45 | } 46 | } 47 | 48 | my $baz = Bar::Baz->new; 49 | ok( $baz->isa( Bar::Baz ), '... the object is from class Baz' ); 50 | ok( $baz->isa( $::Object ), '... the object is derived from class Object' ); 51 | is( mop::class_of( $baz ), Bar::Baz, '... the class of this object is Baz' ); 52 | 53 | is( $baz->foo, 100_010, '... got the value we expected' ); 54 | is( $baz->my_package, 'Bar', '... got the value we expected' ); 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/040-packages/002-packages-w-exports.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | eval { require Path::Class; 1 } 10 | or plan skip_all => "Path::Class is required for this test"; 11 | } 12 | 13 | =pod 14 | 15 | This test shows how you can import functions 16 | into your package, and then use them in your 17 | class this removes the need to import anything 18 | into your class namespace. 19 | 20 | =cut 21 | 22 | { 23 | 24 | package My::DB::FlatFile; 25 | use strict; 26 | use warnings; 27 | use mop; 28 | 29 | use Path::Class qw[ file ]; 30 | 31 | class DataFile { 32 | has $path; 33 | has $file; 34 | has $data; 35 | 36 | method data { $data } 37 | 38 | BUILD { 39 | $file = file( $path ); 40 | $data = [ $file->slurp( chomp => 1 ) ]; 41 | } 42 | } 43 | } 44 | 45 | my $data_file = My::DB::FlatFile::DataFile->new( path => __FILE__ ); 46 | ok( $data_file->isa( My::DB::FlatFile::DataFile ), '... the object is from class My::DB::FlatFile::DataFile' ); 47 | ok( $data_file->isa( $::Object ), '... the object is derived from class Object' ); 48 | is( $data_file->data->[0], '#!/usr/bin/perl', '... got the first line of the data we expected' ); 49 | 50 | done_testing; 51 | -------------------------------------------------------------------------------- /t/040-packages/003-fully-qualified-class-name.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | =pod 11 | 12 | Sometimes you might not want to 13 | actually declare the enclosing 14 | package. And you shouldn't have 15 | to. But just as with other things 16 | it should create the namespace 17 | for you automagically. 18 | 19 | =cut 20 | 21 | class Foo::Bar {} 22 | 23 | my $foo = Foo::Bar->new; 24 | ok( $foo->isa( Foo::Bar ), '... the object is from class Foo' ); 25 | ok( $foo->isa( $::Object ), '... the object is derived from class Object' ); 26 | is( mop::class_of( $foo ), Foo::Bar, '... the class of this object is Foo' ); 27 | is( mop::class_of( $foo )->get_name, 'Foo::Bar', '... got the correct (fully qualified) name of the class'); 28 | like( "$foo", qr/^Foo::Bar/, '... object stringification includes fully qualified class name' ); 29 | 30 | done_testing; 31 | -------------------------------------------------------------------------------- /t/040-packages/004-loading-from-disk.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | 10 | use Foo::Bar; 11 | 12 | my $foo = Foo::Bar->new; 13 | ok( $foo->isa( Foo::Bar ), '... the object is from class Foo' ); 14 | ok( $foo->isa( $::Object ), '... the object is derived from class Object' ); 15 | is( mop::class_of( $foo ), Foo::Bar, '... the class of this object is Foo' ); 16 | is( mop::class_of( $foo )->get_name, 'Foo::Bar', '... got the correct (fully qualified) name of the class'); 17 | 18 | done_testing; 19 | -------------------------------------------------------------------------------- /t/040-packages/010-package-extensions.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | This test is kind of experimental, it is 11 | based on the ideas in the Newspeak language 12 | (L) where they 13 | have have a concept of "nested classes" or 14 | sometimes called "modules as objects" 15 | (L). 16 | 17 | These concepts and these papers can get 18 | very complex and a little weird, but a 19 | central idea that is found in this is the 20 | ability to enclose a set of classes into 21 | a "module" which itself can be extended 22 | just like a class can. By doing this it 23 | becomes possible to dynamically override 24 | one or more of the classes available in 25 | the module. 26 | 27 | This test illustrates that idea in that 28 | it Foo::Extended extends Foo and gets 29 | the Foo::Bar class, but creates its own 30 | Baz class. 31 | 32 | =cut 33 | 34 | { 35 | package Foo; 36 | 37 | use strict; 38 | use warnings; 39 | use mop; 40 | 41 | class Bar { 42 | method baz { 'Foo::Bar::baz' } 43 | } 44 | 45 | class Baz { 46 | method gorch { 'Foo::Baz::gorch' } 47 | } 48 | } 49 | 50 | { 51 | my $bar = Foo::Bar->new; 52 | ok( $bar->isa( Foo::Bar ), '... the object is from class Foo::Bar' ); 53 | is( $bar->baz, 'Foo::Bar::baz', '... go the value expected' ); 54 | 55 | my $baz = Foo::Baz->new; 56 | ok( $baz->isa( Foo::Baz ), '... the object is from class Foo::Baz' ); 57 | is( $baz->gorch, 'Foo::Baz::gorch', '... go the value expected' ); 58 | } 59 | 60 | { 61 | package Foo::Extended; 62 | 63 | use strict; 64 | use warnings; 65 | use mop; 66 | 67 | use base 'Foo'; 68 | 69 | # NOTE: 70 | # make sure to inherit from the 71 | # Baz in the parent, this is a 72 | # nice generic way to do this. 73 | class Baz (extends => __PACKAGE__->SUPER::Baz) { 74 | 75 | method gorch { 'Foo::Extended::Baz::gorch' } 76 | 77 | # NOTE: 78 | # can also easily make sure to use the 79 | # class from the previously derived 80 | # package as well. 81 | method bar (%params) { __PACKAGE__->Bar->new( %params ) } 82 | }; 83 | } 84 | 85 | { 86 | my $bar = Foo::Extended->Bar->new; 87 | ok( $bar->isa( Foo::Bar ), '... the object is from class Foo::Bar' ); 88 | is( $bar->baz, 'Foo::Bar::baz', '... go the value expected' ); 89 | 90 | my $baz = Foo::Extended->Baz->new; 91 | ok( $baz->isa( Foo::Extended::Baz ), '... the object is from class Foo::Baz' ); 92 | ok( $baz->isa( Foo::Baz ), '... the object is from class Foo::Baz' ); 93 | is( $baz->gorch, 'Foo::Extended::Baz::gorch', '... go the value expected' ); 94 | 95 | { 96 | my $bar = $baz->bar; 97 | ok( $bar->isa( Foo::Bar ), '... the object is from class Foo::Bar' ); 98 | is( $bar->baz, 'Foo::Bar::baz', '... go the value expected' ); 99 | } 100 | } 101 | 102 | 103 | done_testing; 104 | -------------------------------------------------------------------------------- /t/050-roles/001-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use mop; 7 | 8 | role Foo { 9 | has $foo = 1; 10 | method foo { $foo } 11 | } 12 | 13 | class Bar (with => [Foo]) { 14 | method bar { $self->foo + 1 } 15 | } 16 | 17 | is(Bar->new->bar, 2); 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /t/050-roles/002-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | role Foo {} 11 | 12 | can_ok( Foo, 'attribute_class' ); 13 | can_ok( Foo, 'method_class' ); 14 | 15 | can_ok( Foo, 'get_name' ); 16 | can_ok( Foo, 'get_version' ); 17 | can_ok( Foo, 'get_authority' ); 18 | 19 | can_ok( Foo, 'find_method' ); 20 | can_ok( Foo, 'get_all_methods' ); 21 | 22 | can_ok( Foo, 'find_attribute' ); 23 | can_ok( Foo, 'get_all_attributes' ); 24 | 25 | is( Foo->attribute_class, $::Attribute, '... got the expected value of attribute_class'); 26 | is( Foo->method_class, $::Method, '... got the expected value of method_class'); 27 | 28 | is( Foo->get_name, 'Foo', '... got the expected value for get_name'); 29 | 30 | role Bar { 31 | has $bar = 'bar'; 32 | method bar { $bar } 33 | } 34 | 35 | my $method = Bar->find_method( 'bar' ); 36 | ok( $method->isa( $::Method ), '... got the method we expected' ); 37 | is( $method->get_name, 'bar', '... got the name of the method we expected'); 38 | 39 | my $attribute = Bar->find_attribute( '$bar' ); 40 | ok( $attribute->isa( $::Attribute ), '... got the attribute we expected' ); 41 | is( $attribute->get_name, '$bar', '... got the name of the attribute we expected'); 42 | 43 | done_testing; 44 | 45 | -------------------------------------------------------------------------------- /t/050-roles/010-compose-into-role.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | role Foo { 11 | has $bar = 'bar'; 12 | method bar { $bar } 13 | } 14 | 15 | role Baz ( with => [Foo] ) { 16 | method baz { join ", " => $self->bar, 'baz' } 17 | } 18 | 19 | ok( Baz->does_role( Foo ), '... Baz does the Foo role'); 20 | 21 | my $bar_method = Baz->find_method('bar'); 22 | ok( $bar_method->isa( $::Method ), '... got a method object' ); 23 | is( $bar_method->get_name, 'bar', '... got the method we expected' ); 24 | 25 | my $bar_attribute = Baz->find_attribute('$bar'); 26 | ok( $bar_attribute->isa( $::Attribute ), '... got an attribute object' ); 27 | is( $bar_attribute->get_name, '$bar', '... got the attribute we expected' ); 28 | 29 | my $baz_method = Baz->find_method('baz'); 30 | ok( $baz_method->isa( $::Method ), '... got a method object' ); 31 | is( $baz_method->get_name, 'baz', '... got the method we expected' ); 32 | 33 | done_testing; 34 | -------------------------------------------------------------------------------- /t/050-roles/020-example.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | role Eq { 11 | method equal; 12 | 13 | method not_equal ($other) { 14 | not $self->equal($other); 15 | } 16 | } 17 | 18 | role Ord (does => [Eq]) { 19 | method compare; 20 | 21 | method equal ($other) { 22 | $self->compare($other) == 0; 23 | } 24 | } 25 | 26 | class Point (does => [Eq]) { 27 | has $x = 0; 28 | has $y = 0; 29 | 30 | method x { $x } 31 | method y { $y } 32 | 33 | method equal ($other) { 34 | $self->x eq $other->x 35 | and 36 | $self->y eq $other->y 37 | } 38 | } 39 | 40 | class Point1D (does => [Ord]) { # "Number" ;-) 41 | has $x = 0; 42 | method x { $x } 43 | 44 | method compare ($other) { 45 | $self->x <=> $other->x; 46 | } 47 | } 48 | 49 | ## Test the class 50 | 51 | ok Point->new->does(Eq), 'class Point does Eq ...'; 52 | ok Point->does_role(Eq), 'class Point does Eq ...'; 53 | is_deeply [ map { $_->get_name } @{ Point->get_all_roles } ], [qw(Eq)], '… got the roles we expected'; 54 | ok Point->new->can("equal"), '˙˙˙ implements equal method'; 55 | ok Point->find_method("equal"), '˙˙˙ implements equal method'; 56 | is_deeply Point->get_mro, [ Point, $::Object ], '⸘⸘⸘ got the mro we expected ‽‽‽'; 57 | is_deeply 58 | [ sort { $a cmp $b } map { $_->get_name } values %{ Point->get_all_methods } ], 59 | [ sort qw(x y equal not_equal), 60 | map { $_->get_name } values %{ $::Object->get_all_methods } ], 61 | ', got , the , attribute , list , we , expected ,'; 62 | 63 | ## Test an instance 64 | 65 | my $p1 = Point->new( x => 100, y => 320 ); 66 | my $p2 = Point->new( x => 100, y => 320 ); 67 | my $p3 = Point->new( x => 100, y => 33 ); 68 | ok $_->isa( Point ), '... p is a Point' for $p1, $p2, $p3; 69 | 70 | 71 | ok $p1->equal($p1), "object equals itself"; 72 | ok $p1->equal($p2), "object equals other"; 73 | ok !$p1->equal($p3), "object does not equal other"; 74 | ok $p1->not_equal($p3), "not_equal role method says the same"; 75 | 76 | ok Point1D->new->does(Ord), "Point1D does Ord"; 77 | ok Point1D->does_role(Ord), "Point1D does Ord"; 78 | is_deeply [ map { $_->get_name } @{ Point1D->get_local_roles } ], [qw(Ord)], 'directly applied roles'; 79 | is_deeply [ sort map { $_->get_name } @{ Point1D->get_all_roles } ], [qw(Eq Ord)], 'directly applied roles'; 80 | 81 | my $n1 = Point1D->new( x => 1 ); 82 | my $n2 = Point1D->new( x => 1 ); 83 | my $n3 = Point1D->new( x => 3 ); 84 | 85 | is $n1->compare($n1), 0, "compare with self"; 86 | is $n1->compare($n2), 0, "compare with equal"; 87 | is $n1->compare($n3), -1, "compare with diff"; 88 | is $n3->compare($n2), 1, "compare with diff"; 89 | 90 | ok $n1->equal($n2), "equal based on compare"; 91 | ok $n1->not_equal($n3), "not_equal based on compare"; 92 | 93 | done_testing; 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /t/050-roles/100-conflict-edge-cases.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | role Role::Base { 12 | method foo { 'Role::Base::foo' } 13 | } 14 | 15 | role Role::Derived1 (with => [Role::Base]) { 16 | } 17 | 18 | role Role::Derived2 (with => [Role::Base]) { 19 | } 20 | 21 | is(exception { 22 | class Class::Test (with => [Role::Derived1, Role::Derived2]) { 23 | } 24 | }, undef, 'consuming two roles that had consumed the same method is not a conflict'); 25 | 26 | ok(Role::Base->find_method('foo'), 'Role::Base has method foo'); 27 | ok(Role::Derived1->find_method('foo'), 'Role::Derived1 has method foo'); 28 | ok(Role::Derived2->find_method('foo'), 'Role::Derived2 has method foo'); 29 | ok(Class::Test->find_method('foo'),'Class::Test has method foo'); 30 | is(Class::Test->new->foo, 'Role::Base::foo', 'got the right value from the method foo'); 31 | 32 | # now the same but for attributes 33 | 34 | role Role::Base2 { 35 | has $foo = 'Role::Base2::foo'; 36 | 37 | method foo { $foo } 38 | } 39 | 40 | role Role::Derived3 (with => [Role::Base2]) { 41 | } 42 | 43 | role Role::Derived4 (with => [Role::Base2]) { 44 | } 45 | 46 | is(exception { 47 | class Class::Test2 (with => [Role::Derived3, Role::Derived4]) { 48 | } 49 | }, undef, 'consuming two roles that had consumed the same attribute is not a conflict'); 50 | 51 | ok(Role::Base2->find_attribute('$foo'), 'Role::Base2 has method foo'); 52 | ok(Role::Derived3->find_attribute('$foo'), 'Role::Derived3 has method foo'); 53 | ok(Role::Derived4->find_attribute('$foo'), 'Role::Derived4 has method foo'); 54 | ok(Class::Test2->find_attribute('$foo'), 'Class::Test2 has method foo'); 55 | 56 | is(Class::Test2->new->foo, 'Role::Base2::foo', 'got the right value from the method foo'); 57 | 58 | done_testing; 59 | 60 | -------------------------------------------------------------------------------- /t/050-roles/anonymous_roles.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use mop; 8 | 9 | my $role = $::Role->new( 10 | name => '__ANON__::Role', 11 | attributes => { 12 | is_worn => undef, 13 | }, 14 | methods => { 15 | remove => sub { shift->is_worn(0) }, 16 | }, 17 | ); 18 | 19 | local $TODO = "not yet implemented"; 20 | is(exception { 21 | my $class = $::Class->new(name => 'MyItem::Armor::Helmet'); 22 | $role->apply($class); 23 | # XXX: Moose::Util::apply_all_roles doesn't cope with references yet 24 | 25 | my $visored = $class->create_instance(is_worn => 0); 26 | ok(!$visored->is_worn, "attribute, accessor was consumed"); 27 | $visored->is_worn(1); 28 | ok($visored->is_worn, "accessor was consumed"); 29 | $visored->remove; 30 | ok(!$visored->is_worn, "method was consumed"); 31 | 32 | like($role->name, '__ANON__::Role', "Role has the right name"); 33 | ok(mop::class_of($role), "creating an anonymous role satisifes class_of"); 34 | 35 | { 36 | my $role; 37 | { 38 | my $meta = $::Role->new( 39 | name => '__ANON__::Role2', 40 | methods => { 41 | foo => sub { 'FOO' }, 42 | }, 43 | ); 44 | 45 | $role = $meta->name; 46 | can_ok($role, 'foo'); 47 | } 48 | ok(!$role->can('foo')); 49 | } 50 | }, undef); 51 | 52 | done_testing; 53 | -------------------------------------------------------------------------------- /t/050-roles/create_role.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # Source: moose.git/t/roles/create_role.t 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use mop; 7 | 8 | my $role = $::Role->new( 9 | name => 'MyItem::Role::Equipment', 10 | attributes => { 11 | is_worn => $::Attribute->new(name => 'is_worn'), # is => 'rw', isa => 'Bool', 12 | }, 13 | methods => { 14 | is_worn => $::Method->new(name => 'is_worn', body => sub { 15 | if(@_) { 16 | my $value = shift; 17 | mop::internal::instance::set_slot_at($::SELF, '$is_worn', \ $value); 18 | } 19 | else { 20 | mop::internal::instance::get_slot_at($::SELF, '$is_worn'); 21 | } 22 | }), 23 | remove => $::Method->new(name => 'remove', body => sub { 24 | $::SELF->is_worn(0); 25 | }), 26 | }, 27 | ); 28 | $role->FINALIZE; 29 | 30 | my $class = $::Class->new( 31 | name => 'MyItem::Armor::Helmet', 32 | roles => [ $role ], 33 | ); 34 | $class->FINALIZE; 35 | 36 | my $visored = $class->new(is_worn => 0); 37 | ok(!$visored->is_worn, "attribute, accessor was consumed"); 38 | $visored->is_worn(1); 39 | ok($visored->is_worn, "accessor was consumed"); 40 | $visored->remove; 41 | ok(!$visored->is_worn, "method was consumed"); 42 | 43 | TODO: { 44 | todo_skip 'Is anon roles going to be implemented? Everything is anon..?', 1; 45 | ok(!$role->is_anon_role, "the role is not anonymous"); 46 | } 47 | 48 | my $composed_role = $::Role->new( 49 | name => 'MyItem::Role::Equipment2', 50 | roles => [ $role ], 51 | ); 52 | 53 | TODO: { 54 | todo_skip 'No idea if this works now... Got old code because of lack of internet :/', 1; 55 | ok($composed_role->DOES('MyItem::Role::Equipment2'), "Role composed into role"); 56 | } 57 | 58 | done_testing; -------------------------------------------------------------------------------- /t/100-oddities/001-syntax-error.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | { 12 | eval q{ 13 | class Foo { 14 | has $bar; 15 | 16 | method bar { $baz } 17 | } 18 | }; 19 | 20 | like "$@", qr/^Global symbol \"\$baz\" requires explicit package name/, '... got the syntax error we expected'; 21 | } 22 | 23 | { 24 | eval 'class Foo { method foo (€bar) { 1 } }'; 25 | like( 26 | "$@", 27 | qr/expected valid sigil/, 28 | '... signature parse failure works' 29 | ); 30 | } 31 | 32 | { 33 | eval 'class Boo { method foo ($bar { 1 } }'; 34 | like( 35 | "$@", 36 | qr/expected comma or closing/, 37 | '... signature parse failure works' 38 | ); 39 | } 40 | 41 | { 42 | eval 'class Too { method foo (%1foo) { 1 }}'; 43 | like( 44 | "$@", 45 | qr/invalid identifier/, 46 | '... method signature failure works' 47 | ); 48 | } 49 | 50 | { 51 | eval 'class Goo } { method foo ($bar { 1 } }'; 52 | like( 53 | "$@", 54 | qr/expected '{'/, 55 | '... class metadata parse failure works' 56 | ); 57 | } 58 | 59 | done_testing 60 | -------------------------------------------------------------------------------- /t/100-oddities/002-lexical-override-attribute.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | =pod 11 | 12 | Since attributes are viewed as 13 | lexically scoped variables, it 14 | is possible to overwrite the 15 | name (which is dumb, but you 16 | can do it). And this is fine 17 | as long as the scope doesn't 18 | bleed into other scopes (and 19 | it doesn't). 20 | 21 | =cut 22 | 23 | class Foo { 24 | has $bar = 99; 25 | 26 | method bar { $bar } 27 | 28 | method test { 29 | my $bar = 'bottles of beer'; 30 | join " " => ( $self->bar, $bar ); 31 | } 32 | } 33 | 34 | my $foo = Foo->new; 35 | 36 | is( $foo->test, '99 bottles of beer', '... this worked as expected' ); 37 | 38 | done_testing; 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /t/100-oddities/003-metadata-errors.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use mop; 10 | 11 | eval q[ 12 | class Foo (extends => $bar) {} 13 | ]; 14 | 15 | like "$@", qr/Global symbol "\$bar" requires explicit package name/, '... got the error we expected'; 16 | 17 | done_testing; 18 | -------------------------------------------------------------------------------- /t/100-oddities/003-returning-lexicals.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | 12 | has $bar; 13 | 14 | method bar_func { 15 | return sub { 1; $bar } 16 | } 17 | 18 | method self_func { 19 | return sub { 1; $self } 20 | } 21 | } 22 | 23 | my $foo = Foo->new( bar => 10 ); 24 | ok( $foo->isa( Foo ), '... got the instance we expected'); 25 | 26 | my $bar = Foo->new( bar => 20 ); 27 | ok( $bar->isa( Foo ), '... got the instance we expected'); 28 | 29 | my $foo_func = $foo->self_func; 30 | is( ref $foo_func, 'CODE', '... got the code ref we expected'); 31 | my $bar_func = $bar->self_func; 32 | is( ref $bar_func, 'CODE', '... got the code ref we expected'); 33 | 34 | my $foo_bar_func = $foo->bar_func; 35 | is( ref $foo_bar_func, 'CODE', '... got the code ref we expected'); 36 | my $bar_bar_func = $bar->bar_func; 37 | is( ref $bar_bar_func, 'CODE', '... got the code ref we expected'); 38 | 39 | is( $foo_func->(), $foo, '... and the function returns the $self we expected'); 40 | is( $bar_func->(), $bar, '... and the function returns the $self we expected'); 41 | 42 | is( $foo_bar_func->(), 10, '... and the function returns the $bar we expected'); 43 | is( $bar_bar_func->(), 20, '... and the function returns the $bar we expected'); 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /t/100-oddities/004-recursive-self.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | method foo ($a) { 12 | my $id = mop::uuid_of( $self ); 13 | if ( ref $a ne "" ) { 14 | $a->foo("x"); 15 | is( $id, mop::uuid_of( $self ), '... this should be the same ref'); 16 | } 17 | is( $id, mop::uuid_of( $self ), '... this should be the same ref'); 18 | } 19 | } 20 | 21 | my $foo = Foo->new; 22 | ok( $foo->isa( Foo ), '... got the instance we expected'); 23 | 24 | my $bar = Foo->new; 25 | ok( $bar->isa( Foo ), '... got the instance we expected'); 26 | 27 | $foo->foo($bar); 28 | 29 | done_testing; -------------------------------------------------------------------------------- /t/100-oddities/005-file-line.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use mop; 7 | 8 | class FileLine (extends => $::Class) { 9 | has $file; 10 | has $line; 11 | has $package; 12 | 13 | method file { $file } 14 | method line { $line } 15 | method package { $package } 16 | } 17 | 18 | my $line = __LINE__; 19 | { 20 | package Foo; 21 | use mop; 22 | class Foo ( 23 | metaclass => ::FileLine, 24 | file => __FILE__, 25 | line => __LINE__, 26 | package => __PACKAGE__, 27 | ) { 28 | has $file = __FILE__; 29 | has $line = __LINE__; 30 | has $package = __PACKAGE__; 31 | 32 | method file { $file } 33 | method line { $line } 34 | method package { $package } 35 | 36 | method FILE { __FILE__ } 37 | method LINE { __LINE__ } 38 | method PACKAGE { __PACKAGE__ } 39 | } 40 | } 41 | 42 | { 43 | is(Foo::Foo->file, __FILE__); 44 | is(Foo::Foo->new->file, __FILE__); 45 | is(Foo::Foo->new->FILE, __FILE__); 46 | 47 | is(Foo::Foo->line, $line + 7); 48 | is(Foo::Foo->new->line, $line + 11); 49 | is(Foo::Foo->new->LINE, $line + 19); 50 | 51 | is(Foo::Foo->package, 'Foo'); 52 | is(Foo::Foo->new->package, 'Foo'); 53 | is(Foo::Foo->new->PACKAGE, 'Foo'); 54 | } 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/100-oddities/006-naming-conflict.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | 8 | { 9 | package Foo; 10 | use mop; 11 | class Bar { 12 | method go { 13 | return 'package Foo, class Bar'; 14 | } 15 | } 16 | } 17 | 18 | 19 | { 20 | package Foo::Bar; 21 | sub new { 22 | bless []=> shift; 23 | } 24 | sub go { 25 | return 'package Foo::Bar'; 26 | } 27 | } 28 | 29 | is( 30 | Foo::Bar->new->go, 31 | 'package Foo, class Bar', 32 | ); 33 | 34 | is( 35 | 'Foo::Bar'->new->go, 36 | 'package Foo::Bar', 37 | ); 38 | 39 | -------------------------------------------------------------------------------- /t/100-oddities/010-recursive-self-more.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use v5.14; 4 | use strict; 5 | use warnings; 6 | 7 | use Test::More; 8 | 9 | use mop; 10 | 11 | my @lexical; 12 | my @global; 13 | 14 | class Tree { 15 | has $node; 16 | has $parent; 17 | has $children = []; 18 | 19 | method node { $node } 20 | method parent { $parent } 21 | method _set_parent ($p) { $parent = $p } 22 | 23 | method children { $children } 24 | 25 | method add_child ( $t ) { 26 | $t->_set_parent( $self ); 27 | push @$children => $t; 28 | $self; 29 | } 30 | 31 | $::CLASS->add_method($::Method->new( 32 | name => 'traverse', 33 | body => sub { 34 | my $indent = shift; 35 | $indent ||= ''; 36 | # say $indent, $::SELF->node, ' => ', $self, ' => ', $::SELF; 37 | push @lexical, $self; 38 | push @global, $::SELF; 39 | foreach my $t ( @{ $::SELF->children } ) { 40 | # warn $t, ' => ', $t->node; 41 | $t->traverse( $indent . ' ' ); 42 | } 43 | } 44 | )); 45 | 46 | #method traverse ($indent) { 47 | # $indent ||= ''; 48 | # say $indent, $node, ' => ', $self, ' => ', $::SELF; 49 | # foreach my $t ( @$children ) { 50 | # warn $t, ' => ', $t->node; 51 | # $t->traverse( $indent . ' ' ); 52 | # } 53 | #} 54 | } 55 | 56 | 57 | my $t = Tree->new( node => '0.0' ) 58 | ->add_child( Tree->new( node => '1.0' ) ) 59 | ->add_child( 60 | Tree->new( node => '2.0' ) 61 | ->add_child( Tree->new( node => '2.1' ) ) 62 | ) 63 | ->add_child( Tree->new( node => '3.0' ) ) 64 | ->add_child( Tree->new( node => '4.0' ) ); 65 | 66 | #use Data::Dumper; warn Dumper $t; 67 | 68 | local $TODO = "something in our pad munging is broken"; 69 | $t->traverse; 70 | is_deeply(\@lexical, \@global); 71 | 72 | done_testing; 73 | -------------------------------------------------------------------------------- /t/200-declare/001-class.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo {} 11 | 12 | is( Foo->get_name, 'Foo', '... got the name we expected' ); 13 | is( Foo->get_superclass, $::Object, '... got the superclass we expected' ); 14 | 15 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/002-class-w-method.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | method bar ( $baz ) { $baz } 12 | } 13 | 14 | is(Foo->get_name, 'Foo', '... got the name we expected'); 15 | is(Foo->get_superclass, $::Object, '... got the superclass we expected'); 16 | 17 | my $bar = Foo->find_method('bar'); 18 | ok($bar, '... got a bar'); 19 | ok($bar->isa( $::Method ), '... bar is a Method'); 20 | is($bar->get_name, 'bar', '... got the right name for bar'); 21 | 22 | my $foo = Foo->new; 23 | ok($foo->isa( Foo ), '... this is a Foo'); 24 | is(mop::class_of( $foo ), Foo, '... this is a Foo'); 25 | 26 | is($foo->bar(10), 10, '... returns what it is given'); 27 | 28 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/003-class-w-attribute.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | has $bar = 100; 12 | } 13 | 14 | is(Foo->get_name, 'Foo', '... got the name we expected'); 15 | is(Foo->get_superclass, $::Object, '... got the superclass we expected'); 16 | 17 | my $bar = Foo->get_all_attributes->{'$bar'}; 18 | ok($bar, '... got a bar'); 19 | ok($bar->isa( $::Attribute ), '... bar is a Attribute'); 20 | is($bar->get_name, '$bar', '... got the right name for bar'); 21 | is(${$bar->get_initial_value}->(), 100, '... got the right initial value for bar'); 22 | 23 | { 24 | my $foo = Foo->new; 25 | ok($foo->isa( Foo ), '... this is a Foo'); 26 | is(mop::class_of( $foo ), Foo, '... this is a Foo'); 27 | is(mop::internal::instance::get_slot_at( $foo, '$bar' ), 100, '... got the expected initial value'); 28 | } 29 | 30 | { 31 | my $foo = Foo->new( bar => 200 ); 32 | ok($foo->isa( Foo ), '... this is a Foo'); 33 | is(mop::class_of( $foo ), Foo, '... this is a Foo'); 34 | is(mop::internal::instance::get_slot_at( $foo, '$bar' ), 200, '... got the expected initial value'); 35 | } 36 | 37 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/004-class-w-both.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | has $bar = 100; 12 | 13 | method bar { $bar } 14 | } 15 | 16 | is(Foo->get_name, 'Foo', '... got the name we expected'); 17 | is(Foo->get_superclass, $::Object, '... got the superclass we expected'); 18 | 19 | my $bar = Foo->get_all_attributes->{'$bar'}; 20 | ok($bar, '... got a bar'); 21 | ok($bar->isa( $::Attribute ), '... bar is a Attribute'); 22 | is($bar->get_name, '$bar', '... got the right name for bar'); 23 | is(${$bar->get_initial_value}->(), 100, '... got the right initial value for bar'); 24 | 25 | { 26 | my $foo = Foo->new; 27 | ok($foo->isa( Foo ), '... this is a Foo'); 28 | is(mop::class_of( $foo ), Foo, '... this is a Foo'); 29 | is($foo->bar, 100, '... got the expected initial value'); 30 | } 31 | 32 | { 33 | my $foo = Foo->new( bar => 200 ); 34 | ok($foo->isa( Foo ), '... this is a Foo'); 35 | is(mop::class_of( $foo ), Foo, '... this is a Foo'); 36 | is($foo->bar, 200, '... got the expected initial value'); 37 | } 38 | 39 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/005-class-w-self-and-class-vars.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | method bar { 'BAR' } 12 | method baz { $self->bar } 13 | 14 | method foobar { $class->get_name } 15 | } 16 | 17 | is( Foo->get_name, 'Foo', '... got the name we expected' ); 18 | is(Foo->get_superclass, $::Object, '... got the superclass we expected'); 19 | 20 | my $foo = Foo->new; 21 | ok($foo->isa( Foo ), '... got the right instance'); 22 | is($foo->baz, 'BAR', '... the $self worked correctly'); 23 | is($foo->foobar, 'Foo', '... the $class worked correctly'); 24 | 25 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/006-class-w-metadata.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo {} 11 | class Bar (extends => Foo) {} 12 | 13 | is( Foo->get_name, 'Foo', '... got the name we expected' ); 14 | is(Foo->get_superclass, $::Object, '... got the superclass we expected'); 15 | 16 | is( Bar->get_name, 'Bar', '... got the name we expected' ); 17 | is( Bar->get_superclass, Foo, '... got the superclass we expected' ); 18 | 19 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/007-class-w-BUILD.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | class Foo { 11 | has $bar; 12 | 13 | BUILD ( $params ) { 14 | $bar .= $params->{'BAR'}; 15 | } 16 | 17 | method bar { $bar } 18 | } 19 | 20 | is(Foo->get_name, 'Foo', '... got the name we expected'); 21 | is(Foo->get_superclass, $::Object, '... got the superclass we expected'); 22 | 23 | my $foo_constructor = Foo->get_constructor(); 24 | ok( $foo_constructor, '... found the BUILD method' ); 25 | ok( $foo_constructor->isa( $::Method ), '... it is a proper method'); 26 | is($foo_constructor->get_name, 'BUILD', '... got the right name for BUILD'); 27 | 28 | my $foo = Foo->new( bar => "HELLO", BAR => ' World' ); 29 | ok($foo->isa( Foo ), '... this is a Foo'); 30 | is(mop::class_of( $foo ), Foo, '... this is a Foo'); 31 | 32 | is($foo->bar, "HELLO World", '... returns what it is given'); 33 | 34 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/010-methods.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my $Foo = $::Class->new; 11 | 12 | { 13 | local $::CLASS = $Foo; 14 | 15 | method foo ( $bar, $baz ) { 16 | join ", " => $bar, $baz; 17 | } 18 | 19 | method bar () { "BAR" } 20 | 21 | method baz { "BAZ" } 22 | 23 | method slurpy_array ($foo, @args) { 24 | $foo . ': ' . join(', ', @args); 25 | } 26 | 27 | method slurpy_hash ($foo, %params) { 28 | $foo . ': ' . join(', ', map { $_ . ' => ' . $params{$_} } keys %params); 29 | } 30 | 31 | method empty ($foo, $bar) {} 32 | 33 | method with_defaults ($foo, $bar = 10) { $foo + $bar } 34 | } 35 | 36 | my $foo_method = $Foo->find_method('foo'); 37 | ok( $foo_method, '... found the foo method' ); 38 | ok( $foo_method->isa( $::Method ), '... it is a proper method'); 39 | 40 | my $bar_method = $Foo->find_method('bar'); 41 | ok( $bar_method, '... found the bar method' ); 42 | ok( $bar_method->isa( $::Method ), '... it is a proper method'); 43 | 44 | my $baz_method = $Foo->find_method('baz'); 45 | ok( $baz_method, '... found the baz method' ); 46 | ok( $baz_method->isa( $::Method ), '... it is a proper method'); 47 | 48 | # We need to call this so that 49 | # Foo gets set up properly and 50 | # is given a v-table, etc, etc. 51 | $Foo->FINALIZE; 52 | 53 | my $foo = $Foo->new; 54 | is( $foo->foo( 10, 20 ), '10, 20', '... got the right value from ->foo' ); 55 | is( $foo->bar, 'BAR', '... got the right value from ->bar' ); 56 | is( $foo->baz, 'BAZ', '... got the right value from ->baz' ); 57 | is( $foo->slurpy_array( "foo", 1, 2, 3 ), 'foo: 1, 2, 3'); 58 | is( $foo->slurpy_hash( "bar", a => 1, b => 2 ), 'bar: a => 1, b => 2'); 59 | is( $foo->with_defaults(1), 11, 'defaults are used properly' ); 60 | is( $foo->with_defaults(1, 3), 4, 'defaults are used properly' ); 61 | my @list_empty = $foo->empty; 62 | is_deeply( \@list_empty, [], "empty method returns nothing" ); 63 | my $scalar_empty = $foo->empty; 64 | is( $scalar_empty, undef, "empty method returns nothing" ); 65 | 66 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/020-has.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my $Foo = $::Class->new; 11 | 12 | { 13 | local $::CLASS = $Foo; 14 | 15 | has $foo = 10; 16 | has $bar; 17 | } 18 | 19 | { 20 | my $attribute = $Foo->get_all_attributes->{'$foo'}; 21 | ok( $attribute, '... found the attribute' ); 22 | ok( $attribute->isa( $::Attribute ), '... it is a proper attribute'); 23 | is( $attribute->get_name, '$foo', '... got the right name'); 24 | is( ${ $attribute->get_initial_value }->(), 10, '... got the right initial value' ); 25 | } 26 | 27 | { 28 | my $attribute = $Foo->get_all_attributes->{'$bar'}; 29 | ok( $attribute, '... found the attribute' ); 30 | ok( $attribute->isa( $::Attribute ), '... it is a proper attribute'); 31 | is( $attribute->get_name, '$bar', '... got the right name'); 32 | is( ${ $attribute->get_initial_value }, undef, '... got the right initial value' ); 33 | } 34 | 35 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/021-has-w-metadata.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my $Foo = $::Class->new; 11 | 12 | { 13 | local $::CLASS = $Foo; 14 | 15 | has $bar ( initial_value => \200 ); 16 | } 17 | 18 | { 19 | my $attribute = $Foo->get_all_attributes->{'$bar'}; 20 | ok( $attribute, '... found the attribute' ); 21 | ok( $attribute->isa( $::Attribute ), '... it is a proper attribute'); 22 | is( $attribute->get_name, '$bar', '... got the right name'); 23 | is( ${ $attribute->get_initial_value }, 200, '... got the right initial value' ); 24 | } 25 | 26 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/022-has-w-block.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my $Foo = $::Class->new; 11 | 12 | { 13 | local $::CLASS = $Foo; 14 | 15 | my $counter = 0; 16 | 17 | has $bar = do { $counter++; [ map { $_ + $counter } 0 .. 5 ] }; 18 | 19 | has $baz = { one => 1 }; 20 | } 21 | 22 | { 23 | my $attribute = $Foo->get_all_attributes->{'$bar'}; 24 | ok( $attribute, '... found the attribute' ); 25 | ok( $attribute->isa( $::Attribute ), '... it is a proper attribute'); 26 | is( $attribute->get_name, '$bar', '... got the right name'); 27 | is_deeply( 28 | ${ $attribute->get_initial_value_for_instance( $attribute ) }, 29 | [ 1, 2, 3, 4, 5, 6 ], 30 | '... got the right initial value' 31 | ); 32 | is_deeply( 33 | ${ $attribute->get_initial_value_for_instance( $attribute ) }, 34 | [ 2, 3, 4, 5, 6, 7 ], 35 | '... got the right initial value' 36 | ); 37 | is_deeply( 38 | ${ $attribute->get_initial_value_for_instance( $attribute ) }, 39 | [ 3, 4, 5, 6, 7, 8 ], 40 | '... got the right initial value' 41 | ); 42 | } 43 | 44 | { 45 | my $attribute = $Foo->get_all_attributes->{'$baz'}; 46 | ok( $attribute, '... found the attribute' ); 47 | ok( $attribute->isa( $::Attribute ), '... it is a proper attribute'); 48 | is( $attribute->get_name, '$baz', '... got the right name'); 49 | is_deeply( 50 | ${ $attribute->get_initial_value_for_instance( $attribute ) }, 51 | { one => 1 }, 52 | '... got the right initial value' 53 | ); 54 | } 55 | 56 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/023-has-w-object.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my $Foo = $::Class->new; 11 | 12 | my $has_Bar_been_created = 0; 13 | 14 | class Bar { 15 | BUILD { $has_Bar_been_created = 1 } 16 | } 17 | 18 | { 19 | local $::CLASS = $Foo; 20 | 21 | has $foo = Bar->new; 22 | } 23 | 24 | { 25 | my $attribute = $Foo->get_all_attributes->{'$foo'}; 26 | ok( $attribute, '... found the attribute' ); 27 | ok( $attribute->isa( $::Attribute ), '... it is a proper attribute'); 28 | is( $attribute->get_name, '$foo', '... got the right name'); 29 | 30 | ok(!$has_Bar_been_created, '... no Bar instances have been created yet'); 31 | 32 | my $bar1 = ${ $attribute->get_initial_value }->(); 33 | ok( $bar1->isa( Bar ), '... got the right initial value' ); 34 | 35 | ok($has_Bar_been_created, '... a Bar instance has been created now'); 36 | 37 | my $bar2 = ${ $attribute->get_initial_value }->(); 38 | ok( $bar2->isa( Bar ), '... got the right initial value (again)' ); 39 | 40 | isnt( $bar1, $bar2, '... these are two distinct instances' ); 41 | } 42 | 43 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/030-BUILD.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use mop; 9 | 10 | my $Foo = $::Class->new; 11 | 12 | { 13 | local $::CLASS = $Foo; 14 | 15 | BUILD ( $params ) {} 16 | } 17 | 18 | my $foo_constructor = $Foo->get_constructor(); 19 | ok( $foo_constructor, '... found the BUILD method' ); 20 | ok( $foo_constructor->isa( $::Method ), '... it is a proper method'); 21 | is($foo_constructor->get_name, 'BUILD', '... got the right name for BUILD'); 22 | 23 | 24 | done_testing; -------------------------------------------------------------------------------- /t/200-declare/040-smartmatch.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use 5.014; 6 | 7 | use mop; 8 | 9 | class Foo { } 10 | class Bar (extends => Foo) { } 11 | class Baz (extends => Bar) { } 12 | class Quux { } 13 | 14 | { 15 | my $found; 16 | given (Foo->new) { 17 | when (Quux) { $found = "Quux" } 18 | when (Baz) { $found = "Baz" } 19 | when (Bar) { $found = "Bar" } 20 | when (Foo) { $found = "Foo" } 21 | default { $found = "default" } 22 | } 23 | is($found, "Foo"); 24 | } 25 | 26 | { 27 | my $found; 28 | given (Bar->new) { 29 | when (Quux) { $found = "Quux" } 30 | when (Baz) { $found = "Baz" } 31 | when (Bar) { $found = "Bar" } 32 | when (Foo) { $found = "Foo" } 33 | default { $found = "default" } 34 | } 35 | is($found, "Bar"); 36 | } 37 | 38 | { 39 | my $found; 40 | given (Bar->new) { 41 | when (Quux) { $found = "Quux" } 42 | when (Baz) { $found = "Baz" } 43 | when (Foo) { $found = "Foo" } 44 | default { $found = "default" } 45 | } 46 | is($found, "Foo"); 47 | } 48 | 49 | done_testing; 50 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/000-load.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/Class-MOPX'; 6 | 7 | BEGIN { 8 | use_ok('Class::MOPX'); 9 | } 10 | 11 | done_testing; 12 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/001-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/Class-MOPX'; 6 | 7 | use Class::MOPX; 8 | 9 | class Foo { 10 | has $foo (reader => 'get_foo', writer => 'set_foo'); 11 | has $bar (accessor => 'bar'); 12 | has $baz (predicate => 'has_baz', clearer => 'clear_baz') = 1; 13 | } 14 | 15 | { 16 | isa_ok(Foo, Class::MOPX::Class); 17 | isa_ok(Foo->find_attribute($_), Class::MOPX::Attribute) 18 | for qw($foo $bar $baz); 19 | isa_ok(Foo->find_method($_), Class::MOPX::Method) 20 | for qw(get_foo set_foo bar has_baz clear_baz); 21 | } 22 | 23 | { 24 | my $foo = Foo->new; 25 | can_ok($foo, $_) 26 | for qw(get_foo set_foo bar has_baz clear_baz); 27 | 28 | is($foo->get_foo, undef); 29 | $foo->set_foo("FOO"); 30 | is($foo->get_foo, "FOO"); 31 | 32 | is($foo->bar, undef); 33 | $foo->bar("BAR"); 34 | is($foo->bar, "BAR"); 35 | 36 | ok($foo->has_baz); 37 | $foo->clear_baz; 38 | ok(!$foo->has_baz); 39 | } 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/002-init_arg.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/Class-MOPX'; 6 | 7 | use Class::MOPX; 8 | 9 | class Foo { 10 | has $foo (init_arg => 'bar'); 11 | method foo { $foo } 12 | } 13 | 14 | { 15 | is(Foo->new(foo => 1)->foo, undef); 16 | is(Foo->new(bar => 1)->foo, 1); 17 | } 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/003-builder.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/Class-MOPX'; 6 | 7 | use Class::MOPX; 8 | 9 | class Foo { 10 | has $foo (builder => 'build_foo'); 11 | 12 | method foo { $foo } 13 | 14 | method build_foo { "FOO" } 15 | } 16 | 17 | { 18 | is(Foo->new->foo, "FOO"); 19 | } 20 | 21 | done_testing; 22 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/004-lazy.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use 5.014; 5 | use Test::More; 6 | use lib 't/ext/Class-MOPX'; 7 | 8 | use Class::MOPX; 9 | 10 | my $i; 11 | class Foo { 12 | has $foo ( 13 | lazy => 1, 14 | reader => 'foo', 15 | builder => '_build_foo', 16 | predicate => 'has_foo', 17 | clearer => 'clear_foo', 18 | ); 19 | 20 | method _build_foo { ++$i } 21 | } 22 | 23 | { 24 | $i = 0; 25 | my $foo = Foo->new; 26 | ok(!$foo->has_foo); 27 | is($foo->foo, 1); 28 | ok($foo->has_foo); 29 | $foo->clear_foo; 30 | ok(!$foo->has_foo); 31 | is($foo->foo, 2); 32 | ok($foo->has_foo); 33 | } 34 | 35 | { 36 | $i = 0; 37 | my $foo = Foo->new(foo => 5); 38 | ok($foo->has_foo); 39 | is($foo->foo, 5); 40 | $foo->clear_foo; 41 | ok(!$foo->has_foo); 42 | is($foo->foo, 1); 43 | ok($foo->has_foo); 44 | } 45 | 46 | class Bar { 47 | has $bar ( 48 | lazy => 1, 49 | reader => 'bar', 50 | predicate => 'has_bar', 51 | clearer => 'clear_bar', 52 | ) = do { ++$i }; 53 | } 54 | 55 | { 56 | $i = 0; 57 | my $bar = Bar->new; 58 | { local $TODO = "lazy + default doesn't work yet"; 59 | ok(!$bar->has_bar); 60 | } 61 | is($bar->bar, 1); 62 | ok($bar->has_bar); 63 | $bar->clear_bar; 64 | ok(!$bar->has_bar); 65 | { local $TODO = "lazy + default doesn't work yet"; 66 | is($bar->bar, 2); 67 | ok($bar->has_bar); 68 | } 69 | } 70 | 71 | { 72 | $i = 0; 73 | my $bar = Bar->new(bar => 5); 74 | ok($bar->has_bar); 75 | is($bar->bar, 5); 76 | $bar->clear_bar; 77 | ok(!$bar->has_bar); 78 | { local $TODO = "lazy + default doesn't work yet"; 79 | is($bar->bar, 1); 80 | ok($bar->has_bar); 81 | } 82 | } 83 | 84 | done_testing; 85 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/005-is.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/Class-MOPX'; 6 | 7 | use Class::MOPX; 8 | 9 | class Foo { 10 | has $foo (is => 'ro'); 11 | } 12 | 13 | { 14 | my $foo = Foo->new(foo => "FOO"); 15 | can_ok($foo, 'foo'); 16 | is($foo->foo, "FOO"); 17 | } 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/006-required.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Fatal; 6 | use lib 't/ext/Class-MOPX'; 7 | 8 | use Class::MOPX; 9 | 10 | class Foo { 11 | has $foo (is => 'ro', required => 1); 12 | } 13 | 14 | { 15 | my $foo; 16 | like( 17 | exception { $foo = Foo->new }, 18 | qr/Attribute \$foo is required/, 19 | "required attributes must be provided" 20 | ); 21 | is(exception { $foo = Foo->new(foo => 1) }, undef, 22 | "object creation works if required parameters are fulfilled"); 23 | is($foo->foo, 1); 24 | } 25 | 26 | class Bar { 27 | has $foo (is => 'ro', required => 1) = 23; 28 | } 29 | 30 | { 31 | my $bar; 32 | is(exception { $bar = Bar->new }, undef, 33 | "defaults fulfill requirements"); 34 | is($bar->foo, 23); 35 | } 36 | 37 | class Baz { 38 | has $foo (is => 'ro', required => 1, builder => 'build_foo'); 39 | method build_foo { "FOO" } 40 | } 41 | 42 | { 43 | my $baz; 44 | is(exception { $baz = Baz->new }, undef, 45 | "builders fulfill requirements"); 46 | is($baz->foo, "FOO"); 47 | } 48 | 49 | done_testing; 50 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/010-associated_class.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/Class-MOPX'; 6 | 7 | use Class::MOPX; 8 | 9 | use Scalar::Util 'weaken'; 10 | 11 | class Foo { 12 | has $foo; 13 | method foo { $foo } 14 | } 15 | 16 | { 17 | my $attr = Foo->find_attribute('$foo'); 18 | my $method = Foo->find_method('foo'); 19 | 20 | isa_ok($attr->associated_class, Class::MOPX::Class); 21 | isa_ok($method->associated_class, Class::MOPX::Class); 22 | 23 | weaken(my $class = Foo); 24 | is($class, Foo); 25 | 26 | undef *Foo; 27 | 28 | { local $TODO = "we're too leaky for this to work at the moment"; 29 | is($attr->associated_class, undef); 30 | is($method->associated_class, undef); 31 | is($class, undef); 32 | } 33 | } 34 | 35 | done_testing; 36 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/020-types.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Fatal; 6 | use lib 't/ext/Class-MOPX'; 7 | 8 | use Class::MOPX; 9 | use Class::MOPX::Types; 10 | 11 | class Foo { 12 | has $foo ( 13 | is => 'rw', 14 | isa => T->type('Int'), 15 | ); 16 | has $bar ( 17 | reader => 'get_bar', 18 | writer => 'set_bar', 19 | isa => T->type('ArrayRef'), 20 | ); 21 | } 22 | 23 | { 24 | my $foo = Foo->new; 25 | is(exception { $foo->foo(23) }, undef, 26 | "23 passes the constraint"); 27 | is($foo->foo, 23); 28 | like( 29 | exception { $foo->foo("bar") }, 30 | qr/Type constraint Int failed with value bar/, 31 | "'bar' doesn't pass the constraint" 32 | ); 33 | is($foo->foo, 23); 34 | } 35 | 36 | { 37 | my $foo = Foo->new; 38 | my $aref = []; 39 | is(exception { $foo->set_bar($aref) }, undef, 40 | "arrayref passes the constraint"); 41 | is($foo->get_bar, $aref); 42 | like( 43 | exception { $foo->set_bar("bar") }, 44 | qr/Type constraint ArrayRef failed with value bar/, 45 | "'bar' doesn't pass the constraint" 46 | ); 47 | is($foo->get_bar, $aref); 48 | } 49 | 50 | { 51 | my $foo; 52 | is(exception { $foo = Foo->new(foo => 23) }, undef, 53 | "constraints in constructors work"); 54 | is($foo->foo, 23); 55 | like( 56 | exception { $foo = Foo->new(foo => "FOO") }, 57 | qr/Type constraint Int failed with value FOO/, 58 | "constraints in constructors work" 59 | ); 60 | 61 | my $aref = []; 62 | is(exception { $foo = Foo->new(bar => $aref) }, undef, 63 | "constraints in constructors work"); 64 | is($foo->get_bar, $aref); 65 | like( 66 | exception { $foo = Foo->new(bar => "FOO") }, 67 | qr/Type constraint ArrayRef failed with value FOO/, 68 | "constraints in constructors work" 69 | ); 70 | } 71 | 72 | class Bar { 73 | has $foo ( 74 | is => 'ro', 75 | isa => T->type('Int'), 76 | lazy => 1, 77 | builder => 'build_foo' 78 | ); 79 | method build_foo { "FOO" } 80 | 81 | has $bar ( 82 | is => 'rw', 83 | isa => T->type('Int'), 84 | lazy => 1, 85 | builder => 'build_bar' 86 | ); 87 | method build_bar { "BAR" } 88 | } 89 | 90 | { 91 | my $bar = Bar->new; 92 | like( 93 | exception { $bar->foo }, 94 | qr/Type constraint Int failed with value FOO/, 95 | "lazy defaults also fail" 96 | ); 97 | like( 98 | exception { $bar->bar }, 99 | qr/Type constraint Int failed with value BAR/, 100 | "lazy defaults also fail" 101 | ); 102 | } 103 | 104 | done_testing; 105 | -------------------------------------------------------------------------------- /t/300-ext/Class-MOPX/100-extension.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/Class-MOPX'; 6 | 7 | BEGIN { 8 | package FollowPBP; 9 | 10 | use Class::MOPX; 11 | 12 | class Attribute (extends => Class::MOPX::Attribute) { 13 | has $reader; 14 | has $writer; 15 | has $accessor; 16 | 17 | BUILD ($params) { 18 | if (my $is = $params->{is}) { 19 | (my $name = $self->get_name) =~ s/^\$//; 20 | if ($is eq 'ro') { 21 | $reader = 'get_' . $name; 22 | } 23 | elsif ($is eq 'rw') { 24 | $reader = 'get_' . $name; 25 | $writer = 'set_' . $name; 26 | $accessor = undef; 27 | } 28 | } 29 | } 30 | } 31 | 32 | class Class (extends => Class::MOPX::Class) { 33 | method attribute_class { Attribute } 34 | } 35 | 36 | sub import { mop->import(-metaclass => Class) } 37 | 38 | $INC{'FollowPBP.pm'} = 1; 39 | } 40 | 41 | { 42 | use Class::MOPX; 43 | use FollowPBP; 44 | 45 | class Foo { 46 | has $foo (is => 'ro'); 47 | has $bar (is => 'rw'); 48 | } 49 | } 50 | 51 | { 52 | my $foo = Foo->new(foo => "FOO", bar => "BAR"); 53 | can_ok($foo, 'get_foo'); 54 | can_ok($foo, 'get_bar'); 55 | can_ok($foo, 'set_bar'); 56 | ok(!$foo->can('foo')); 57 | ok(!$foo->can('bar')); 58 | is($foo->get_foo, "FOO"); 59 | is($foo->get_bar, "BAR"); 60 | } 61 | 62 | done_testing; 63 | -------------------------------------------------------------------------------- /t/300-ext/Test-BuilderX/001-load.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | A long, long time ago ... in a galaxy far, far away ... http://svn.openfoundry.org/pugs/ext/Test-Builder 11 | 12 | So, back in the heydays of Pugs, chromatic 13 | decided to experiment and port Test::Builder 14 | to Perl 6. Fast forward many years into the 15 | future ... and I decided I needed an example 16 | for the p5mop that was sufficiently complex 17 | enough to test features and show-off some of 18 | the syntactic sweetness. I think this has 19 | actually succeded quite well in accomplishing 20 | this. Some notable features are: 21 | 22 | =over 4 23 | 24 | =item ArrayRef attributes 25 | 26 | The syntax to operate on them is kind of 27 | nice (in my opinion anyway): 28 | 29 | push @$results => $test 30 | 31 | This can be seen in the Test::BuilderX 32 | class in particular. 33 | 34 | =item Using defined-or (//) in BUILD 35 | 36 | See Test::BuilderX::BUILD for an example. 37 | 38 | =item Multiple classes per-file 39 | 40 | See both Test::BuilderX::TestPlan and 41 | Test::BuilderX::Test for an example. 42 | 43 | =item Using old style Perl OO as a factory 44 | 45 | If you look in Test::BuilderX::Test, the &new 46 | method is just a factory for constructing the 47 | new MOP powered classes. This is a nice mix of 48 | the two styles in my opinion. 49 | 50 | =item Mixing procedural with new OO 51 | 52 | See Test::BuilderX::Tester for an example of 53 | this. Again, I think this shows how the new 54 | style classes can compliment old style perl. 55 | 56 | =back 57 | 58 | =cut 59 | 60 | use lib 't/ext/Test-BuilderX'; 61 | 62 | BEGIN { 63 | use_ok( 'Test::BuilderX' ); 64 | use_ok( 'Test::BuilderX::Tester' ); 65 | } 66 | 67 | done_testing; 68 | 69 | 70 | -------------------------------------------------------------------------------- /t/300-ext/Test-BuilderX/010-Test_Builder.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use lib 't/ext/Test-BuilderX'; 8 | 9 | BEGIN { 10 | use_ok( 'Test::BuilderX' ); 11 | use_ok( 'Test::BuilderX::TestPlan' ); 12 | } 13 | 14 | my $tb = Test::BuilderX->new; 15 | is( mop::class_of( $tb ), Test::BuilderX, '... got the expected class' ); 16 | ok( $tb->isa( Test::BuilderX ), '... it isa Test::BuilderX' ); 17 | 18 | # skipping the singleton tests here ... 19 | 20 | # skipping the destroy tests here ... 21 | 22 | done_testing; 23 | 24 | 25 | -------------------------------------------------------------------------------- /t/300-ext/Test-BuilderX/020-Test_Builder_Test.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use lib 't/ext/Test-BuilderX'; 8 | 9 | BEGIN { 10 | use_ok( 'Test::BuilderX::Test' ); 11 | } 12 | 13 | my $pass_test = Test::BuilderX::Test->new( 14 | number => 1, 15 | passed => 1, 16 | description => 'first test description' 17 | ); 18 | is( mop::class_of( $pass_test ), Test::BuilderX::Test::Pass, '... we got a Test::BuilderX::Test::Pass instance'); 19 | is($pass_test->number, 1, '... got the right test number'); 20 | ok($pass_test->passed, '... this test passed'); 21 | is($pass_test->description, 'first test description', '... got the right test description'); 22 | is_deeply( $pass_test->status, { passed => 1, description => 'first test description' }, '... got the right status'); 23 | is($pass_test->report, 'ok 1 - first test description', '... got the right report'); 24 | 25 | my $fail_test = Test::BuilderX::Test->new( 26 | number => 2, 27 | passed => 0, 28 | description => 'first test description' 29 | ); 30 | is( mop::class_of( $fail_test ), Test::BuilderX::Test::Fail, '... we got a Test::BuilderX::Test::Fail instance'); 31 | is($fail_test->number, 2, '... got the right test number'); 32 | ok(!$fail_test->passed, '... this test passed'); 33 | is($fail_test->description, 'first test description', '... got the right test description'); 34 | is_deeply( $fail_test->status, { passed => 0, description => 'first test description' }, '... got the right status'); 35 | is($fail_test->report, 'not ok 2 - first test description', '... got the right report'); 36 | 37 | my $todo_test = Test::BuilderX::Test->new( 38 | number => 3, 39 | passed => 1, 40 | description => 'first test description', 41 | todo => 1, 42 | reason => 'this is TODO', 43 | ); 44 | is( mop::class_of( $todo_test ), Test::BuilderX::Test::TODO, '... we got a Test::BuilderX::Test::TODO instance'); 45 | is($todo_test->number, 3, '... got the right test number'); 46 | ok($todo_test->passed, '... this test passed'); 47 | is($todo_test->description, 'first test description', '... got the right test description'); 48 | is_deeply( 49 | $todo_test->status, 50 | { 51 | passed => 1, 52 | really_passed => 1, 53 | reason => 'this is TODO', 54 | description => 'first test description', 55 | TODO => 1 56 | }, 57 | '... got the right status' 58 | ); 59 | is($todo_test->report, 'ok 3 # TODO first test description', '... got the right report'); 60 | 61 | my $skip_test = Test::BuilderX::Test->new( 62 | number => 4, 63 | passed => 1, 64 | description => 'first test description', 65 | skip => 1, 66 | reason => 'this is Skip', 67 | ); 68 | is( mop::class_of( $skip_test ), Test::BuilderX::Test::Skip, '... we got a Test::BuilderX::Test::Skip instance'); 69 | is($skip_test->number, 4, '... got the right test number'); 70 | ok($skip_test->passed, '... this test passed'); 71 | is($skip_test->description, 'first test description', '... got the right test description'); 72 | is_deeply( 73 | $skip_test->status, 74 | { 75 | passed => 1, 76 | skip => 1, 77 | reason => 'this is Skip', 78 | description => 'first test description', 79 | }, 80 | '... got the right status' 81 | ); 82 | is($skip_test->report, 'not ok 4 #skip this is Skip', '... got the right report'); 83 | 84 | 85 | 86 | done_testing; 87 | 88 | 89 | -------------------------------------------------------------------------------- /t/300-ext/explicit-override/001-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Fatal; 6 | use lib 't/ext/explicit-override'; 7 | 8 | BEGIN { 9 | eval { require List::MoreUtils; 1 } 10 | or plan skip_all => "List::MoreUtils is required for this test"; 11 | } 12 | 13 | use mop; 14 | use explicit::override; 15 | 16 | class Foo { 17 | method foo { 'BASE' } 18 | } 19 | eval < Foo) { 21 | override foo => sub { 'SUB' }; 22 | } 23 | CLASS 24 | 25 | ok(!$@); 26 | 27 | is(FooSub()->new->foo, 'SUB'); 28 | 29 | eval < Foo) { 31 | method foo { 'SUB2' } 32 | } 33 | CLASS 34 | 35 | like( 36 | $@, 37 | qr/^Overriding method foo without using override/ 38 | ); 39 | 40 | done_testing; 41 | -------------------------------------------------------------------------------- /t/300-ext/mopx-instance-tracking/001-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use lib 't/ext/mopx-instance-tracking'; 6 | 7 | BEGIN { 8 | eval { require Set::Object::Weak; 1 } 9 | or plan skip_all => "Set::Object::Weak is required for this test"; 10 | } 11 | 12 | use mop; 13 | use mopx::instance::tracking; 14 | 15 | class Foo { 16 | } 17 | 18 | sub is_instances { 19 | my ($class, @instances) = @_; 20 | local $Test::Builder::Level = $Test::Builder::Level + 1; 21 | is_deeply( 22 | [ sort { $a <=> $b } $class->instances ], 23 | [ sort { $a <=> $b } @instances ] 24 | ); 25 | } 26 | 27 | my $foo = Foo->new(); 28 | is_instances(Foo, $foo); 29 | 30 | do { 31 | my $bar = Foo->new(); 32 | is_instances(Foo, $foo, $bar); 33 | }; 34 | 35 | is_instances(Foo, $foo); 36 | 37 | class Person { 38 | has $name; 39 | } 40 | 41 | my $stevan = Person->new(name => 'Stevan'); 42 | my $jesse = Person->new(name => 'Jesse'); 43 | 44 | is_instances(Person, $stevan, $jesse); 45 | is_instances(Foo, $foo); 46 | 47 | done_testing(); 48 | 49 | -------------------------------------------------------------------------------- /t/400-yapc-eu-examples/001-basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.14; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | 10 | BEGIN { 11 | eval { require Devel::StackTrace; 1 } 12 | or plan skip_all => "Devel::StackTrace is required for this test"; 13 | 14 | eval { require Try; 1 } 15 | or plan skip_all => "Try is required for this test"; 16 | 17 | eval { require Fun; 1 } 18 | or plan skip_all => "Fun is required for this test"; 19 | 20 | eval { require Variable::Magic; 1 } 21 | or plan skip_all => "Variable::Magic is required for this test"; 22 | 23 | eval { require Perl6::Junction; 1 } 24 | or plan skip_all => "Perl6::Junction is required for this test"; 25 | } 26 | 27 | use Scalar::Util 'blessed'; 28 | use File::Temp 'tempfile'; 29 | use Fun; use Try; 30 | 31 | use lib 't/400-yapc-eu-examples/lib/'; 32 | 33 | package MyApp::IO { 34 | use strict; 35 | use warnings; 36 | use mop; 37 | use Fun; 38 | use GuardedAttribute; 39 | use Perl6::Junction qw[ any ]; 40 | 41 | role FileInfo ( metaclass => GuardedAttributeRole ) { 42 | has $mode ( guard => fun ($x) { $x eq any('r', 'w') } ); 43 | has $filename ( guard => fun ($x) { defined $x } ); 44 | method mode { $mode } 45 | method filename { $filename } 46 | } 47 | 48 | class FileHandle ( with => [FileInfo] ) { 49 | has $fh; 50 | 51 | BUILD ($params) { 52 | $fh = IO::File->new( $self->filename, $self->mode ) 53 | or MyApp::IO::Util::convert_error( $!, $self ); 54 | } 55 | 56 | method iter_lines ( $f ) { 57 | while ( my $line = $fh->getline ) { 58 | MyApp::IO::Util::convert_error( $!, $self ) 59 | if not defined $line; 60 | $f->( $line ); 61 | } 62 | $fh->seek( 0, 0 ); 63 | $self; 64 | } 65 | 66 | method slurp { 67 | $fh->read( my $x, -s $fh ) 68 | or MyApp::IO::Util::convert_error( $!, $self ); 69 | $x; 70 | } 71 | 72 | DEMOLISH { 73 | $fh->close or MyApp::IO::Util::convert_error( $!, $self ) 74 | if $fh; 75 | } 76 | } 77 | 78 | package MyApp::IO::Error { 79 | use strict; 80 | use warnings; 81 | use mop; 82 | 83 | use Throwable; 84 | 85 | class FileNotFound ( with => [ Throwable, MyApp::IO::FileInfo ] ) { 86 | method format_message ( $message ) { 87 | "File '" . $self->filename . "' not found" . ($message ? ": $message" : '') 88 | } 89 | } 90 | 91 | class PermissionsError ( with => [ Throwable, MyApp::IO::FileInfo ] ) { 92 | method format_message ( $message ) { 93 | my $type = do { 94 | given ( $self->mode ) { 95 | when ('r') { 'readable' } 96 | when ('w') { 'writeable' } 97 | } 98 | }; 99 | "File '" . $self->filename . "' is not '$type'" . ($message ? ": $message" : '') 100 | } 101 | } 102 | } 103 | 104 | package MyApp::IO::Util { 105 | use strict; 106 | use warnings; 107 | use Fun; 108 | 109 | fun convert_error ($err, $handle) { 110 | given ( $err ) { 111 | when ( 'No such file or directory' ) { 112 | MyApp::IO::Error::FileNotFound->new( 113 | filename => $handle->filename 114 | )->throw 115 | } 116 | when ( 'Permission denied' ) { 117 | MyApp::IO::Error::PermissionsError->new( 118 | filename => $handle->filename, 119 | mode => $handle->mode 120 | )->throw 121 | } 122 | default { 123 | warn $err if $err; 124 | } 125 | } 126 | } 127 | } 128 | } 129 | 130 | my ($fh, $filename) = tempfile; 131 | 132 | try { 133 | my $r = MyApp::IO::FileHandle->new( filename => $filename, mode =>'r' ); 134 | my $x = 0; 135 | $r->iter_lines( fun ( $line ) { chomp $line && say join ' ' => $x++, ':', $line } ); 136 | pass("... this worked"); 137 | } catch { 138 | fail("... this failed"); 139 | when ( blessed $_ ) { 140 | warn $_->as_string; 141 | } 142 | default { 143 | warn $_; 144 | } 145 | } 146 | 147 | #unlink $filename; 148 | 149 | done_testing; 150 | 151 | -------------------------------------------------------------------------------- /t/400-yapc-eu-examples/100-throwable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | eval { require Devel::StackTrace; 1 } 10 | or plan skip_all => "Devel::StackTrace is required for this test"; 11 | } 12 | 13 | use mop; 14 | 15 | use lib 't/400-yapc-eu-examples/lib/'; 16 | 17 | use Throwable; 18 | 19 | class MyError ( with => [Throwable] ) {} 20 | 21 | sub foo { MyError->new( message => "HELLO" )->throw } 22 | sub bar { foo() } 23 | 24 | eval { bar }; 25 | my $e = $@; 26 | 27 | ok( $e->does( Throwable ), '... the exception does the Throwable role' ); 28 | ok( $e->isa( MyError ), '... the exception is a MyError object' ); 29 | 30 | is( $e->message, 'HELLO', '... got the exception' ); 31 | 32 | isa_ok( $e->stack_trace, 'Devel::StackTrace' ); 33 | 34 | my $file = __FILE__; 35 | $file =~ s/^\.\///; 36 | 37 | is( 38 | $e->stack_trace->as_string, 39 | qq[Trace begun at $file line 22 40 | main::bar at $file line 24 41 | eval {...} at $file line 24 42 | ], 43 | '... got the exception' 44 | ); 45 | 46 | done_testing; 47 | 48 | -------------------------------------------------------------------------------- /t/400-yapc-eu-examples/101-guarded-attributes.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | BEGIN { 10 | eval { require Fun; 1 } 11 | or plan skip_all => "Fun is required for this test"; 12 | 13 | eval { require Variable::Magic; 1 } 14 | or plan skip_all => "Variable::Magic is required for this test"; 15 | } 16 | 17 | use mop; 18 | use Fun; 19 | 20 | use lib 't/400-yapc-eu-examples/lib/'; 21 | 22 | use GuardedAttribute; 23 | 24 | class Foo (metaclass => GuardedAttributeClass) { 25 | has $bar; 26 | has $baz; 27 | has $age ( guard => fun ($x) { $x =~ /^\d+$/ } ); 28 | 29 | method age { $age } 30 | method set_age ( $new_age ) { 31 | $age = $new_age; 32 | } 33 | } 34 | 35 | my $foo = Foo->new; 36 | 37 | my $age_attr = Foo->find_attribute('$age'); 38 | ok($age_attr->isa( GuardedAttribute ), '... this is a Guarded Attribute'); 39 | 40 | { 41 | my $guard = $age_attr->guard; 42 | ok($guard->( 10 ), '... guard worked as expected'); 43 | } 44 | 45 | like(exception { $foo->set_age('test') }, qr/^Value \'SCALAR\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 46 | like(exception { $foo->set_age(\10) }, qr/^Value \'REF\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 47 | like(exception { $foo->set_age([]) }, qr/^Value \'REF\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 48 | like(exception { $foo->set_age({}) }, qr/^Value \'REF\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 49 | 50 | is(exception { $foo->set_age(10) }, undef, '... guard accepted the input'); 51 | 52 | is($foo->age, 10, '... got the right value'); 53 | 54 | # metaroles 55 | 56 | role Bar (metaclass => GuardedAttributeRole) { 57 | has $hash ( guard => fun ($x) { ref $x && ref $x eq 'HASH' } ); 58 | 59 | method hash { $hash } 60 | method set_hash ( $new_hash ) { 61 | $hash = $new_hash; 62 | } 63 | } 64 | 65 | class Baz ( with => [Bar] ) {} 66 | 67 | my $baz = Baz->new; 68 | 69 | my $hash_attr = Baz->find_attribute('$hash'); 70 | ok($hash_attr->isa( GuardedAttribute ), '... this is a Guarded Attribute'); 71 | 72 | { 73 | my $guard = $hash_attr->guard; 74 | ok($guard->( {} ), '... guard worked as expected'); 75 | } 76 | 77 | like(exception { $baz->set_hash('test') }, qr/^Value \'SCALAR\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 78 | like(exception { $baz->set_hash(\10) }, qr/^Value \'REF\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 79 | like(exception { $baz->set_hash([]) }, qr/^Value \'REF\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 80 | like(exception { $baz->set_hash(10) }, qr/^Value \'SCALAR\(0x[a-z0-9]+\)\' did not pass the guard .*/, '... guard tripped the exception'); 81 | 82 | is(exception { $baz->set_hash({ foo => 1 }) }, undef, '... guard accepted the input'); 83 | 84 | is_deeply($baz->hash, { foo => 1 }, '... got the right value'); 85 | 86 | done_testing; -------------------------------------------------------------------------------- /t/400-yapc-eu-examples/lib/GuardedAttribute.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use mop; 4 | 5 | use Variable::Magic qw[ wizard cast ]; 6 | 7 | role MetaAttributeWithGuard { 8 | has $guard; 9 | 10 | method guard { $guard } 11 | method has_guard { defined $guard } 12 | 13 | method get_initial_value_for_instance { 14 | my $value = super; 15 | return $value unless $self->has_guard; 16 | $self->_add_guard_to_slot( $value ); 17 | } 18 | 19 | method prepare_constructor_value_for_instance ( $value ) { 20 | return super( $value ) unless $self->has_guard; 21 | $self->_add_guard_to_slot( $value ); 22 | } 23 | 24 | method _add_guard_to_slot ( $value ) { 25 | my $guard = $self->guard; 26 | my $wiz = wizard(set => sub { 27 | die "Value '$_[0]' did not pass the guard" unless $guard->( ${ $_[0] } ) 28 | }); 29 | cast $$value, $wiz; 30 | $value; 31 | } 32 | } 33 | 34 | class GuardedAttribute (extends => $::Attribute, with => [MetaAttributeWithGuard]) {} 35 | 36 | class GuardedAttributeClass (extends => $::Class) { 37 | method attribute_class { GuardedAttribute } 38 | } 39 | 40 | class GuardedAttributeRole (extends => $::Role) { 41 | method attribute_class { GuardedAttribute } 42 | } 43 | 44 | 1; -------------------------------------------------------------------------------- /t/400-yapc-eu-examples/lib/Throwable.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use mop; 4 | 5 | use Devel::StackTrace; 6 | 7 | role Throwable { 8 | 9 | has $message = 'Error'; 10 | has $stack_trace = Devel::StackTrace->new( 11 | frame_filter => sub { 12 | $_[0]->{'caller'}->[3] !~ /^mop\:\:/ && 13 | $_[0]->{'caller'}->[0] !~ /^mop\:\:/ && 14 | $_[0]->{'caller'}->[3] !~ /^Try\:\:/ && 15 | $_[0]->{'caller'}->[0] !~ /^Try\:\:/ 16 | } 17 | ); 18 | 19 | method message { $message } 20 | method stack_trace { $stack_trace } 21 | method throw { die $self } 22 | 23 | method format_message ( $message ) { "$message" } 24 | method as_string { 25 | $self->format_message( $message ) 26 | . "\n" 27 | . $stack_trace->as_string 28 | } 29 | } 30 | 31 | 1; -------------------------------------------------------------------------------- /t/ext/Class-MOPX/Class/MOPX/Types.pm: -------------------------------------------------------------------------------- 1 | package Class::MOPX::Types; 2 | use strict; 3 | use warnings; 4 | use mop; 5 | 6 | use Scalar::Util 'looks_like_number'; 7 | 8 | class Constraint { 9 | has $name; 10 | 11 | has $constraint; 12 | has $parent; 13 | has $compiled_constraint; 14 | 15 | BUILD { 16 | die "name is required" unless defined $name; 17 | 18 | if ($parent) { 19 | $compiled_constraint //= sub { 20 | $parent->check(@_) && $constraint->(@_) 21 | }; 22 | } 23 | else { 24 | $compiled_constraint //= $constraint; 25 | } 26 | } 27 | 28 | method subtype ($name, $constraint) { 29 | $class->new( 30 | name => $name, 31 | constraint => $constraint, 32 | ); 33 | } 34 | 35 | method check ($val) { 36 | $compiled_constraint->($val); 37 | } 38 | 39 | method validate ($val) { 40 | die "Type constraint $name failed with value $val" 41 | unless $self->check($val); 42 | } 43 | } 44 | 45 | class Registry { 46 | has $constraints; 47 | 48 | BUILD { 49 | $constraints = {}; 50 | $constraints->{Any} = Constraint->new( 51 | name => 'Any', 52 | constraint => sub { 1 } 53 | ); 54 | $constraints->{Undef} = $constraints->{Any}->subtype(Undef => sub { 55 | !defined($_[0]) 56 | }); 57 | $constraints->{Defined} = $constraints->{Any}->subtype(Defined => sub { 58 | defined($_[0]) 59 | }); 60 | $constraints->{Value} = $constraints->{Defined}->subtype(Value => sub { 61 | !ref($_[0]) 62 | }); 63 | $constraints->{Ref} = $constraints->{Defined}->subtype(Ref => sub { 64 | ref($_[0]) 65 | }); 66 | $constraints->{Str} = $constraints->{Value}->subtype(Str => sub { 67 | ref(\$_[0]) eq 'SCALAR' || ref(\(my $val = $_[0])) eq 'SCALAR' 68 | }); 69 | $constraints->{Num} = $constraints->{Str}->subtype(Num => sub { 70 | looks_like_number($_[0]) 71 | }); 72 | $constraints->{Int} = $constraints->{Num}->subtype(Int => sub { 73 | (my $val = $_[0]) =~ /\A-?[0-9]+\z/ 74 | }); 75 | $constraints->{ArrayRef} = $constraints->{Ref}->subtype(ArrayRef => sub { 76 | ref($_[0]) eq 'ARRAY' 77 | }); 78 | $constraints->{HashRef} = $constraints->{Ref}->subtype(HashRef => sub { 79 | ref($_[0]) eq 'HASH' 80 | }); 81 | } 82 | 83 | method type ($name) { 84 | $constraints->{$name} 85 | } 86 | } 87 | 88 | sub import { 89 | my $caller = caller; 90 | my $registry = Registry->new; 91 | { 92 | no strict 'refs'; 93 | *{ $caller . '::T' } = sub () { $registry }; 94 | } 95 | } 96 | 97 | 1; 98 | -------------------------------------------------------------------------------- /t/ext/Test-BuilderX/Test/BuilderX.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use mop; 4 | 5 | use Test::BuilderX::Test; 6 | use Test::BuilderX::Output; 7 | use Test::BuilderX::TestPlan; 8 | 9 | class Test::BuilderX { 10 | 11 | has $output; 12 | has $testplan; 13 | has $results = []; 14 | 15 | BUILD { 16 | $output //= Test::BuilderX::Output->new; 17 | } 18 | 19 | DEMOLISH { 20 | return unless $testplan; 21 | my $footer = $testplan->footer( scalar @$results ); 22 | $output->write( $footer ) if $footer; 23 | } 24 | 25 | method get_test_number { (scalar @$results) + 1 } 26 | 27 | method plan ( $explanation, $tests ) { 28 | die "Plan already set" if $testplan; 29 | 30 | if ( $tests ) { 31 | $testplan = Test::BuilderX::TestPlan->new( expect => $tests ); 32 | } 33 | elsif ( $explanation eq 'no_plan' ) { 34 | $testplan = Test::BuilderX::NullPlan->new; 35 | } 36 | else { 37 | die "Unknown plan"; 38 | } 39 | 40 | $output->write( $testplan->header ); 41 | } 42 | 43 | method ok ( $passed, $description ) { 44 | $self->report_test( 45 | Test::BuilderX::Test->new( 46 | number => $self->get_test_number, 47 | passed => $passed, 48 | description => $description // '' 49 | ) 50 | ); 51 | 52 | return $passed; 53 | } 54 | 55 | method diag ( $diagnostic ) { 56 | $output->diag( $diagnostic // '' ); 57 | } 58 | 59 | method todo ( $passed, $description, $reason ) { 60 | $self->report_test( 61 | Test::BuilderX::Test->new( 62 | todo => 1, 63 | number => $self->get_test_number, 64 | reason => $reason, 65 | description => $description // '' 66 | ) 67 | ); 68 | 69 | return $passed; 70 | } 71 | 72 | method skip ( $num, $reason ) { 73 | for ( 1 .. $num ) { 74 | $self->report_test( 75 | Test::BuilderX::Test->new( 76 | skip => 1, 77 | number => $self->get_test_number, 78 | reason => $reason, 79 | ) 80 | ); 81 | } 82 | } 83 | 84 | method skip_all { 85 | die "Cannot skip_all with a plan" if $testplan; 86 | $output->write( "1..0" ); 87 | exit(0); 88 | } 89 | 90 | method BAILOUT ( $reason ) { 91 | $output->write( "Bail out! $reason" ); 92 | exit(255); 93 | } 94 | 95 | method report_test ( $test ) { 96 | die "No plan set!" unless $testplan; 97 | 98 | push @$results => $test; 99 | $output->write( $test->report ); 100 | } 101 | } 102 | 103 | 1; 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /t/ext/Test-BuilderX/Test/BuilderX/Output.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use mop; 4 | 5 | use IO::Handle; 6 | 7 | class Test::BuilderX::Output { 8 | has $output; 9 | has $error_output; 10 | 11 | BUILD { 12 | $output = IO::Handle->new; 13 | $output->fdopen( fileno( STDOUT ), "w" ); 14 | 15 | $error_output = IO::Handle->new; 16 | $error_output->fdopen( fileno( STDERR ), "w" ); 17 | } 18 | 19 | # XXX - should we add a DEMOLISH 20 | # here to close the file handles? 21 | 22 | method write ( $message ) { 23 | $message =~ s/\n(?!#)/\n# /g; 24 | $output->print( $message, "\n" ); 25 | } 26 | 27 | method diag ( $message ) { 28 | $message =~ s/^(?!#)/# /; 29 | $message =~ s/\n(?!#)/\n# /g; 30 | $output->print( $message, "\n" ); 31 | } 32 | } 33 | 34 | 1; -------------------------------------------------------------------------------- /t/ext/Test-BuilderX/Test/BuilderX/Test.pm: -------------------------------------------------------------------------------- 1 | package Test::BuilderX::Test; 2 | use strict; 3 | use warnings; 4 | use mop; 5 | 6 | role Base { 7 | 8 | has $passed; 9 | has $number = 0; 10 | has $diagnostic = '???'; 11 | has $description; 12 | 13 | method passed { $passed } 14 | method number { $number } 15 | method description { $description } 16 | 17 | method status { 18 | return +{ passed => $passed, description => $description } 19 | } 20 | 21 | method report { 22 | my $ok = $passed ? 'ok ' : 'not ok '; 23 | $ok .= $number; 24 | $ok .= " - $description" if $description; 25 | return $ok; 26 | } 27 | } 28 | 29 | class Pass ( with => [Base] ) {} 30 | class Fail ( with => [Base] ) {} 31 | 32 | role WithReason ( with => [Base] ) { 33 | has $reason; 34 | 35 | method reason { $reason } 36 | 37 | method status { 38 | # FIXME 39 | my $status = Base->find_method('status')->execute( $self ); 40 | $status->{'reason'} = $reason; 41 | $status; 42 | } 43 | } 44 | 45 | class Skip ( with => [WithReason] ) { 46 | 47 | method report { 48 | return "not ok " . $self->number . " #skip " . $self->reason; 49 | } 50 | 51 | method status { 52 | # FIXME 53 | my $status = WithReason->find_method('status')->execute( $self ); 54 | $status->{'skip'} = 1; 55 | $status; 56 | } 57 | } 58 | 59 | class TODO ( with => [WithReason] ) { 60 | 61 | method report { 62 | my $ok = $self->passed ? 'ok' : 'not ok'; 63 | my $description = "# TODO " . $self->description; 64 | return join ' ' => ( $ok, $self->number, $description ); 65 | } 66 | 67 | method status { 68 | # FIXME 69 | my $status = WithReason->find_method('status')->execute( $self ); 70 | $status->{'TODO'} = 1; 71 | $status->{'passed'} = 1; 72 | $status->{'really_passed'} = $self->passed; 73 | $status; 74 | } 75 | } 76 | 77 | sub new { 78 | shift; 79 | my %params = @_; 80 | my ($number, $passed, $skip, $todo, $reason, $description) = @params{qw[ 81 | number 82 | passed 83 | skip 84 | todo 85 | reason 86 | description 87 | ]}; 88 | 89 | return TODO->new( 90 | description => $description, 91 | passed => $passed, 92 | reason => $reason, 93 | number => $number, 94 | ) if $todo; 95 | 96 | return Skip->new( 97 | description => $description, 98 | passed => 1, 99 | reason => $reason, 100 | number => $number, 101 | ) if $skip; 102 | 103 | return Pass->new( 104 | description => $description, 105 | passed => 1, 106 | number => $number, 107 | ) if $passed; 108 | 109 | return Fail->new( 110 | description => $description, 111 | passed => 0, 112 | number => $number, 113 | ); 114 | } 115 | 116 | 1; 117 | 118 | -------------------------------------------------------------------------------- /t/ext/Test-BuilderX/Test/BuilderX/TestPlan.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use mop; 4 | 5 | class Test::BuilderX::TestPlan { 6 | has $expect; 7 | 8 | BUILD { 9 | die "Invalid or missing plan" unless defined $expect; 10 | } 11 | 12 | method header { "1..$expect" } 13 | 14 | method footer ( $run ) { 15 | return '' if $run == $expect; 16 | return "Expected $expect but ran $run"; 17 | } 18 | } 19 | 20 | class Test::BuilderX::NullPlan { 21 | method header { '' } 22 | method footer ( $run ) { "1..$run" } 23 | } 24 | 25 | 1; -------------------------------------------------------------------------------- /t/ext/Test-BuilderX/Test/BuilderX/Tester.pm: -------------------------------------------------------------------------------- 1 | package Test::BuilderX::Tester; 2 | 3 | use strict; 4 | use warnings; 5 | use mop; 6 | 7 | use Test::BuilderX; 8 | use Test::BuilderX::Output; 9 | 10 | sub import { 11 | my $to = caller; 12 | my $from = shift; 13 | { 14 | no strict 'refs'; 15 | map { 16 | *{"${to}::${_}"} = \&{"${from}::${_}"}; 17 | } qw[ 18 | test_plan 19 | test_pass 20 | test_fail 21 | test_out 22 | test_err 23 | test_diag 24 | test_test 25 | ]; 26 | } 27 | } 28 | 29 | 30 | class MockOutput { 31 | has $output = []; 32 | has $diagnostics = []; 33 | 34 | method write ( $message ) { 35 | push @$output => $message; 36 | } 37 | 38 | method diag ( $message ) { 39 | push @$diagnostics => $message; 40 | } 41 | 42 | method output { 43 | return '' unless @$output; 44 | my $result = join "\n" => @$output; 45 | $output = []; 46 | return $result; 47 | } 48 | 49 | method diagnostics { 50 | return '' unless @$diagnostics; 51 | my $result = join "\n" => @$diagnostics; 52 | $diagnostics = []; 53 | return $result; 54 | } 55 | } 56 | 57 | my @expect_out; 58 | my @expect_diag; 59 | 60 | my $Test = Test::BuilderX->new; 61 | my $TB_Test_Output = MockOutput->new; 62 | my $TB_Test = Test::BuilderX->new( output => $TB_Test_Output ); 63 | 64 | $TB_Test->plan( 'no_plan' ); 65 | $TB_Test_Output->output; # flush this 66 | 67 | sub test_plan { 68 | my ($tests) = @_; 69 | $Test->plan( tests => $tests ); 70 | } 71 | 72 | sub test_pass { 73 | my ($diagnostic) = @_; 74 | report_test( 'ok', $diagnostic ); 75 | } 76 | 77 | sub test_fail { 78 | my ($diagnostic) = @_; 79 | report_test( 'not ok', $diagnostic ); 80 | } 81 | 82 | sub report_test { 83 | my ($type, $diagnostic) = @_; 84 | my $number = $TB_Test->get_test_number; 85 | my $line = "$type $number"; 86 | $line .= " - $diagnostic" if defined $diagnostic; 87 | test_out( $line ); 88 | } 89 | 90 | sub test_out { 91 | my ($line) = @_; 92 | push @expect_out => $line; 93 | } 94 | 95 | sub test_err { 96 | my ($line) = @_; 97 | push @expect_diag => $line; 98 | } 99 | 100 | sub test_diag { 101 | my ($line) = @_; 102 | push @expect_diag => $line; 103 | } 104 | 105 | sub test_test { 106 | my ($description) = @_; 107 | 108 | my $expect_out = join "\n" => @expect_out; 109 | my $expect_diag = join "\n" => @expect_diag; 110 | @expect_out = (); 111 | @expect_diag = (); 112 | 113 | my $received_out = $TB_Test_Output->output; 114 | my $received_diag = $TB_Test_Output->diagnostics; 115 | 116 | my $out_matches = $expect_out eq $received_out; 117 | my $diag_matches = $expect_diag eq $received_diag; 118 | 119 | return 1 if $Test->ok( ($out_matches && $diag_matches), $description ); 120 | 121 | $Test->diag( 122 | "output mismatch\nexpected: $expect_out\nreceived: $received_out\n" 123 | ) unless $out_matches; 124 | 125 | $Test->diag( 126 | "diagnostics mismatch\n" . 127 | "expected: '$expect_diag'\nreceived: '$received_diag'\n" 128 | ) unless $diag_matches; 129 | 130 | return 0; 131 | } 132 | 133 | 1; -------------------------------------------------------------------------------- /t/ext/explicit-override/explicit/override.pm: -------------------------------------------------------------------------------- 1 | package explicit::override; 2 | use strict; 3 | use warnings; 4 | 5 | use mop; 6 | use List::MoreUtils 'any'; 7 | 8 | class ExplicitOverride (extends => $::Class) { 9 | method add_method ($method, $override) { 10 | die "Overriding method " . $method->get_name . " without using override" 11 | if !$override && $self->find_method($method->get_name); 12 | super($method); 13 | } 14 | 15 | method override_method ($method) { 16 | $self->add_method($method, 1); 17 | } 18 | } 19 | 20 | # XXX add method parser for this 21 | sub override ($&) { 22 | my ($name, $sub) = @_; 23 | $::CLASS->add_method( 24 | $::CLASS->method_class->new( 25 | name => $name, body => $sub 26 | ), 27 | 1 28 | ) 29 | } 30 | 31 | sub import { 32 | my $caller = caller; 33 | mop->import(-metaclass => ExplicitOverride); 34 | no strict 'refs'; 35 | *{ $caller . '::override'} = \&override; 36 | } 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /t/ext/mopx-instance-tracking/mopx/instance/tracking.pm: -------------------------------------------------------------------------------- 1 | package mopx::instance::tracking; 2 | use strict; 3 | use warnings; 4 | 5 | use mop; 6 | use Set::Object::Weak 'weak_set'; 7 | 8 | class InstanceTracking (extends => $::Class) { 9 | has $instances = weak_set(); 10 | 11 | method instances { return $instances->members } 12 | 13 | # ->subclasses doesn't work yet 14 | # method get_all_instances { return map { $_->instances } $self, $self->subclasses } 15 | 16 | method _track_instance ($instance) { 17 | $instances->insert($instance); 18 | } 19 | 20 | method _untrack_instance ($instance) { 21 | $instances->remove($instance); 22 | } 23 | 24 | method create_instance ($params) { 25 | my $instance = super($params); 26 | $self->_track_instance($instance); 27 | return $instance; 28 | } 29 | } 30 | 31 | sub import { 32 | my $caller = caller; 33 | mop->import(-metaclass => InstanceTracking); 34 | } 35 | 36 | 1; 37 | 38 | -------------------------------------------------------------------------------- /t/lib/Foo.pm: -------------------------------------------------------------------------------- 1 | package Foo; 2 | use strict; 3 | use warnings; 4 | 5 | 1; -------------------------------------------------------------------------------- /t/lib/Foo/Bar.pm: -------------------------------------------------------------------------------- 1 | # NOTE: 2 | # the following 3 lines 3 | # shouldn't be neccessary 4 | # and really should be 5 | # implied. 6 | # - SL 7 | use strict; 8 | use warnings; 9 | use mop; 10 | 11 | class Foo::Bar {} 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /xt/author/leaks.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use 5.014; 5 | use Test::More; 6 | BEGIN { 7 | eval { require Test::LeakTrace; 1 } 8 | or plan skip_all => "This test requires Test::LeakTrace"; 9 | Test::LeakTrace->import; 10 | } 11 | 12 | use mop; 13 | 14 | local $TODO = "we're pretty leaky"; 15 | 16 | no_leaks_ok { 17 | local $SIG{__WARN__} = sub { 18 | return if $_[0] =~ /Constant subroutine main::Foo redefined/; 19 | warn $_[0]; 20 | }; 21 | eval <