Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
add support for native objects
  • Loading branch information
ingydotnet committed Mar 21, 2013
1 parent a233804 commit c260d09
Show file tree
Hide file tree
Showing 5 changed files with 41 additions and 59 deletions.
72 changes: 26 additions & 46 deletions lib/TestML/Runtime.pm
Expand Up @@ -21,16 +21,12 @@ sub BUILD {

sub run {
my ($self) = @_;

$self->compile_testml;
$self->initialize_runtime;

$self->run_function(
$self->{function}, # top level testml function
[], # function arguments
);
$self->run_function($self->{function}, []);
}

# TODO Functions should have return values
sub run_function {
my ($self, $function, $args) = @_;

Expand All @@ -48,7 +44,7 @@ sub run_function {
}
}
$self->{function} = $parent;
return TestML::None->new;
return;
}

sub apply_signature {
Expand Down Expand Up @@ -148,17 +144,24 @@ sub run_call {
my $callable =
$self->function->getvar($name) ||
$self->get_point($name) ||
$self->lookup_callable($name)
or die "Can't locate '$name' callable";
$self->lookup_callable($name) ||
die "Can't locate '$name' callable";
if ($callable->isa('TestML::Object')) {
return $callable;
}
return $callable unless $call->args or defined $context;
$call->{args} ||= [];
my $args = [map $self->run_expression($_), @{$call->args}];
unshift @$args, $context if $context;
if ($callable->isa('TestML::Native')) {
return $self->run_native($callable, $args);
if ($callable->isa('TestML::Callable')) {
my $value = eval { $callable->value->(@$args) };
if ($@) {
$self->{error} = $@;
return TestML::Error->new(value => $@);
}
die "'$name' did not return a TestML::Object object"
unless UNIVERSAL::isa($value, 'TestML::Object');
return $value;
}
if ($callable->isa('TestML::Function')) {
return $self->run_function($callable, $args);
Expand All @@ -173,7 +176,7 @@ sub lookup_callable {
for my $library (@{$self->function->getvar('Library')->value}) {
if ($library->can($name)) {
my $function = sub { $library->$name(@_) };
my $callable = TestML::Native->new(value => $function);
my $callable = TestML::Callable->new(value => $function);
$self->function->setvar($name, $callable);
return $callable;
}
Expand All @@ -191,23 +194,6 @@ sub get_point {
return TestML::Str->new(value => $value);
}

sub run_native {
my ($self, $native, $args) = @_;
my $value = eval {
$native->value->(@$args)
};
if ($@) {
$self->{error} = $@;
return TestML::None->new;
}
elsif (UNIVERSAL::isa($value, 'TestML::Object')) {
return $value;
}
else {
return $self->object_from_native($value);
}
}

sub select_blocks {
my ($self, $wanted) = @_;
return [1] unless @$wanted;
Expand All @@ -229,18 +215,6 @@ sub select_blocks {
return $selected;
}

sub object_from_native {
my ($self, $value) = @_;
return
not(defined $value) ? TestML::None->new :
ref($value) eq 'ARRAY' ? TestML::List->new(value => $value) :
$value =~ /^-?\d+$/ ? TestML::Num->new(value => $value + 0) :
"$value" eq "$TestML::Constant::True" ? $value :
"$value" eq "$TestML::Constant::False" ? $value :
"$value" eq "$TestML::Constant::None" ? $value :
TestML::Str->new(value => $value);
}

sub compile_testml {
my ($self) = @_;

Expand Down Expand Up @@ -282,9 +256,10 @@ sub initialize_runtime {

sub get_label {
my ($self) = @_;
my $label = $self->function->getvar('Label')->value;
my $label = $self->function->getvar('Label') or return;
$label = $label->value or return;
$label =~ s/\$(\w+)/$self->replace_label($1)/ge;
return $label ? ($label) : ();
return $label;
}

sub replace_label {
Expand Down Expand Up @@ -379,6 +354,11 @@ use TestML::Base;
has name => ();
has args => ();

#-----------------------------------------------------------------------------
package TestML::Callable;
use TestML::Base;
has value => ();

#-----------------------------------------------------------------------------
package TestML::Block;
use TestML::Base;
Expand Down Expand Up @@ -469,14 +449,14 @@ sub bool { $TestML::Constant::False }
sub list { TestML::List->new(value => []) }

#-----------------------------------------------------------------------------
package TestML::Error;
package TestML::Native;
use TestML::Base;
extends 'TestML::Object';

#-----------------------------------------------------------------------------
package TestML::Native;
package TestML::Error;
use TestML::Base;
has value => ();
extends 'TestML::Object';

#-----------------------------------------------------------------------------
package TestML::Constant;
Expand Down
18 changes: 9 additions & 9 deletions lib/TestML/Runtime/TAP.pm
Expand Up @@ -5,7 +5,7 @@ package TestML::Runtime::TAP;
use TestML::Base;
extends 'TestML::Runtime';

has native_test => sub { Test::Builder->new };
has test_framework => sub { Test::Builder->new };
has planned => 0;

sub run {
Expand Down Expand Up @@ -35,31 +35,31 @@ sub title {
if (my $title = $self->function->getvar('Title')) {
$title = $title->value;
$title = "=== $title ===\n";
$self->native_test->note($title);
$self->test_framework->note($title);
}
}

sub skip_test {
my ($self, $reason) = @_;
$self->native_test->plan(skip_all => $reason);
$self->test_framework->plan(skip_all => $reason);
}

sub plan_begin {
my ($self) = @_;
if (my $tests = $self->function->getvar('Plan')) {
$self->native_test->plan(tests => $tests->value);
$self->test_framework->plan(tests => $tests->value);
}
}

sub plan_end {
my ($self) = @_;
$self->native_test->done_testing();
$self->test_framework->done_testing();
}

# TODO Use Test::Diff here.
sub assert_EQ {
my ($self, $got, $want) = @_;
$self->native_test->is_eq(
$self->test_framework->is_eq(
$got->str->value,
$want->str->value,
$self->get_label,
Expand All @@ -78,14 +78,14 @@ Failed TestML HAS (~~) assertion. This text:
does not contain this string:
'$has'
...
$self->native_test->diag($msg);
$self->test_framework->diag($msg);
}
$self->native_test->ok($assertion, $self->get_label);
$self->test_framework->ok($assertion, $self->get_label);
}

sub assert_OK {
my ($self, $got) = @_;
$self->native_test->ok(
$self->test_framework->ok(
$got->bool->value,
$self->get_label,
);
Expand Down
5 changes: 3 additions & 2 deletions lib/TestML/Util.pm
Expand Up @@ -5,12 +5,13 @@ use TestML::Runtime;
package TestML::Util;

use Exporter 'import';
our @EXPORT = qw( str num bool none list );
our @EXPORT = qw( list str num bool none native );

sub list { TestML::List->new(value => $_[0]) }
sub str { TestML::Str->new(value => $_[0]) }
sub num { TestML::Num->new(value => $_[0]) }
sub bool { TestML::Bool->new(value => $_[0]) }
sub none { TestML::None->new(value => $_[0]) }
sub list { TestML::List->new(value => $_[0]) }
sub native { TestML::Native->new(value => $_[0]) }

1;
2 changes: 1 addition & 1 deletion notes/ToDo
Expand Up @@ -48,7 +48,7 @@
- Add a standard call for data parse

- Allow quotes for line points
- Support Native objects
+ Support Native objects

== Runtime
- Run the 'plan' right away (not as a side-effect of the first test)
Expand Down
3 changes: 2 additions & 1 deletion t/inline-bridge.t
@@ -1,9 +1,10 @@
use TestML;
use TestML::Util;
TestML->new->run;

sub upper {
my ($self, $string) = @_;
return uc($string->value);
return str uc($string->value);
}

__DATA__
Expand Down

0 comments on commit c260d09

Please sign in to comment.