t/pmc/parrotobject.t

   1 #!perl
   2 # Copyright (C) 2006-2008, Parrot 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 => 11;
  10
  11 =head1 NAME
  12
  13 t/pmc/parrotobject.t - test the Object PMC
  14
  15
  16 =head1 SYNOPSIS
  17
  18     % prove t/pmc/parrotobject.t
  19
  20 =head1 DESCRIPTION
  21
  22 Tests the Object PMC.
  23
  24 =cut
  25
  26 pir_error_output_like( <<'CODE', <<'OUT', 'new' );
  27 .sub 'test' :main
  28     new $P0, ['Object']
  29     print "ok 1\n"
  30 .end
  31 CODE
  32 /Object must be created by a class./
  33 OUT
  34
  35 # '
  36
  37 pir_output_is( <<'CODE', <<'OUT', ':vtable override' );
  38 .sub main :main
  39    $P0 = newclass [ "Test" ]
  40    $P1 = new [ "Test" ]
  41    $I1 = $P1[11]
  42    print $I1
  43    print "\n"
  44 .end
  45
  46 .namespace [ "Test" ]
  47
  48 .sub get_integer_keyed_int :method :vtable
  49    .param int key
  50    .return(42)
  51 .end
  52 CODE
  53 42
  54 OUT
  55
  56 # '
  57
  58 pir_output_is( <<'CODE', <<'OUT', ':vtable("...") override' );
  59 .sub main :main
  60     $P0 = newclass [ "Test" ]
  61     $P1 = new [ "Test" ]
  62     $S1 = $P1[11]
  63     print $S1
  64     print "\n"
  65 .end
  66
  67 .namespace [ "Test" ]
  68
  69 .sub monkey :method :vtable("get_string_keyed_int")
  70     .param int key
  71     .return("monkey")
  72 .end
  73 CODE
  74 monkey
  75 OUT
  76
  77 # '
  78
  79 pir_error_output_like( <<'CODE', <<'OUT', ':vtable with bad name' );
  80 .namespace [ "Test" ]
  81
  82 .sub monkey :method :vtable("not_in_the_vtable")
  83     .param int key
  84     .return("monkey")
  85 .end
  86 CODE
  87 /'not_in_the_vtable' is not a vtable, but was used with :vtable/
  88 OUT
  89
  90 # '
  91
  92 pir_output_is( <<'CODE', <<'OUT', ':vtable and init' );
  93 .sub main :main
  94    $P0 = newclass [ "Test" ]
  95    $P1 = new [ "Test" ]
  96    print "ok\n"
  97 .end
  98
  99 .namespace [ "Test" ]
 100
 101 .sub init :method :vtable
 102    print "init\n"
 103 .end
 104 CODE
 105 init
 106 ok
 107 OUT
 108
 109 # '
 110
 111 pir_output_is( <<'CODE', <<'OUT', ':vtable inheritance' );
 112 .sub main :main
 113    $P0 = newclass [ "Test" ]
 114    $P1 = newclass [ "Test2" ]
 115    addparent $P1, $P0
 116    $P2 = new [ "Test2" ]
 117    $P3 = clone $P2
 118    print "ok\n"
 119 .end
 120
 121 .namespace [ "Test" ]
 122
 123 .sub clone :method :vtable
 124    print "cloned\n"
 125 .end
 126
 127 .namespace [ "Test2" ]
 128 CODE
 129 cloned
 130 ok
 131 OUT
 132
 133 # '
 134
 135 pir_output_is( <<'CODE', <<'OUT', ':vtable inheritance from core classes' );
 136 .sub main :main
 137     $P0 = subclass 'Hash', 'Foo'
 138     $P0 = subclass 'Hash', 'Bar'
 139
 140     $P1 = new ['Foo']
 141     $S1 = $P1
 142     say $S1
 143
 144     $P1 = new ['Bar']
 145     $S1 = $P1
 146     say $S1
 147 .end
 148
 149
 150 .namespace [ 'Foo' ]
 151
 152 .sub 'get_string' :vtable :method
 153     .return('Foo::get_string')
 154 .end
 155
 156
 157 .namespace [ 'Bar' ]
 158
 159 .sub 'get_string' :vtable :method
 160     .return('Bar::get_string')
 161 .end
 162 CODE
 163 Foo::get_string
 164 Bar::get_string
 165 OUT
 166
 167 # assign opcode in inherited classes
 168 pir_output_is(
 169     <<'CODE', <<'OUT', 'assign opcode in inherited classes' );
 170 .sub main :main
 171     $P1 = new ['ResizablePMCArray']
 172     push $P1, 3
 173     $P2 = new ['ResizablePMCArray']
 174     assign $P2, $P1
 175     $I0 = elements $P2
 176     print $I0
 177     print "\n"
 178
 179     $P99 = subclass 'ResizablePMCArray', 'Perl6List'
 180     $P1 = new 'Perl6List'
 181     push $P1, 3
 182     $P2 = new 'Perl6List'
 183     assign $P2, $P1
 184     $I0 = elements $P2
 185     print $I0
 186     print "\n"
 187 .end
 188 CODE
 189 1
 190 1
 191 OUT
 192
 193 pir_output_is( <<'CODE', <<'OUT', 'Execution ends after returning from invoke' );
 194 .namespace ['Foo']
 195
 196 .sub invoke :vtable
 197 say "you invoked me!"
 198 .return()
 199 .end
 200
 201 .sub main :main
 202 $P0 = newclass "Foo"
 203 $P1 = new ['Foo']
 204 $P1($P1)   # pass the object it"self"
 205 say "got here"
 206 .end
 207 CODE
 208 you invoked me!
 209 got here
 210 OUT
 211
 212 pir_output_is( <<'CODE', <<'OUT', 'params/returns from overridden invoke' );
 213 .namespace ['Foo']
 214
 215 .sub invoke :vtable
 216   .param int a
 217   print a
 218   print "\n"
 219   inc a
 220   .return(a)
 221 .end
 222
 223 .sub main :main
 224   $P0 = newclass "Foo"
 225   $P1 = new ['Foo']
 226   $I0 = $P1($P1, 2) # pass the object it"self"
 227   print $I0
 228   print "\n"
 229 .end
 230 CODE
 231 2
 232 3
 233 OUT
 234
 235 pir_error_output_like( <<'CODE', <<'OUT', 'handle too few positional arguments' );
 236 .namespace ['Foo']
 237
 238 .sub invoke :vtable
 239   .param pmc a
 240   say 'hi'
 241 .end
 242
 243 .sub main :main
 244     $P0 = newclass "Foo"
 245     $P1 = new ['Foo']
 246     $P1()
 247 .end
 248 CODE
 249 /too few positional arguments/
 250 OUT
 251
 252 # '
 253
 254 # Local Variables:
 255 #   mode: cperl
 256 #   cperl-indent-level: 4
 257 #   fill-column: 100
 258 # End:
 259 # vim: expandtab shiftwidth=4: