#! perl
# Copyright (C) 2001-2007, The Perl Foundation.
# $Id: /mirror/trunk/t/pmc/object-meths.t 35425 2009-01-11T07:34:33.703139Z cotto  $

use strict;
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
use Parrot::Test tests => 37;

=head1 NAME

t/pmc/object-meths.t - Object Methods

=head1 SYNOPSIS

    % prove t/pmc/object-meths.t

=head1 DESCRIPTION

Tests PMC object methods.

=cut

pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethodcc - unknown method" );
    newclass P2, "Foo"
    set S0, "nada"
    callmethodcc P2, S0
    print "should never reach here\n"
    end
CODE
/Method 'nada' not found for invocant of class 'Foo'/
OUTPUT

pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethod (STR) - unknown method" );
    newclass P2, "Foo"
    set S1, "nada"
    callmethod P2, S1, P1
    print "should never reach here\n"
    end
CODE
/Method 'nada' not found for invocant of class 'Foo'/
OUTPUT

pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethodcc - unknown method" );
    newclass P2, "Foo"
    set S0, "nada"
    callmethodcc P2, S0
    print "should never reach here\n"
    end
CODE
/Method 'nada' not found for invocant of class 'Foo'/
OUTPUT

pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethodcc (STR) - unknown method" );
    newclass P2, "Foo"
    set S1, "nada"
    callmethodcc P2, S1
    print "should never reach here\n"
    end
CODE
/Method 'nada' not found for invocant of class 'Foo'/
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "callmethod 1" );
.sub main :main
    $P2 = newclass "Foo"
    $P3 = new $P2
    set $S0, "meth"

    print "main\n"
    $P3.'meth'()
    print "back\n"
    end
.end

.namespace ["Foo"]
.sub meth :method
    print "in meth\n"
    .return ()
.end
CODE
main
in meth
back
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "can class" );
.sub main :main
    $P2 = newclass "Foo"

    $P3 = new ['Sub']
    # Add a method to the class manually
    $P2.'add_method'("meth", $P3)

    # Classes only report 'can' for class methods, not instance methods
    can $I0, $P2, "meth"
    print $I0
    print "\n"
    end
.end
CODE
0
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "can object" );
.sub main :main
    $P2 = newclass "Foo"
    $P4 = new ['Foo']

    $P3 = new ['Sub']
    # Add a method to the class manually
    $P2.'add_method'("meth", $P3)

    can $I0, $P4, "meth"
    print $I0
    print "\n"
    can $I0, $P4, "no_such_meth"
    print $I0
    print "\n"
    end
.end
CODE
1
0
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "constructor" );
.sub main :main
    $P1 = newclass "Foo"
    new $P3, ['Foo']
    print "ok 2\n"
    end
.end

.namespace ["Foo"]
.sub init :method :vtable
    print "ok 1\n"
.end
CODE
ok 1
ok 2
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', "constructor - init attr" );
    newclass P1, "Foo"
    addattribute P1, ".i"
    new P3, ['Foo']
    print "ok 2\n"
    print P3
    print "\n"
    end
.namespace ["Foo"]
.pcc_sub __init:
    get_params "0", P2
    print "ok 1\n"
    new P10, ['Integer']
    set P10, 42
    setattribute P2, ".i", P10
    set_returns ""
    returncc
.pcc_sub __get_string:
    get_params "0", P2
    getattribute P10, P2, ".i"
    set_returns "0", P10
    returncc
CODE
ok 1
ok 2
42
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', "constructor - parents" );
    newclass P1, "Foo"
    subclass P2, P1, "Bar"
    subclass P3, P2, "Baz"
    new P3, ['Baz']
    new P3, ['Bar']
    get_global P0, "_sub"
    invokecc P0
    print "done\n"
    end

    .namespace ["Foo"]
.pcc_sub __init:
    get_params "0", P2
    print "foo_init\n"
    typeof S0, P2
    print S0
    print "\n"
    returncc

    .namespace ["Bar"]
.pcc_sub __init:
    get_params "0", P2
    print "bar_init\n"
    returncc

    .namespace ["Baz"]
.pcc_sub __init:
    get_params "0", P2
    print "baz_init\n"
    returncc

    .namespace [] # main again
.pcc_sub _sub:
    print "in sub\n"
    returncc

CODE
foo_init
Baz
bar_init
baz_init
foo_init
Bar
bar_init
in sub
done
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "methods: self" );

.sub _main
    .local pmc A
    .local pmc B

    newclass A, "A"
    newclass B, "B"

    new A, ['A']
    new B, ['B']

    setprop A, "B", B

    A."foo"()
    B."foo"()

    end
.end

.namespace ["A"]

.sub foo :method
    .local pmc B

    print "A::foo\n"
    getprop B, "B", self

    self."blah"()
    B."blah"()
    self."blah"()

.end

.sub blah :method
    print "A::blah\n"
.end

.namespace ["B"]

.sub foo :method
    print "B::foo\n"
.end

.sub blah :method
    print "B::blah\n"
.end
CODE
A::foo
A::blah
B::blah
A::blah
B::foo
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "methods: self w arg" );

.sub _main
    .local pmc A
    .local pmc B

    newclass A, "A"
    newclass B, "B"

    new A, ['A']
    new B, ['B']

    A."foo"(B)
    B."foo"()

    end
.end

.namespace ["A"]

.sub foo :method
    .param pmc B

    print "A::foo\n"

    self."blah"()
    B."blah"()
    self."blah"()

.end

.sub blah :method
    print "A::blah\n"
.end

.namespace ["B"]

.sub foo :method
    print "B::foo\n"
.end

.sub blah :method
    print "B::blah\n"
.end
CODE
A::foo
A::blah
B::blah
A::blah
B::foo
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "methods: self w arg and ret" );

.sub _main
    .local pmc A
    .local pmc B

    newclass A, "A"
    newclass B, "B"

    new A, ['A']
    new B, ['B']

    .local pmc r
    r = A."foo"(B)
    r."foo"()

    end
.end

.namespace ["A"]

.sub foo :method
    .param pmc B

    print "A::foo\n"

    self."blah"()
    B."blah"()
    self."blah"()
    .begin_return
    .set_return B
    .end_return

.end

.sub blah :method
    print "A::blah\n"
.end

.namespace ["B"]

.sub foo :method
    print "B::foo\n"
.end

.sub blah :method
    print "B::blah\n"
.end
CODE
A::foo
A::blah
B::blah
A::blah
B::foo
OUTPUT

SKIP: {
    skip( "currently broken", 1 );
    pasm_output_is( <<'CODE', <<'OUTPUT', "exceptions and different runloops" );
_main:
    push_eh eh

    newclass P0, "Foo"

    print "new\n"
    new P2, ['Foo']
eh:
    print "back in main\n"
    end

.namespace ["Foo"]
.pcc_sub __init:
    print "in __init\n"

    # raise an exception
    callmethodcc self, "qux"

    print "never\n"
    returncc
CODE
new
in __init
back in main
OUTPUT
}

pasm_output_is( <<'CODE', <<'OUTPUT', "find_method" );
    newclass P3, "Foo"
    new P2, ['Foo']

    set S0, "meth"
    find_method P0, P2, S0
    print "main\n"
    callmethodcc P2, P0
    print "back\n"
    end

.namespace ["Foo"]
.pcc_sub :method meth:
    print "in meth\n"
    returncc
CODE
main
in meth
back
OUTPUT

pasm_error_output_like( <<'CODE', <<'OUTPUT', "find_method - unknown method" );
    newclass P2, "Foo"
    set S0, "nada"
    find_method P0, P2, S0
    print "nope\n"
    end
CODE
/Method 'nada' not found for invocant of class 'Foo'/
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', "constructor - diamond parents" );
#
# A   B A   E
#  \ /   \ /
#   C     D
#    \   /
#     \ /
#      F
    newclass P1, "A"
    newclass P2, "B"
    subclass P3, P1, "C"
    addparent P3, P2

    subclass P4, P1, "D"
    newclass P5, "E"
    addparent P4, P5

    subclass P6, P3, "F"
    addparent P6, P4
    bsr _check_isa

    print "new F\n"
    new P16, ['F']
    print "done\n"
    end

_check_isa:
    print "F isa D "
    isa I0, P6, "D"
    print I0
    print "\n"
    print "D isa F "
    isa I0, P4, "F"
    print I0
    print "\n"
    print "F isa C "
    isa I0, P6, "C"
    print I0
    print "\n"
    print "C isa F "
    isa I0, P3, "F"
    print I0
    print "\n"
    print "F isa E "
    isa I0, P6, "E"
    print I0
    print "\n"
    print "E isa F "
    isa I0, P5, "F"
    print I0
    print "\n"
    print "F isa A "
    isa I0, P6, "A"
    print I0
    print "\n"
    print "A isa F "
    isa I0, P1, "F"
    print I0
    print "\n"
    print "F isa B "
    isa I0, P6, "B"
    print I0
    print "\n"
    print "B isa F "
    isa I0, P2, "F"
    print I0
    print "\n"

    print "C isa A "
    isa I0, P3, "A"
    print I0
    print "\n"
    print "A isa C "
    isa I0, P1, "C"
    print I0
    print "\n"
    print "D isa A "
    isa I0, P4, "A"
    print I0
    print "\n"
    print "A isa D "
    isa I0, P1, "D"
    print I0
    print "\n"
    ret


.namespace ["A"]
.pcc_sub __init:
    get_params "0", P2
    print "A init\n"
    returncc
.namespace ["B"]
.pcc_sub __init:
    get_params "0", P2
    print "B init\n"
    returncc
.namespace ["C"]
.pcc_sub __init:
    get_params "0", P2
    print "C init\n"
    returncc
.namespace ["D"]
.pcc_sub __init:
    get_params "0", P2
    print "D init\n"
    returncc
.namespace ["E"]
.pcc_sub __init:
    get_params "0", P2
    print "E init\n"
    returncc
.namespace ["F"]
.pcc_sub __init:
    get_params "0", P2
    print "F init\n"
    returncc
CODE
F isa D 1
D isa F 0
F isa C 1
C isa F 0
F isa E 1
E isa F 0
F isa A 1
A isa F 0
F isa B 1
B isa F 0
C isa A 1
A isa C 0
D isa A 1
A isa D 0
new F
E init
B init
A init
D init
C init
F init
done
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "constructor - vtable override" );
.sub main :main
  $P0 = newclass 'Foo'
  $P1 = subclass 'Foo', 'Bar'
  $P2 = new ['Bar']
.end

.namespace ['Foo']
.sub init :vtable :method
  print "foo init\n"
.end

.namespace ['Bar']
.sub init :vtable :method
  print "bar init\n"
.end

CODE
foo init
bar init
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "same method name in two namespaces" );

.namespace ["A"]
.sub foo :method
    .param int i

    .begin_return
    .end_return
.end

.namespace ["B"]
.sub foo :method
    .param int i

    .begin_return
    .end_return
.end

.namespace []
.sub _main :main
    print "ok\n"
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "self - CURRENT_OBJECT" );

.sub _main
    .local pmc A

    newclass A, "A"
    new A, ['A']
    A."foo"()
    end
.end

.namespace ["A"]

.sub foo :method
    .include "interpinfo.pasm"
    $P0 = interpinfo .INTERPINFO_CURRENT_OBJECT
    eq_addr self, $P0, ok
    print "not "
ok: print "ok\n"
.end
CODE
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "Bug in method calling with nonconst keys" );

.sub _main
    newclass $P0, "Foo"

    new $P1, ['Foo']

    $I1 = $P1["foo"]

    $S0 = "foo"
    $I1 = $P1[$S0]

    end
.end

.namespace ["Foo"]

.sub get_integer_keyed :vtable :method
    .param pmc key
    print "Key = "
    print key
    print "\n"
    .return(0)
.end
CODE
Key = foo
Key = foo
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "Bug in method calling with nonconst keys - clobber" );

.sub _main
    newclass $P0, "Foo"

    new $P1, ['Foo']

    $I1 = $P1["foo"]

    $S0 = "foo"
    $I1 = $P1[$S0]

    end
.end

.namespace ["Foo"]

.sub get_integer_keyed :vtable :method
    .param pmc key
    $S0 = "bar"
    print "Key = "
    print key
    print "\n"
    print $S0
    print "\n"
    .return(0)
.end
CODE
Key = foo
bar
Key = foo
bar
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "method cache invalidation" );
.sub main :main
    .local pmc o, cl
    newclass cl, "Foo"
    subclass cl, cl, "Bar"
    o = new ['Bar']
    print o
    $P0 = get_global "ok2"
    cl.'add_method'('get_string', $P0, 'vtable' => 1)
    print o
.end
.sub ok2
    .return("ok 2\n")
.end
.namespace [ "Foo" ]
.sub get_string :vtable :method
    .return("ok 1\n")
.end
CODE
ok 1
ok 2
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "callmethod - method name" );
.sub main :main
    $P2 = newclass "Foo"
    $S0 = "meth"
    print "main\n"
    $P3 = new $P2
    $P3.$S0()
    print "back\n"
    end
.end

.namespace ["Foo"]
.sub meth :method
    print "in meth\n"
    getinterp $P0
    $P1 = $P0["sub"]
    print $P1
    print "\n"
    .return ()
.end
CODE
main
in meth
meth
back
OUTPUT

SKIP: {
    skip( "no bound NCI method", 1 );
    pir_output_is( <<'CODE', <<'OUTPUT', "bound NCI method" );
.sub main :main
    .local pmc s, l, f
    s = new ['String']
    s = "ABC\n"
    f = getattribute s, "lower"
    typeof $S0, f
    print $S0
    print "\n"
    l = f()
    print l
.end
CODE
Bound_NCI
abc
OUTPUT
}

pir_output_is( <<'CODE', <<'OUTPUT', "tailcallmeth" );
.sub main :main
    .local pmc cl, o, n
    cl = newclass "Foo"
    addattribute cl, "n"
    o = new ['Foo']
    n = new ['Integer']
    n = 2000
    setattribute o, [ "Foo" ], "n", n
    o.'go'()
    n = getattribute o, [ "Foo" ], "n"
    print n
    print "\n"
.end

.namespace ["Foo"]
.sub go :method
    .local pmc n
    n = getattribute self, [ "Foo" ], "n"
    dec n
    unless n goto done
    .tailcall self."go"()
done:
.end
CODE
0
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "kind of a super" );
.sub main :main
    .local pmc cl, o
    cl = subclass "String", "MyString"
    o = new ['MyString']
    o = "foo"
    print o
    print "\n"
.end

.namespace ["MyString"]
.sub set_string_native :vtable :method
    .param string s
    $P0 = getattribute self, ["String"], 'proxy'
    s .= s
    $P0 = s
.end
CODE
foofoo
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "delegate keyed_int" );
.sub main :main
    .local pmc cl, o
    cl = newclass "MyClass"
    o = new ['MyClass']
    $I0 = 5
    $S0 = "foo"
    o[$I0] = 42
    o[$S0] = 42
    delete o[$I0]
    delete o[$S0]
    $I1 = defined o[$I0]
    $I1 = defined o[$S0]
    $I1 = exists o[$I0]
    $I1 = exists o[$S0]
.end

.namespace ["MyClass"]

.sub set_integer_keyed_int :vtable :method
    .param int key
    .param int val
    print "ikey\n"
.end

.sub set_integer_keyed :vtable :method
    .param string key
    .param int val
    print "skey\n"
.end

.sub delete_keyed_int :vtable :method
    .param int key
    print "del_ikey\n"
.end

.sub delete_keyed :vtable :method
    .param string key
    print "del_skey\n"
.end

.sub defined_keyed_int :vtable :method
    .param int key
    print "def_ikey\n"
    .return (0)
.end

.sub defined_keyed :vtable :method
    .param string key
    print "def_skey\n"
    .return (0)
.end

.sub exists_keyed_int :vtable :method
    .param int key
    print "exists_ikey\n"
    .return (0)
.end

.sub exists_keyed :vtable :method
    .param string key
    print "exists_skey\n"
    .return (0)
.end

CODE
ikey
skey
del_ikey
del_skey
def_ikey
def_skey
exists_ikey
exists_skey
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "delegate keyed_int PMC derived" );
.sub main :main
    .local pmc cl, o
    cl = subclass "ResizablePMCArray", "MyClass"
    o = new ['MyClass']
    $I0 = 5
    o[$I0] = 42
    $I1 = o[$I0]
    print $I1
    print "\n"
.end

.namespace ["MyClass"]

.sub get_integer_keyed_int :vtable :method
    .param int key
    print "ikey\n"
    .local pmc ar
    ar = getattribute self, ["ResizablePMCArray"], "proxy"
    $I0 = ar[key]
    .return ($I0)
.end

.sub set_integer_keyed_int :vtable :method
    .param int key
    .param int val
    print "pkey\n"
    .local pmc ar
    ar = getattribute self, ["ResizablePMCArray"], "proxy"
    ar[key] = val
.end

CODE
pkey
ikey
42
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "delegate keyed_int PMC derived - inherit" );
.sub main :main
    .local pmc cl, o
    cl = subclass "ResizablePMCArray", "MyClass"
    o = new ['MyClass']
    $I0 = 5
    o[$I0] = 42
    $I1 = o[$I0]
    print $I1
    print "\n"
.end

.namespace ["MyClass"]

.sub get_integer_keyed_int :vtable :method
    .param int key
    print "ikey\n"
    .local pmc ar
    ar = getattribute self, ["ResizablePMCArray"], "proxy"
    $I0 = ar[key]
    .return ($I0)
.end

CODE
ikey
42
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "addmethod op" );
.sub main :main
    .local pmc c
    c = newclass ['whatever']
    .const 'Sub' foo = "whatever_foo"
    addmethod c, "foo", foo
    $P0 = new ['whatever']
    $P0.'foo'()
.end

.sub whatever_foo :anon :method
    print "Foo!\n"
.end
CODE
Foo!
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "inherit a PMC METHOD" );
.sub main :main
    .local pmc cl, o
    cl = subclass 'Integer', 'MyInt'
    o = new ['MyInt']
    o = 10
    $S0 = o.'get_as_base'(16)
    print $S0
    print "\n"
.end
CODE
a
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "init calls" );
.sub main :main
    .local pmc cl, o
    cl = newclass 'MyClass'
    o = new ['MyClass']
    $P0 = new ['String']
    o = new ['MyClass'], $P0
.end

.namespace ['MyClass']

.sub init :method :vtable
    .param pmc initializer :optional
    print "init was called\n"
.end

.sub init_pmc :method :vtable
    .param pmc initializer
    print "init_pmc was called\n"
.end
CODE
init was called
init_pmc was called
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "overloading find_method vtable" );
.sub main :main
    .local pmc cl, o
    cl = newclass 'MyClass'
    o = new ['MyClass']
    o.'foo'()
.end

.namespace ['MyClass']

.sub find_method :method :vtable
    .param string methodname
    print "find_method was called\n"
    $P0 = get_hll_global ["MyClass"], methodname
    .return($P0)
.end

.sub foo
  print "foo was called\n"
.end

CODE
find_method was called
foo was called
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "overloading attribute accessor vtable" );
.sub main :main
    .local pmc cl, o
    cl = newclass 'MyClass'
    o = new ['MyClass']
    $P2 = new ['String']
    $P2 = "blue"
    setattribute o, "blue", $P2
    $P1 = getattribute o, "blue"
.end

.namespace ['MyClass']

.sub get_attr_str :method :vtable
    .param string attrname
    print "get_attr_str was called\n"
.end
.sub set_attr_str :method :vtable
    .param string attrname
    .param pmc val
    print "set_attr_str was called\n"
.end
CODE
set_attr_str was called
get_attr_str was called
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "overloading get_class vtable" );
.sub main :main
    .local pmc cl, o, cl2
    cl = newclass 'MyClass'
    o = new ['MyClass']
    cl2 = class o
.end

.namespace ['MyClass']

.sub get_class :method :vtable
    print "get_class was called\n"
.end

CODE
get_class was called
OUTPUT

pir_error_output_like( <<'CODE', <<'OUTPUT', "method called on non-object (RT #50440)" );
.namespace [ 'Foo' ]

.sub 'blah' :method
.end

.namespace []

.sub main :main
    $P1 = get_hll_global 'Foo'
    $P0 = $P1.'new'()
.end
CODE
/Method 'new' not found for non-object/
OUTPUT

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
