t/050_scala_style_mixin_composition.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 BEGIN {
   9     eval "use SUPER 1.10";
  10     plan skip_all => "SUPER 1.10 required for this test" if $@;
  11     plan tests => 4;
  12 }
  13
  14 =pod
  15
  16 This test demonstrates how simple it is to create Scala Style
  17 Class Mixin Composition. Below is an example taken from the
  18 Scala web site's example section, and trancoded to Class::MOP.
  19
  20 NOTE:
  21 We require SUPER for this test to handle the issue with SUPER::
  22 being determined at compile time.
  23
  24 L<http://scala.epfl.ch/intro/mixin.html>
  25
  26 A class can only be used as a mixin in the definition of another
  27 class, if this other class extends a subclass of the superclass
  28 of the mixin. Since ColoredPoint3D extends Point3D and Point3D
  29 extends Point2D which is the superclass of ColoredPoint2D, the
  30 code above is well-formed.
  31
  32   class Point2D(xc: Int, yc: Int) {
  33     val x = xc;
  34     val y = yc;
  35     override def toString() = "x = " + x + ", y = " + y;
  36   }
  37
  38   class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) {
  39     val color = c;
  40     def setColor(newCol: String): Unit = color = newCol;
  41     override def toString() = super.toString() + ", col = " + color;
  42   }
  43
  44   class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) {
  45     val z = zc;
  46     override def toString() = super.toString() + ", z = " + z;
  47   }
  48
  49   class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String)
  50         extends Point3D(xc, yc, zc)
  51         with ColoredPoint2D(xc, yc, col);
  52
  53
  54   Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString())
  55
  56   "x = 1, y = 2, z = 3, col = blue"
  57
  58 =cut
  59
  60 use Scalar::Util 'blessed';
  61 use Carp         'confess';
  62
  63 sub ::with ($) {
  64     # fetch the metaclass for the
  65     # caller and the mixin arg
  66     my $metaclass = (caller)->meta;
  67     my $mixin     = (shift)->meta;
  68
  69     # according to Scala, the
  70     # the superclass of our class
  71     # must be a subclass of the
  72     # superclass of the mixin (see above)
  73     my ($super_meta)  = $metaclass->superclasses();
  74     my ($super_mixin) = $mixin->superclasses();
  75     ($super_meta->isa($super_mixin))
  76         || confess "The superclass must extend a subclass of the superclass of the mixin";
  77
  78     # collect all the attributes
  79     # and clone them so they can
  80     # associate with the new class
  81     my @attributes = map {
  82         $mixin->get_attribute($_)->clone()
  83     } $mixin->get_attribute_list;
  84
  85     my %methods = map  {
  86         my $method = $mixin->get_method($_);
  87         # we want to ignore accessors since
  88         # they will be created with the attrs
  89         (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'))
  90             ? () : ($_ => $method)
  91     } $mixin->get_method_list;
  92
  93     # NOTE:
  94     # I assume that locally defined methods
  95     # and attributes get precedence over those
  96     # from the mixin.
  97
  98     # add all the attributes in ....
  99     foreach my $attr (@attributes) {
 100         $metaclass->add_attribute($attr)
 101             unless $metaclass->has_attribute($attr->name);
 102     }
 103
 104     # add all the methods in ....
 105     foreach my $method_name (keys %methods) {
 106         $metaclass->alias_method($method_name => $methods{$method_name})
 107             unless $metaclass->has_method($method_name);
 108     }
 109 }
 110
 111 {
 112     package Point2D;
 113     use metaclass;
 114
 115     Point2D->meta->add_attribute('$x' => (
 116         accessor => 'x',
 117         init_arg => 'x',
 118     ));
 119
 120     Point2D->meta->add_attribute('$y' => (
 121         accessor => 'y',
 122         init_arg => 'y',
 123     ));
 124
 125     sub new {
 126         my $class = shift;
 127         $class->meta->new_object(@_);
 128     }
 129
 130     sub toString {
 131         my $self = shift;
 132         "x = " . $self->x . ", y = " . $self->y;
 133     }
 134
 135     package ColoredPoint2D;
 136     our @ISA = ('Point2D');
 137
 138     ColoredPoint2D->meta->add_attribute('$color' => (
 139         accessor => 'color',
 140         init_arg => 'color',
 141     ));
 142
 143     sub toString {
 144         my $self = shift;
 145         $self->SUPER() . ', col = ' . $self->color;
 146     }
 147
 148     package Point3D;
 149     our @ISA = ('Point2D');
 150
 151     Point3D->meta->add_attribute('$z' => (
 152         accessor => 'z',
 153         init_arg => 'z',
 154     ));
 155
 156     sub toString {
 157         my $self = shift;
 158         $self->SUPER() . ', z = ' . $self->z;
 159     }
 160
 161     package ColoredPoint3D;
 162     our @ISA = ('Point3D');
 163
 164     ::with('ColoredPoint2D');
 165
 166 }
 167
 168 my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue');
 169 isa_ok($colored_point_3d, 'ColoredPoint3D');
 170 isa_ok($colored_point_3d, 'Point3D');
 171 isa_ok($colored_point_3d, 'Point2D');
 172
 173 is($colored_point_3d->toString(),
 174    'x = 1, y = 2, z = 3, col = blue',
 175    '... got the right toString method');
 176
 177