#!/usr/bin/perl use strict; use warnings; use Test::More tests => 60; use Test::Exception; use Perl6::MetaModel; =pod This example is not yet complete, it is meant to showcase some Role capability, but I need to get Roles totally working first. However I hate not having things in version control, so i am commiting this. =cut # Roles my $Shape = role 'Shape' => { methods => { 'area' => sub {}, } }; my $Shape3D = role 'Shape3D' => { does => [ $Shape ], methods => { 'volume' => sub {}, } }; # Classes my $Square = class 'Square' => { is => [ $::Object ], does => [ $Shape ], attributes => [ '$.length' ], methods => { 'area' => sub { _('$.length') ** 2 }, 'perimeter' => sub { _('$.length') * 4 }, 'length' => sub { shift; _('$.length' => shift) if @_; _('$.length'); } } }; my $Square3D = class 'Square3D' => { is => [ $Square ], does => [ $Shape3D ], methods => { 'volume' => sub { _('$.length') ** 3 }, 'area' => sub { ::next_METHOD() * 6 } } }; my $Rectangle = class 'Rectangle' => { is => [ $Square ], does => [ $Shape ], attributes => [ '$.height' ], methods => { 'area' => sub { _('$.height') * _('$.length') }, 'perimeter' => sub { (_('$.length') * 2) + (_('$.height') * 2) }, 'height' => sub { shift; _('$.height' => shift) if @_; _('$.height'); }, } }; my $Rectangle3D = class 'Rectangle3D' => { is => [ $Rectangle ], does => [ $Shape3D ], attributes => [ '$.width' ], methods => { 'volume' => sub { ((_('$.height') * _('$.length')) * 2) + ((_('$.height') * _('$.width')) * 2) + ((_('$.width') * _('$.length')) * 2) }, 'area' => sub { (_('$.width') * ::next_METHOD()) }, 'width' => sub { shift; _('$.width' => shift) if @_; _('$.width'); } } }; my $Circle = class 'Circle' => { is => [ $::Object ], does => [ $Shape ], attributes => [ '$.radius' ], methods => { 'area' => sub { $::CLASS->FETCH('$.PI') * (_('$.radius') ** 2) }, 'diameter' => sub { _('$.radius') * 2 }, 'circumference' => sub { $::CLASS->FETCH('$.PI') * $::SELF->diameter }, 'radius' => sub { shift; _('$.radius' => shift) if @_; _('$.radius'); } } }; $Circle->STORE('$.PI' => 3.14159); my $Circle3D = class 'Circle3D' => { is => [ $Circle ], does => [ $Shape3D ], methods => { 'volume' => sub { (4 / 3) * $Circle->FETCH('$.PI') * (_('$.radius') ** 3) }, 'area' => sub { 4 * ::next_METHOD() }, } }; { ok($Rectangle->does('Shape'), '... the Rectangle class does Shape'); ok($Rectangle3D->does('Shape'), '... the Rectangle3D class does Shape'); ok($Rectangle3D->does('Shape3D'), '... the Rectangle3D class does Shape3D'); ok($Square->does('Shape'), '... the Square class does Shape'); ok($Square3D->does('Shape'), '... the Square3D class does Shape'); ok($Square3D->does('Shape3D'), '... the Square3D class does Shape3D'); ok($Circle->does('Shape'), '... the Circle class does Shape'); ok($Circle3D->does('Shape'), '... the Circle3D class does Shape'); ok($Circle3D->does('Shape3D'), '... the Circle3D class does Shape3D'); } { my $rect = $Rectangle->new('$.height' => 10, '$.length' => 10); isa_ok($rect, 'Rectangle'); ok($rect->does('Shape'), '... the rectangle does Shape'); is($rect->height, 10, '... got the right height'); is($rect->length, 10, '... got the right length'); is($rect->area, 100, '... got the right area'); is($rect->perimeter, 40, '... got the right area'); $rect->height(5); is($rect->height, 5, '... got the right height'); is($rect->area, 50, '... got the right area'); is($rect->perimeter, 30, '... got the right area'); $rect->length(2); is($rect->length, 2, '... got the right length'); is($rect->area, 10, '... got the right area'); is($rect->perimeter, 14, '... got the right area'); } { my $rect3D = $Rectangle3D->new('$.height' => 4, '$.length' => 8, '$.width' => 3); isa_ok($rect3D, 'Rectangle3D'); ok($rect3D->does('Shape'), '... the rectangle does Shape'); ok($rect3D->does('Shape3D'), '... the rectangle does Shape3D'); is($rect3D->length, 8, '... got the right length'); is($rect3D->height, 4, '... got the right height'); is($rect3D->width, 3, '... got the right width'); is($rect3D->volume, 136, '... got the right volume'); is($rect3D->area, 96, '... got the right area'); } { my $square = $Square->new('$.length' => 10); isa_ok($square, 'Square'); ok($square->does('Shape'), '... the square does Shape'); is($square->length, 10, '... got the right length'); is($square->area, 100, '... got the right area'); is($square->perimeter, 40, '... got the right area'); $square->length(5); is($square->length, 5, '... got the right length'); is($square->area, 25, '... got the right area'); is($square->perimeter, 20, '... got the right area'); } { my $square3D = $Square3D->new('$.length' => 2.1); isa_ok($square3D, 'Square3D'); ok($square3D->does('Shape'), '... the square does Shape'); ok($square3D->does('Shape3D'), '... the square does Shape3D'); is($square3D->length, 2.1, '... got the right length'); is($square3D->area, 26.46, '... got the right area'); is($square3D->volume, 9.261, '... got the right volume'); $square3D->length(5); is($square3D->length, 5, '... got the right length'); is($square3D->area, 150, '... got the right area'); is($square3D->volume, 125, '... got the right volume'); } { my $circle = $Circle->new('$.radius' => 4.2); isa_ok($circle, 'Circle'); ok($circle->does('Shape'), '... the circle does Shape'); is($circle->radius, 4.2, '... got the right radius'); is($circle->diameter, 8.4, '... got the right diameter'); is($circle->circumference, 26.389356, '... got the right circumference'); is($circle->area, 55.4176476, '... got the right area'); } { my $circle3D = $Circle3D->new('$.radius' => 4); isa_ok($circle3D, 'Circle3D'); ok($circle3D->does('Shape'), '... the circle does Shape'); ok($circle3D->does('Shape3D'), '... the circle does Shape3D'); is($circle3D->radius, 4, '... got the right radius'); is($circle3D->diameter, 8, '... got the right diameter'); is($circle3D->circumference, 25.13272, '... got the right circumference'); is($circle3D->area, 201.06176, '... got the right area'); is($circle3D->volume, 268.082346666667, '... got the right volume'); }