t/oo/ops.t

   1 #!perl
   2 # Copyright (C) 2007, The Perl Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8 use Test::More;
   9 use Parrot::Test tests => 8;
  10
  11 =head1 NAME
  12
  13 t/oo/ops.t - test OO related ops
  14
  15 =head1 SYNOPSIS
  16
  17     % prove t/oo/ops.t
  18
  19 =head1 DESCRIPTION
  20
  21 Tests opcodes related to the OO implementation.
  22
  23 =cut
  24
  25 pir_output_is( <<'CODE', <<'OUT', 'addrole_p_p' );
  26 .sub 'test' :main
  27     $P0 = new 'Role'
  28     $P1 = new 'Class'
  29     addrole $P1, $P0
  30     print "ok 1 - addrole op executed\n"
  31
  32     $P2 = $P1.roles()
  33     $I0 = elements $P2
  34     if $I0 == 1 goto ok_2
  35     print "not "
  36 ok_2:
  37     print "ok 2 - addrole op actually added the role\n"
  38 .end
  39 CODE
  40 ok 1 - addrole op executed
  41 ok 2 - addrole op actually added the role
  42 OUT
  43
  44 pir_output_is( <<'CODE', <<'OUT', 'inspect_p_p' );
  45 .sub 'test' :main
  46     $P0 = new 'Class'
  47
  48     $P1 = inspect $P0
  49     print "ok 1 - inspect_p_p op executed\n"
  50
  51     $I0 = elements $P1
  52     if $I0 == 7 goto ok_2
  53     print "not "
  54 ok_2:
  55     print "ok 2 - returned hash had correct number of elements\n"
  56 .end
  57 CODE
  58 ok 1 - inspect_p_p op executed
  59 ok 2 - returned hash had correct number of elements
  60 OUT
  61
  62 pir_output_is( <<'CODE', <<'OUT', 'inspect_p_p_s' );
  63 .sub 'test' :main
  64     $P0 = new 'Class'
  65     $P0.name('foo')
  66     $P0.add_attribute('a')
  67
  68     $P1 = inspect $P0, 'name'
  69     say $P1
  70     print "ok 1 - inspect_p_p_s with $3='name'\n"
  71
  72     $P1 = inspect $P0, 'flags'
  73     $I0 = $P1
  74     $I1 = 1 << 29 # flag 29 is PObj_is_class_FLAG
  75
  76     $I2 = $I0 & $I1
  77     if $I2 goto flags_ok
  78       print "not "
  79     flags_ok:
  80     print "ok 2 - inspect_p_p_s with $3='flags'\n"
  81
  82     $P1 = inspect $P0, 'attributes'
  83     $I0 = elements $P1
  84     if $I0 == 1 goto ok_2
  85     print "not "
  86 ok_2:
  87     print "ok 3 - inspect_p_p_s with $3='attributes'\n"
  88 .end
  89 CODE
  90 foo
  91 ok 1 - inspect_p_p_s with $3='name'
  92 ok 2 - inspect_p_p_s with $3='flags'
  93 ok 3 - inspect_p_p_s with $3='attributes'
  94 OUT
  95
  96 pir_output_is( <<'CODE', <<'OUT', 'get_class_p_s' );
  97 .sub main :main
  98     $P0 = new 'Hash'
  99     $P4 = new 'String'
 100     $P4 = 'Monkey'
 101     $P0['name'] = $P4
 102
 103     $P1 = new 'Class', $P0
 104     print "ok 1 - created new class named Monkey\n"
 105
 106     push_eh nok_2
 107     $P2 = get_class 'Monkey'
 108     pop_eh
 109     goto ok_2
 110 nok_2:
 111     print "not "
 112 ok_2:
 113     print "ok 2 - get_class found a class\n"
 114
 115     $P3 = $P2.'inspect'('name')
 116     print $P3
 117     print "\nok 3 - got name of found class\n"
 118 .end
 119 CODE
 120 ok 1 - created new class named Monkey
 121 ok 2 - get_class found a class
 122 Monkey
 123 ok 3 - got name of found class
 124 OUT
 125
 126 pir_output_is( <<'CODE', <<'OUT', 'get_class_p_p' );
 127 .sub main :main
 128     $P0 = new 'Hash'
 129     $P4 = new 'String'
 130     $P4 = 'Monkey'
 131     $P0['name'] = $P4
 132
 133     $P1 = new 'Class', $P0
 134     print "ok 1 - created new class named Monkey\n"
 135
 136     push_eh nok_2
 137     $P2 = get_class [ 'Monkey' ]
 138     pop_eh
 139     goto ok_2
 140 nok_2:
 141     print "not "
 142 ok_2:
 143     print "ok 2 - get_class with a Key found a class\n"
 144
 145     $P3 = $P2.'inspect'('name')
 146     print $P3
 147     print "\nok 3 - got name of found class\n"
 148
 149     push_eh nok_4
 150     $P3 = get_namespace [ 'Monkey' ]
 151     $P2 = get_class $P3
 152     pop_eh
 153     goto ok_4
 154 nok_4:
 155     print "not "
 156 ok_4:
 157     print "ok 4 - get_class with a NameSpace found a class\n"
 158
 159     $P3 = $P2.'inspect'('name')
 160     print $P3
 161     print "\nok 5 - got name of found class\n"
 162 .end
 163 CODE
 164 ok 1 - created new class named Monkey
 165 ok 2 - get_class with a Key found a class
 166 Monkey
 167 ok 3 - got name of found class
 168 ok 4 - get_class with a NameSpace found a class
 169 Monkey
 170 ok 5 - got name of found class
 171 OUT
 172
 173 pir_error_output_like( <<'CODE', <<'OUT', 'addattribute_p_s' );
 174 .sub main :main
 175     $P0 = new 'Class'
 176     addattribute $P0, 'foo'
 177
 178     $P1 = $P0.'new'()
 179
 180     $P2 = new 'Integer'
 181     $P2 = 100
 182     setattribute $P1, 'foo', $P2
 183     getattribute $P2, $P1, 'foo'
 184
 185     print $P2
 186     print "\n"
 187
 188     $P0 = new 'Hash'
 189     addattribute $P0, 'oops'
 190     print "Not here!\n"
 191 .end
 192 CODE
 193 /100
 194 Cannot add attribute to non-class
 195 current instr\.: 'main'/
 196 OUT
 197
 198 pir_output_is( <<'CODE', <<'OUT', 'new_p_s works with string register arg' );
 199 .sub main :main
 200 #    $P0 = newclass "Foo"
 201     $P0 = newclass "Foo"
 202     addattribute $P0, 'foo'
 203
 204     $S0 = "Foo"
 205     $P1 = new $S0
 206
 207     $P2 = new 'Integer'
 208     $P2 = 100
 209     setattribute $P1, 'foo', $P2
 210     getattribute $P2, $P1, 'foo'
 211
 212     print $P2
 213     print "\n"
 214
 215 .end
 216 CODE
 217 100
 218 OUT
 219
 220 pir_output_is( <<'CODE', <<'OUT', 'can_i_p_s' );
 221 .sub main :main
 222     $P0 = newclass "Foo"
 223     $P1 = new $P0
 224
 225     can $I0, $P1, "bar"
 226
 227     if $I0 goto can_bar
 228     print "not "
 229   can_bar:
 230     print "ok 1\n"
 231
 232     $P1.'bar'()
 233 .end
 234
 235 .namespace ["Foo"]
 236 .sub bar :method
 237     print "called bar\n"
 238 .end
 239
 240 CODE
 241 ok 1
 242 called bar
 243 OUT
 244
 245 # Local Variables:
 246 #   mode: cperl
 247 #   cperl-indent-level: 4
 248 #   fill-column: 100
 249 # End:
 250 # vim: expandtab shiftwidth=4: