Skip to content
Browse files

improve syntax stuff and add more tests

  • Loading branch information...
1 parent de16d60 commit 6095227c0686ddd4f9ff2e515cfaf23333d1f160 Stevan Little committed Jun 19, 2013
Showing with 214 additions and 21 deletions.
  1. +116 −21 lib/mop/internals/syntax.pm
  2. +16 −0 t/001-basic.t
  3. +82 −0 t/100-point.t
View
137 lib/mop/internals/syntax.pm
@@ -5,16 +5,19 @@ use warnings;
use base 'Devel::Declare::Context::Simple';
-use Sub::Name ();
-use Devel::Declare ();
+use Sub::Name ();
+use Devel::Declare ();
+use Hash::Util::FieldHash ();
+use Variable::Magic ();
use B::Hooks::EndOfScope;
sub setup_for {
my $class = shift;
my $pkg = shift;
{
no strict 'refs';
- *{ $pkg . '::class' } = sub (&@) {};
+ *{ $pkg . '::class' } = sub (&@) {};
+ *{ $pkg . '::has' } = sub ($@) {};
*{ $pkg . '::method' } = sub (&) {};
*{ $pkg . '::submethod' } = sub (&) {};
}
@@ -24,12 +27,16 @@ sub setup_for {
$pkg,
{
'class' => { const => sub { $context->class_parser( @_ ) } },
+ 'has' => { const => sub { $context->attribute_parser( @_ ) } },
'method' => { const => sub { $context->method_parser( @_ ) } },
'submethod' => { const => sub { $context->submethod_parser( @_ ) } },
}
);
}
+my $CLASS;
+my @ATTRIBUTES;
+
sub class_parser {
my $self = shift;
@@ -42,33 +49,40 @@ sub class_parser {
my $caller = $self->get_curstash_name;
my $pkg = ($caller eq 'main' ? $name : (join "::" => $caller, $name));
- my $inject = $self->scope_injector_call
- . 'my $d = shift;'
- . 'eval("package ' . $pkg . '; use strict; use warnings; our \$META; our \@ISA");'
- . 'mro::set_mro("' . $pkg . '", "mop");'
- . '$d->{"class"} = ' . __PACKAGE__ . '->build_class('
- . 'name => "' . $pkg . '"'
- . ($proto ? (', ' . $proto) : '')
- . ');'
- . 'local $::CLASS = $d->{"class"};'
- . '{'
- . 'no warnings "once";'
- . '$' . $pkg . '::META = $d->{"class"};'
- . '}'
- ;
+ $CLASS = $pkg;
+
+ my (@PLAN, @EVAL);
+ push @EVAL => 'package ' . $pkg .';';
+ push @EVAL => 'use strict;';
+ push @EVAL => 'use warnings;';
+
+ push @PLAN => 'eval(q[' . (join '' => @EVAL) . ']);';
+ push @PLAN => 'mro::set_mro(q[' . $pkg . '], q[mop]);';
+ push @PLAN => '$' . $pkg . '::__WIZARD__ = Variable::Magic::wizard('
+ . 'data => sub { $_[1] },'
+ . 'set => sub { $_[1]->[0]->{ $_[1]->[1] } = $_[0] },'
+ . ');';
+ push @PLAN => '$' . $pkg . '::__META__ = ' . __PACKAGE__ . '->build_class('
+ . 'name => q[' . $pkg . ']'
+ . ($proto ? (', ' . $proto) : '')
+ . ');';
+ push @PLAN => 'local $::CLASS = $' . $pkg . '::__META__;';
+
+ my $inject = $self->scope_injector_call . join "" => @PLAN;
+
$self->inject_if_block( $inject );
$self->shadow(sub (&@) {
my $body = shift;
- my $data = {};
- $body->( $data );
-
- #use Data::Dumper 'Dumper'; warn Dumper( $data->{'class'} );
+ $body->();
return;
});
+ #$CLASS = undef;
+ @ATTRIBUTES = ();
+
return;
}
@@ -111,6 +125,12 @@ sub generic_method_parser {
else {
$inject .= 'my ($self) = @_;';
}
+
+ foreach my $attr (@ATTRIBUTES) {
+ my $key_name = substr( $attr, 1, length $attr );
+ $inject .= 'my ' . $attr . ' = ${ ' . $attr . '{$self} || \(undef) };';
+ $inject .= 'Variable::Magic::cast(' . $attr . ', $' . $CLASS . '::__WIZARD__, [ \%' . $key_name . ', $self ]);';
+ }
$self->inject_if_block( $inject );
$self->shadow($callback->($name));
@@ -150,6 +170,81 @@ sub submethod_parser {
}, @_);
}
+sub attribute_parser {
+ my $self = shift;
+
+ $self->init( @_ );
+
+ $self->skip_declarator;
+ $self->skipspace;
+
+ my $name;
+
+ my $linestr = $self->get_linestr;
+ if ( substr( $linestr, $self->offset, 1 ) eq '$' ) {
+ my $length = Devel::Declare::toke_scan_ident( $self->offset );
+ $name = substr( $linestr, $self->offset, $length );
+
+ my $full_length = $length;
+ my $old_offset = $self->offset;
+
+ $self->inc_offset( $length );
+ $self->skipspace;
+
+ my $proto;
+ if ( substr( $linestr, $self->offset, 1 ) eq '(' ) {
+ my $length = Devel::Declare::toke_scan_str( $self->offset );
+ $proto = Devel::Declare::get_lex_stuff();
+ $full_length += $length;
+ Devel::Declare::clear_lex_stuff();
+ $self->inc_offset( $length );
+ }
+
+ $self->skipspace;
+ if ( substr( $linestr, $self->offset, 1 ) eq '=' ) {
+ $self->inc_offset( 1 );
+ $self->skipspace;
+ if ( substr( $linestr, $self->offset, 2 ) eq 'do' ) {
+ substr( $linestr, $self->offset, 2 ) = 'sub';
+ }
+ }
+
+ substr( $linestr, $old_offset, $full_length ) = '(q[' . $name . '])' . ( $proto ? (', (' . $proto) : '');
+
+ my $key_name = substr( $name, 1, length $name );
+ my $fieldhash = 'Hash::Util::FieldHash::fieldhash(my %' . $key_name . ');';
+ $full_length += length($fieldhash);
+
+ substr( $linestr, length($linestr) - 1, $full_length ) = $fieldhash;
+
+ $self->set_linestr( $linestr );
+ $self->inc_offset( $full_length );
+ }
+
+ push @ATTRIBUTES => $name;
+
+ $self->shadow(sub ($@) : lvalue {
+ shift;
+ my %metadata = @_;
+ my $initial_value;
+ $::CLASS->add_attribute(
+ mop::attribute->new(
+ name => $name,
+ default => sub { $initial_value },
+ )
+ );
+ $initial_value
+ });
+
+ return;
+}
+
+sub scope_injector_call {
+ my $self = shift;
+ my $inject = shift || '';
+ return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
+}
+
sub inject_scope {
my $class = shift;
my $inject = shift || ';';
View
16 t/001-basic.t
@@ -9,11 +9,20 @@ use Test::Fatal;
use mop;
class Foo {
+
+ has $foo;
+ has $bar;
+
method bar { 'Foo::bar' }
method baz ($x) {
join "::" => $self, 'baz', $x
}
+
+ method test ($x) {
+ $foo = $x if $x;
+ $foo;
+ }
}
is(Foo->bar, 'Foo::bar', '... simple test works');
@@ -25,4 +34,11 @@ isa_ok($foo, 'Foo');
is($foo->bar, 'Foo::bar', '... simple test works');
is($foo->baz('hi'), $foo . '::baz::hi', '... another test works');
+warn $foo->test(10);
+warn $foo->test;
+warn $foo->test(20);
+warn $foo->test;
+warn $foo->test([ 1, 2, 3 ]);
+warn $foo->test;
+
done_testing;
View
82 t/100-point.t
@@ -0,0 +1,82 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use mop;
+
+class Point {
+ has $x;
+ has $y;
+
+ method x { $x }
+ method y { $y }
+
+ method set_x ($new_x) {
+ $x = $new_x;
+ }
+
+ method set_y ($new_y) {
+ $y = $new_y;
+ }
+
+ method clear {
+ ($x, $y) = (0, 0);
+ }
+
+ method dump {
+ +{ x => $self->x, y => $self->y }
+ }
+}
+
+# ... subclass it ...
+
+class Point3D (extends => 'Point') {
+ has $z;
+
+ method z { $z }
+
+ method set_z ($new_z) {
+ $z = $new_z;
+ }
+
+ method dump {
+ +{ x => $self->x, y => $self->y, z => $self->z }
+ }
+}
+
+## Test an instance
+
+my $p = Point->new;
+isa_ok($p, 'Point');
+
+$p->set_x(10);
+is $p->x, 10, '... got the right value for x';
+
+$p->set_y(320);
+is $p->y, 320, '... got the right value for y';
+
+is_deeply $p->dump, { x => 10, y => 320 }, '... got the right value from dump';
+
+## Test the instance
+
+my $p3d = Point3D->new();
+isa_ok($p3d, 'Point3D');
+
+$p3d->set_x(10);
+is $p3d->x, 10, '... got the right value for x';
+
+$p3d->set_y(320);
+is $p3d->y, 320, '... got the right value for y';
+
+$p3d->set_z(30);
+is $p3d->z, 30, '... got the right value for z';
+
+is_deeply $p3d->dump, { x => 10, y => 320, z => 30 }, '... got the right value from dump';
+
+done_testing;
+
+
+

0 comments on commit 6095227

Please sign in to comment.
Something went wrong with that request. Please try again.