[Bps-public-commit] r17641 - in Lorzy/trunk: t

[clkao at bestpractical.com]

Author: clkao
Date: Thu Jan  8 09:38:44 2009
New Revision: 17641

Added:
   Lorzy/trunk/t/roundtrip.t
Modified:
   Lorzy/trunk/lib/Lorzy/Expression/Symbol.pm

Log:
tests for native object method invocation.

Modified: Lorzy/trunk/lib/Lorzy/Expression/Symbol.pm
==============================================================================
--- Lorzy/trunk/lib/Lorzy/Expression/Symbol.pm	(original)
+++ Lorzy/trunk/lib/Lorzy/Expression/Symbol.pm	Thu Jan  8 09:38:44 2009
@@ -26,7 +26,7 @@
     my $symbol = $self->{'args'}->{'symbol'}->evaluate($eval);
     my $result = $eval->resolve_symbol_name($symbol);
 
-    return ref($result) && $result->meta->does_role('Lorzy::Evaluatable')
+    return ref($result) && $result->can('meta') && $result->meta->does_role('Lorzy::Evaluatable')
          ? $result->evaluate($eval)
          : $result; # XXX: figure out evaluation order here
 }

Added: Lorzy/trunk/t/roundtrip.t
==============================================================================
--- (empty file)
+++ Lorzy/trunk/t/roundtrip.t	Thu Jan  8 09:38:44 2009
@@ -0,0 +1,61 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+use Test::Exception;
+use_ok('Lorzy::Expression');
+use_ok('Lorzy::Evaluator');
+use_ok('Lorzy::Builder');
+use_ok('Lorzy::Lambda::Native');
+
+my $builder = Lorzy::Builder->new();
+my $eval = Lorzy::Evaluator->new();
+
+my $invoke_native = Lorzy::Lambda::Native->new(
+    body => sub {
+        my $args = shift;
+        my $method = $args->{method};
+        die "Invalid 'args' $args->{args}" unless ref($args->{args}) eq 'Lorzy::EvaluatorResult::RunTime';
+        my $nodes = ${$args->{args}};
+
+        $args->{obj}->$method( @$nodes );
+    },
+
+    signature => {
+        'obj' => Lorzy::FunctionArgument->new( name => 'obj'),
+        'method' => Lorzy::FunctionArgument->new( name => 'method', type => 'Str' ),
+        'args' => Lorzy::FunctionArgument->new( name => 'args' ),
+        }
+
+);
+
+$eval->set_global_symbol( 'invoke!' => $invoke_native );
+
+my $script = $builder->defun(
+                             ops => [
+                                     { name => 'ProgN',
+                                       args => {
+                                                nodes => [
+                                                          { name => 'invoke!', args => 
+                                                            { obj => { name => 'Symbol', args => { symbol => 'something' } },
+                                                              method => 'hello',
+                                                              args => { name => 'List', nodes => [ 'orz' ] },
+                                                                                     } },
+                         ],
+                                               } } ],
+                            signature => { something => 
+                                               Lorzy::FunctionArgument->new( name => 'tested-string')});
+
+isa_ok($script, "Lorzy::Lambda");
+my $ret;
+lives_ok {
+    $ret = $eval->apply_script( $script, { 'something' => bless {}, 'TestClass' } );
+};
+is($ret, 'world');
+
+package TestClass;
+
+sub hello {
+    return 'world';
+}