Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tag: RELEASE_0_4_13
Fetching contributors…

Cannot retrieve contributors at this time

608 lines (512 sloc) 13.657 kB
#!perl
# Copyright (C) 2007, The Perl Foundation.
# $Id$
use strict;
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
use Parrot::Test tests => 16;
=head1 NAME
t/pmc/class.t - test the Class PMC
=head1 SYNOPSIS
% prove t/pmc/class.t
=head1 DESCRIPTION
Tests the Class PMC.
=cut
# L<PDD15/Class PMC API/=item new>
pir_output_is( <<'CODE', <<'OUT', 'new' );
.sub 'test' :main
new $P0, .Class
say 'ok 1 - $P0 = new .Class'
$I0 = isa $P0, 'Class'
if $I0 goto ok_2
print 'not '
ok_2:
say "ok 2 - isa $P0, 'Class'"
.end
CODE
ok 1 - $P0 = new .Class
ok 2 - isa $P0, 'Class'
OUT
# L<PDD15/Class PMC API/'Class PMCs also have the "I am a class" flag set on them.'>
pir_output_is( <<'CODE', <<'OUT', 'Class PMC has "I am a class" flag set' );
.include 'pmcinfo.pasm'
.sub 'test' :main
.const int POBJ_IS_CLASS_FLAG = 536870912 # 1 << 29
new $P0, .Class
$I0 = pmcinfo $P0, .PMCINFO_FLAGS # XXX op currently experimental
$I99 = $I0 & POBJ_IS_CLASS_FLAG
if $I99 goto ok_1
print 'not '
ok_1:
say 'ok 1 - Class PMC has "I am a class" flag set'
.end
CODE
ok 1 - Class PMC has "I am a class" flag set
OUT
# L<PDD15/Class PMC API/=item name>
pir_output_is( <<'CODE', <<'OUT', 'name' );
.sub 'test' :main
new $P0, .Class
$P1 = $P0.'name'()
if $P1 == '' goto ok_1
print 'not '
ok_1:
say 'ok 1 - name() with no args returns class name, which is empty at first'
$P0.'name'('Alex')
$P1 = $P0.'name'()
if $P1 == 'Alex' goto ok_2
print 'not '
ok_2:
say 'ok 2 - name() with args sets class name'
push_eh ok_3
$P0.'name'('Alice', 'Bob')
clear_eh
print 'not '
ok_3:
say 'ok 3 - name() with too many args fails'
$P1 = $P0.'pmc_namespace'()
if $P1 == 'Alex' goto ok_4
print 'not '
ok_4:
say 'ok 4 - name() with args sets namespace too'
.end
CODE
ok 1 - name() with no args returns class name, which is empty at first
ok 2 - name() with args sets class name
ok 3 - name() with too many args fails
ok 4 - name() with args sets namespace too
OUT
# L<PDD15/Class PMC API/=item new>
pir_output_is( <<'CODE', <<'OUT', 'new' );
.sub 'test' :main
new $P0, .Class
$P1 = $P0.'new'()
$I0 = isa $P1, 'Object'
if $I0 goto ok_1
print 'not '
ok_1:
say 'ok 1 - new() with no args returns an object'
push_eh ok_2
$P1 = $P0.'new'('abc' => '123' )
clear_eh
print 'not '
ok_2:
say 'ok 2 - new() with non-attribute key fails'
$P0 = new .Class
$P0.'add_attribute'('foo')
$P0.'add_attribute'('bar')
$P1 = $P0.'new'('foo' => 1, 'bar' => 2)
$P2 = getattribute $P1, 'foo'
say $P2
$P2 = getattribute $P1, 'bar'
say $P2
say 'ok 3 - new() with key/value pairs sets attributes'
.end
CODE
ok 1 - new() with no args returns an object
ok 2 - new() with non-attribute key fails
1
2
ok 3 - new() with key/value pairs sets attributes
OUT
# L<PDD15/Class PMC API/=item attributes>
pir_output_is( <<'CODE', <<'OUT', 'attributes' );
.sub 'test' :main
new $P0, .Class
$P1 = $P0.'attributes'()
$I0 = isa $P1, 'Hash'
if $I0 goto ok_1
print 'not '
ok_1:
say 'ok 1 - attributes() returns a Hash'
$I0 = $P1
if $I0 == 0 goto ok_2
print 'not '
ok_2:
say 'ok 2 - New Class PMC has no attributes'
push_eh ok_3
$P1 = $P0.'attributes'( 'foo' )
clear_eh
print 'not '
goto ok_3
ok_3:
say 'ok 3 - attributes() is read-only accessor'
.end
CODE
ok 1 - attributes() returns a Hash
ok 2 - New Class PMC has no attributes
ok 3 - attributes() is read-only accessor
OUT
## Q: what attributes does the base Class have by default?
## A: it has no attributes by default
# L<PDD15/Class PMC API/=item add_attribute>
pir_output_is( <<'CODE', <<'OUT', 'add_attribute' );
.sub 'test' :main
new $P0, .Class
push_eh ok_1
$P0.'add_attribute'()
clear_eh
print 'not '
ok_1:
say 'ok 1 - add_attribute() with no args fails'
$P0.'add_attribute'( 'foo' )
$P1 = $P0.'attributes'()
$I0 = $P1
if $I0 == 1 goto ok_2
print 'not '
ok_2:
say 'ok 2 - add_attribute() with valid single arg adds an attribute'
$P0.'add_attribute'( 'bar', 'Integer' )
$P1 = $P0.'attributes'()
$I0 = $P1
if $I0 == 2 goto ok_3
print 'not '
ok_3:
say 'ok 3 - add_attribute() with valid args adds an attribute'
push_eh ok_4
$P0.'add_attribute'( 'foo', 'String' )
clear_eh
print 'not '
ok_4:
say 'ok 4 - add_attribute() with existing attribute name fails'
.end
CODE
ok 1 - add_attribute() with no args fails
ok 2 - add_attribute() with valid single arg adds an attribute
ok 3 - add_attribute() with valid args adds an attribute
ok 4 - add_attribute() with existing attribute name fails
OUT
## Q: should adding an attribute with an invalid type name fail?
## A: since type compatibility checks does, you could specify a type
# that isn't registered as a class/role. So, no, I don't think it should try to
# validate types.
## NOTE i think this belongs in the Object PMC tests
# L<PDD15/Class PMC API>
pir_output_is( <<'CODE', <<'OUT', 'set_attr/get_attr VTABLE methods' );
.sub 'test' :main
new $P0, .Class
$P0.'name'("Test")
$P0.'add_attribute'("foo")
say 'ok 1 - created a class with two attributes'
$P1 = $P0.'new'()
say 'ok 2 - instantiated the class'
$P2 = new Integer
$P2 = 42
setattribute $P1, "foo", $P2
say 'ok 3 - set an attribute'
$P3 = getattribute $P1, "foo"
print $P3
print "\n"
say 'ok 4 - got an attribute'
.end
CODE
ok 1 - created a class with two attributes
ok 2 - instantiated the class
ok 3 - set an attribute
42
ok 4 - got an attribute
OUT
# L<PDD15/Class PMC API/=item parents>
pir_output_is( <<'CODE', <<'OUT', 'parents' );
.sub 'test' :main
new $P0, .Class
$P1 = $P0.'parents'()
$I0 = isa $P1, 'ResizablePMCArray' ## XXX really?
if $I0 goto ok_1
print 'not '
ok_1:
say 'ok 1 - parents() returns a ResizablePMCArray'
.end
CODE
ok 1 - parents() returns a ResizablePMCArray
OUT
## 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>
pir_output_is( <<'CODE', <<'OUT', 'roles' );
.sub 'test' :main
new $P0, .Class
$P1 = $P0.'roles'()
$I0 = isa $P1, 'ResizablePMCArray' ## XXX really?
if $I0 goto ok_1
print 'not '
ok_1:
say 'ok 1 - roles() returns a ResizablePMCArray'
.end
CODE
ok 1 - roles() returns a ResizablePMCArray
OUT
## 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>
pir_output_is( <<'CODE', <<'OUT', 'inspect PCCMETHOD' );
.sub 'test' :main
$P0 = new 'Class'
$P0.name('foo')
$P0.add_attribute('a')
$P1 = $P0.inspect()
print "ok 1 - inspect with no args called\n"
$I0 = elements $P1
if $I0 == 6 goto ok_2
print "not "
ok_2:
print "ok 2 - returned hash had correct number of elements\n"
$P1 = $P0.inspect('name')
say $P1
print "ok 3 - inspect('name')\n"
$P1 = $P0.inspect('attributes')
$I0 = elements $P1
if $I0 == 1 goto ok_4
print "not "
ok_4:
print "ok 4 - inspect('attributes')\n"
.end
CODE
ok 1 - inspect with no args called
ok 2 - returned hash had correct number of elements
foo
ok 3 - inspect('name')
ok 4 - inspect('attributes')
OUT
pir_output_is( <<'CODE', <<'OUT', 'clone' );
.sub 'test' :main
$P0 = new 'Hash'
$P0['name'] = 'Monkey'
$P1 = new 'Class', $P0
$P1.add_attribute('banana')
$P2 = $P1.'new'()
print "ok 1 - created class Monkey and instantiated it\n"
$P3 = clone $P1
print "ok 2 - cloned class Monkey\n"
$S1 = $P3.'inspect'('name')
if $S1 == "" goto ok_3
print "not "
ok_3:
print "ok 3 - name is empty\n"
$P4 = $P3.'inspect'('namespace')
if null $P4 goto ok_4
print "not "
ok_4:
print "ok 4 - namespace is null\n"
$P4 = $P3.'inspect'('attributes')
$I0 = elements $P4
if $I0 == 1 goto ok_5
print "not "
ok_5:
print "ok 5 - attribute survived cloning\n"
$P3.add_attribute('jungle')
print "ok 6 - can modify cloned class\n"
.end
CODE
ok 1 - created class Monkey and instantiated it
ok 2 - cloned class Monkey
ok 3 - name is empty
ok 4 - namespace is null
ok 5 - attribute survived cloning
ok 6 - can modify cloned class
OUT
pir_output_is( <<'CODE', <<'OUT', 'clone_pmc' );
.sub 'test' :main
$P0 = new 'Hash'
$P0['name'] = 'Monkey'
$P1 = new 'Class', $P0
$P1.add_attribute('banana')
$P2 = $P1.'new'()
print "ok 1 - created class Monkey and instantiated it\n"
$P0 = new 'Hash'
$P0['name'] = 'Mandrill'
$P3 = clone $P1, $P0
print "ok 2 - cloned class Monkey with Hash argument\n"
$S1 = $P3.'inspect'('name')
if $S1 == "Mandrill" goto ok_3
print "not "
ok_3:
print "ok 3 - name is new one set in the Hash\n"
$P4 = $P3.'inspect'('namespace')
$S1 = $P4
if $S1 == 'Mandrill' goto ok_4
print "not "
ok_4:
print "ok 4 - namespace is Mandrill too\n"
$P4 = $P3.'inspect'('attributes')
$I0 = elements $P4
if $I0 == 1 goto ok_5
print "not "
ok_5:
print "ok 5 - attribute survived cloning\n"
$P3.add_attribute('jungle')
print "ok 6 - can modify cloned class\n"
.end
CODE
ok 1 - created class Monkey and instantiated it
ok 2 - cloned class Monkey with Hash argument
ok 3 - name is new one set in the Hash
ok 4 - namespace is Mandrill too
ok 5 - attribute survived cloning
ok 6 - can modify cloned class
OUT
pir_output_is( <<'CODE', <<'OUT', 'new with initialization hash' );
.sub 'test' :main
$P0 = new 'Hash'
# We'll have some attributes...
$P1 = new 'ResizablePMCArray'
$P1[0] = 'x'
$P1[1] = 'y'
$P0['attributes'] = $P1
# And a method.
$P1 = new 'Hash'
$P2 = find_global 'add'
$P1['add'] = $P2
$P0['methods'] = $P1
$P1 = new 'Class', $P0
print "ok 1 - created new class with attributes and methods supplied\n"
# Instantiate and try setting each attribute.
$P2 = $P1.'new'()
$P3 = new 'Integer'
$P3 = 37
setattribute $P2, 'x', $P3
print "ok 2 - set first attribute\n"
$P3 = new 'Integer'
$P3 = 5
setattribute $P2, 'y', $P3
print "ok 3 - set second attribute\n"
# Call method.
$P3 = $P2.add()
print $P3
print "\nok 4 - called method\n"
.end
.sub add :method
$P0 = getattribute self, "x"
$P1 = getattribute self, "y"
$P2 = new 'Integer'
$P2 = $P0 + $P1
.return($P2)
.end
CODE
ok 1 - created new class with attributes and methods supplied
ok 2 - set first attribute
ok 3 - set second attribute
42
ok 4 - called method
OUT
# L<PDD15/Class PMC API/=item isa>
pir_output_is( <<'CODE', <<'OUT', 'isa()' );
.sub 'test' :main
new $P0, .Class
test_isa( $P0, 'Class' )
test_isa( $P0, 'Hash' )
test_isa( $P0, 'Foo' )
.end
.sub 'test_isa'
.param pmc obj
.param string class
$I0 = obj.'isa'( class )
if $I0 goto is_class
print "Not a "
print class
print "\n"
.return()
is_class:
print "Is a "
print class
print "\n"
.return()
.end
CODE
Is a Class
Not a Hash
Not a Foo
OUT
# L<PDD15/Class PMC API/=item does>
pir_output_is( <<'CODE', <<'OUT', 'does()' );
.sub 'test' :main
.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' )
color.'add_role'( red )
test_does( color, 'Red' )
color.'add_role'( green )
test_does( color, 'Green' )
test_does( color, 'Blue' )
test_does( color, 'Class' )
.end
.sub 'test_does'
.param pmc obj
.param string role_name
$I0 = obj.'does'( role_name )
if $I0 goto does_role
print "Doesn't "
print role_name
print "\n"
.return()
does_role:
print "Does "
print role_name
print "\n"
.return()
.end
CODE
Doesn't Red
Does Red
Does Green
Does Blue
Does Class
OUT
# L<PDD15/Class PMC API/=item does>
pir_output_is( <<'CODE', <<'OUT', 'more does() - RT #42974' );
.const int TESTS = 2
.sub 'main' :main
load_bytecode 'Test/More.pir'
.local pmc exp, test_ns
test_ns = get_namespace ['Test::More']
exp = new 'Exporter'
exp.'source'(test_ns)
exp.'import'('plan ok is diag isa_ok' :named('globals'))
plan(TESTS)
.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
CODE
1..2
ok 1 - does not Red
ok 2 - does Red
OUT
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
Jump to Line
Something went wrong with that request. Please try again.