Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: RELEASE_0_8_2
Fetching contributors…

Cannot retrieve contributors at this time

589 lines (443 sloc) 13.78 kb
#! parrot
# Copyright (C) 2007-2008, The Perl Foundation.
# $Id$
=head1 NAME
t/pmc/class.t - test the Class PMC
=head1 SYNOPSIS
% prove t/pmc/class.t
=head1 DESCRIPTION
Tests the Class PMC.
=cut
.const int TESTS = 49
.sub 'main' :main
load_bytecode 'Test/More.pir'
.local pmc exporter, test_ns
test_ns = get_namespace [ 'Test'; 'More' ]
exporter = new 'Exporter'
exporter.'import'( test_ns :named('source'), 'plan ok is isa_ok todo' :named('globals') )
plan(TESTS)
'new op'()
'class flag'()
'name'()
'new method'()
'attributes'()
'add_attribute'()
'set_attr/get_attr'()
# 'add_method'() # TODO not yet implemented
'parents'()
'roles'()
# 'inspect'() # XXX must fix 'attributes' test
'clone'()
'clone_pmc'()
'new with init hash'()
'isa'()
'does'()
'more does'()
.end
# L<PDD15/Class PMC API/=item new>
.sub 'new op'
.local pmc class
.local int isa_class
new class, 'Class'
ok(1, "$P0 = new 'Class'")
isa_ok(class, 'Class')
.end
# L<PDD15/Class PMC API/'Class PMCs also have the "I am a class" flag set on them.'>
.sub 'class flag'
.local pmc class, class_flags_pmc
.local int class_flags, class_flag_set
.const int POBJ_IS_CLASS_FLAG = 536870912 # 1 << 29
new class, 'Class'
class_flags_pmc = inspect class, 'flags'
class_flags = class_flags_pmc
class_flag_set = class_flags & POBJ_IS_CLASS_FLAG
ok(class_flag_set, 'Class PMC has "I am a class" flag set')
.end
# L<PDD15/Class PMC API/=item name>
.sub 'name'
.local pmc class, result
new class, 'Class'
result = class.'name'()
is(result, '', 'name() with no args returns class name, which is empty at first')
class.'name'('Alex')
result = class.'name'()
is(result, 'Alex', 'name() with args sets class name')
$I0 = 1 # hack for testing exceptions
push_eh t_too_many_args
class.'name'('Alice', 'Bob')
$I0 = 0
pop_eh
t_too_many_args:
ok($I0, 'name() with too many args fails')
result = class.'get_namespace'()
is(result, 'Alex', 'name() with args sets namespace too')
.end
# L<PDD15/Class PMC API/=item new>
.sub 'new method'
.local pmc class, result, attrib
.local int isa_object
new class, 'Class'
result = class.'new'()
isa_ok(result, 'Object')
$I0 = 1
push_eh t_non_attribute_key
result = class.'new'('abc' => '123' )
$I0 = 0
pop_eh
t_non_attribute_key:
ok($I0, 'new() with non-attribute key fails')
$I0 = 1
class = new 'Class'
class.'add_attribute'('foo')
class.'add_attribute'('bar')
result = class.'new'('foo' => 1, 'bar' => 2)
attrib = getattribute result, 'foo'
if attrib != 1 goto nok_3
attrib = getattribute result, 'bar'
if attrib != 2 goto nok_3
goto ok_3
nok_3:
$I0 = 0
ok_3:
ok($I0, 'new() with key/value pairs sets attributes')
.end
# L<PDD15/Class PMC API/=item attributes>
.sub 'attributes'
.local pmc class, attribs
.local int test_val
new class, 'Class'
attribs = class.'attributes'()
test_val = isa attribs, 'Hash'
ok(test_val, 'attributes() returns a Hash')
test_val = attribs
is(test_val, 0, 'New Class PMC has no attributes')
$I0 = 1
push_eh ok_ro_accessor
attribs = class.'attributes'( 'foo' )
$I0 = 0
pop_eh
ok_ro_accessor:
ok($I0, 'attributes() is read-only accessor')
.end
# L<PDD15/Class PMC API/=item add_attribute>
.sub 'add_attribute'
.local pmc class, attribs
.local int test_val
new class, 'Class'
$I0 = 1
push_eh t_no_args
class.'add_attribute'()
$I0 = 0
pop_eh
t_no_args:
ok($I0, 'add_attribute() with no args fails')
class.'add_attribute'( 'foo' )
attribs = class.'attributes'()
test_val = attribs
is(test_val, 1, 'add_attribute() with valid single arg adds an attribute')
class.'add_attribute'( 'bar', 'Integer' )
attribs = class.'attributes'()
test_val = attribs
is(test_val, 2, 'add_attribute() with valid args adds an attribute')
$I0 = 1
push_eh t_existing_attribute
class.'add_attribute'( 'foo', 'String' )
$I0 = 0
pop_eh
t_existing_attribute:
ok($I0, 'add_attribute() with existing attribute name fails')
.end
# L<PDD15/Class PMC API>
.sub 'set_attr/get_attr'
.local pmc class, class_instance, attrib_in, attrib_out
new class, 'Class'
class.'name'("Test")
class.'add_attribute'("foo")
ok(1, 'created a class with one attribute')
class_instance = class.'new'()
ok(1, 'instantiated the class')
attrib_in = new 'Integer'
attrib_in = 42
setattribute class_instance, "foo", attrib_in
ok(1, 'set an attribute')
attrib_out = getattribute class_instance, "foo"
is(attrib_out, 42, 'got an attribute')
.end
# L<PDD15/Class PMC API/=item add_method>
.sub 'add_method' # todo => 'not yet implemented'
.local pmc class, attribs, meth_to_add, test_attr_val
.local int test_val
new class, 'Class'
$I0 = 1
push_eh t_no_args
class.'add_method'()
$I0 = 0
pop_eh
t_no_args:
ok($I1, 'add_method() with no args fails')
$I0 = 1
push_eh t_one_arg
class.'add_method'( 'foo' )
$I0 = 0
pop_eh
t_one_arg:
ok($I1, 'add_method() with valid single arg fails')
# note this test depends on 'add_attribute' and 'attributes'
class.'add_attribute'( 'foo', 'String' )
attribs = class.'attributes'()
attribs['foo'] = 'bar'
.const 'Sub' meth_to_add = 'foo'
class.'add_method'( 'foo', meth_to_add )
attribs = class.'methods'()
test_val = attribs
is(test_val, 1, 'add_method() one method added')
test_val = exists attribs['foo']
ok(test_val, 'add_method() method has correct name')
test_val = defined attribs['foo']
ok(test_val, 'add_method() method is defined')
test_attr_val = attribs['foo']
isa_ok(test_attr_val, 'Sub', 'add_method() with valid args adds a method')
.local string test_string_val
test_string_val = class.'foo'()
is(test_string_val, 'bar', 'add_method() invoking method added to class works')
$I0 = 1
push_eh t_existing_method
class.'add_method'( 'foo' )
$I0 = 0
pop_eh
t_existing_method:
ok($I0, 'add_method() with existing method name fails')
.end
.sub 'foo' :method
.return ('foo')
.end
# L<PDD15/Class PMC API/=item parents>
.sub 'parents'
.local pmc class, parents
.local int isa_parent
new class, 'Class'
parents = class.'parents'()
## XXX is this really what's expected?
isa_ok(parents, 'ResizablePMCArray', 'parents() returns a ResizablePMCArray')
.end
## NOTE test that accessor is read-only
## NOTE figure out what parents the base Class has by default (if any)
## A: It has no parents by default. (Note, the parents stored in the 'parents'
# attribute aren't the parents of Class, they're the parents of the class object
# that is an instance of Class.)
## TODO add_parent
# L<PDD15/Class PMC API/=item roles>
.sub 'roles'
.local pmc class, array
.local int is_array
new class, 'Class'
array = class.'roles'()
## XXX is this really what's expected?
isa_ok(array, 'ResizablePMCArray', 'roles() returns a ResizablePMCArray')
.end
## NOTE test that accessor is read-only
## NOTE figure out what roles the base Class has by default (if any)
# A: None. See comment for parents().
## TODO add_role
# L<PDD15/Class PMC API/=item inspect>
.sub 'inspect'
.local pmc class, result
.local int test_val
class = new 'Class'
class.'name'('foo')
class.'add_attribute'('a')
result = class.'inspect'()
ok(1, 'inspect() with no args called returns successfully')
test_val = elements result
is(test_val, 6, 'inspect() returns correctly sized value')
result = class.'inspect'('name')
is(result, 'foo', 'inspect() "name" param returns expected value')
result = class.'inspect'('attributes')
test_val = elements result
is(test_val, 1, 'inspect() "attributes" param returns correctly sized value')
.end
# TODO more tests
.sub 'clone'
.local pmc attrs, class, class_instance, test_pmc
.local string test_name
.local int test_val
attrs = new 'Hash'
attrs['name'] = 'Monkey'
class = new 'Class', attrs
class.'add_attribute'('banana')
class_instance = class.'new'()
ok(1, 'clone() created class Monkey and instantiated it')
class_instance = clone class
ok(1, 'cloned class Monkey')
test_name = class_instance.'inspect'('name')
is(test_name, '', 'clone() name is empty')
test_pmc = class_instance.'inspect'('namespace')
$I0 = isnull test_pmc
ok($I0, 'clone() namespace is null')
test_pmc = class_instance.'inspect'('attributes')
test_val = elements test_pmc
is(test_val, 1, 'clone() attribute survived cloning')
class_instance.'add_attribute'('jungle')
ok(1, 'clone() can modify cloned class')
.end
.sub 'clone_pmc'
.local pmc class, class_instance, monkey, mandrill, test_ns
.local string test_string_val
.local int num_elems
class = new 'Hash'
class['name'] = 'Monkey2'
class_instance = new 'Class', class
class_instance.'add_attribute'('banana')
monkey = class_instance.'new'()
ok(1, 'clone_pmc() created class Monkey and instantiated it')
class = new 'Hash'
class['name'] = 'Mandrill'
mandrill = clone class_instance, class
ok(1, 'clone_pmc() cloned class Monkey with Hash argument')
test_string_val = mandrill.'inspect'('name')
is(test_string_val, 'Mandrill', 'clone_pmc() name is new one set in the Hash')
test_ns = mandrill.'inspect'('namespace')
test_string_val = test_ns
is(test_string_val, 'Mandrill', 'clone_pmc() namespace is Mandrill too')
test_ns = mandrill.'inspect'('attributes')
num_elems = elements test_ns
is(num_elems, 1, 'clone_pmc() attribute survived cloning')
mandrill.'add_attribute'('jungle')
ok(1, 'clone_pmc() can modify cloned class')
.end
.sub 'new with init hash'
.local pmc class, init_hash, attrs, methods, meth_to_add, class_instance
.local pmc attr_val, result
init_hash = new 'Hash'
# We'll have some attributes...
attrs = new 'ResizablePMCArray'
attrs[0] = 'x'
attrs[1] = 'y'
init_hash['attributes'] = attrs
# And a method.
methods = new 'Hash'
meth_to_add = get_global 'add'
methods['add'] = meth_to_add
init_hash['methods'] = methods
class = new 'Class', init_hash
ok(1, 'new() created new class with attributes and methods supplied')
# Instantiate and try setting each attribute.
class_instance = class.'new'()
attr_val = new 'Integer'
attr_val = 37
setattribute class_instance, 'x', attr_val
ok(1, 'new() set first attribute')
attr_val = new 'Integer'
attr_val = 5
setattribute class_instance, 'y', attr_val
ok(1, 'new() set second attribute')
# Call method.
result = class_instance.'add'()
is(result, 42, 'new() added method returns expected value')
.end
.sub add :method
$P0 = getattribute self, "x"
$P1 = getattribute self, "y"
$P2 = new 'Integer'
$P2 = $P0 + $P1
.return($P2)
.end
# L<PDD15/Class PMC API/=item isa>
.sub 'isa'
.local pmc class
new class, 'Class'
test_isa( class, 'Class', 1 )
test_isa( class, 'Hash', 0 )
test_isa( class, 'Foo', 0 )
.end
.sub 'test_isa'
.param pmc obj
.param string class
.param int expected
.local int isa_class
.local string message
$I0 = 0
message = 'isa() '
isa_class = obj.'isa'( class )
if isa_class goto is_class
message .= "The object isn't a "
message .= class
goto test
is_class:
$I0 = 1
message .= "The object is a "
message .= class
test:
is($I0, expected, message)
.return()
.end
# L<PDD15/Class PMC API/=item does>
.sub 'does'
.local pmc class
.local pmc attrs
attrs = new 'Hash'
.local pmc red, green, blue
attrs['name'] = 'Red'
red = new 'Role', attrs
attrs['name'] = 'Green'
green = new 'Role', attrs
attrs['name'] = 'Blue'
blue = new 'Role', attrs
green.'add_role'( blue )
.local pmc color
color = new 'Class'
test_does( color, 'Red', 0 )
color.'add_role'( red )
test_does( color, 'Red', 1 )
color.'add_role'( green )
test_does( color, 'Green', 1 )
test_does( color, 'Blue', 1 )
test_does( color, 'Class', 1 )
.end
.sub 'test_does'
.param pmc obj
.param string role_name
.param int expected
.local int does_a_role
.local string message
$I0 = 0
message = 'does() '
does_a_role = obj.'does'( role_name )
if does_a_role goto does_role
message .= "The object doesn't "
message .= role_name
goto test
does_role:
$I0 = 1
message .= "The object does "
message .= role_name
test:
is($I0, expected, message)
.return()
.end
# L<PDD15/Class PMC API/=item does>
.sub 'more does' # RT #42974
.local pmc attrs
attrs = new 'Hash'
.local pmc red, green, blue
attrs['name'] = 'Red'
red = new 'Role', attrs
attrs['name'] = 'Green'
green = new 'Role', attrs
attrs['name'] = 'Blue'
blue = new 'Role', attrs
green.'add_role'( blue )
.local pmc color
color = new 'Class'
$S0 = 'Red'
$I0 = color.'does'($S0)
is($I0, 0, 'does not Red')
color.'add_role'( red )
$I0 = color.'does'($S0)
is($I0, 1, 'does Red')
.end
# Local Variables:
# mode: pir
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir:
Jump to Line
Something went wrong with that request. Please try again.