cvsuser 04/05/17 14:09:08
Modified: src objects.c
t/pmc object-meths.t
Log:
This patch makes the experimental "CALL__BUILD" the default behaviour for class
BUILD methods.
A fallback to an __init method is done if no BUILD property is set.
If the __init method does not exists,
no exception is thrown (like before), whereas now an exception is thrown if
you specify a BUILD property and the specified method does not exists.
A special case is if you set BUILD to an empty string, then no constructor is
called for the class, not even __init if it exists.
Revision Changes Path
1.91 +36 -1 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.90
retrieving revision 1.91
diff -u -w -r1.90 -r1.91
--- objects.c 27 Apr 2004 12:00:43 -0000 1.90
+++ objects.c 17 May 2004 21:09:04 -0000 1.91
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.90 2004/04/27 12:00:43 leo Exp $
+$Id: objects.c,v 1.91 2004/05/17 21:09:04 jrieks Exp $
=head1 NAME
@@ -482,6 +482,7 @@
void * __ptr;
} __ptr_u;
STRING *meth;
+ *meth_str = NULL;
#if 0
prop = VTABLE_getprop(interpreter, class, prop_str);
if (!VTABLE_defined(interpreter, prop))
@@ -509,6 +510,7 @@
PMC *classsearch_array = get_attrib_num(class_data, PCD_ALL_PARENTS);
PMC *parent_class;
INTVAL i, nparents;
+#if 0
int free_it;
static void *what = (void*)-1;
/*
@@ -527,6 +529,7 @@
Parrot_base_vtables[enum_class_delegate]->init(interpreter, object);
}
else {
+#endif
/*
* 1) if class has a CONSTRUCT property run it on the object
* no redispatch
@@ -538,6 +541,7 @@
STRING *meth_str;
PMC *meth = get_init_meth(interpreter, class,
CONST_STRING(interpreter, "CONSTRUCT"), &meth_str);
+ int default_meth;
if (meth) {
if (init)
Parrot_run_meth_fromc_args_save(interpreter, meth,
@@ -556,6 +560,16 @@
classsearch_array, i);
meth = get_init_meth(interpreter, parent_class,
CONST_STRING(interpreter, "BUILD"), &meth_str);
+ /* no method found and no BUILD property set? */
+ if (!meth && meth_str == NULL) {
+ /* use __init as fallback constructor method, if it exists */
+ meth_str = string_from_cstring(interpreter, "__init", 6);
+ meth = Parrot_find_method_with_cache(interpreter,
+ parent_class, meth_str);
+ default_meth = 1;
+ }
+ else
+ default_meth = 0;
if (meth) {
if (init)
Parrot_run_meth_fromc_args_save(interpreter, meth,
@@ -564,9 +578,23 @@
Parrot_run_meth_fromc_save(interpreter, meth,
object, meth_str);
}
+ else if (meth_str != NULL &&
+ string_length(interpreter, meth_str) != 0 && !default_meth) {
+ real_exception(interpreter, NULL, METH_NOT_FOUND,
+ "Class BUILD method ('%Ss') not found", meth_str);
+ }
}
meth = get_init_meth(interpreter, class,
CONST_STRING(interpreter, "BUILD"), &meth_str);
+ /* no method found and no BUILD property set? */
+ if (!meth && meth_str == NULL) {
+ /* use __init as fallback constructor method, if it exists */
+ meth_str = string_from_cstring(interpreter, "__init", 6);
+ meth = Parrot_find_method_with_cache(interpreter, class, meth_str);
+ default_meth = 1;
+ }
+ else
+ default_meth = 0;
if (meth) {
if (init)
Parrot_run_meth_fromc_args_save(interpreter, meth,
@@ -575,7 +603,14 @@
Parrot_run_meth_fromc_save(interpreter, meth,
object, meth_str);
}
+ else if (meth_str != NULL && string_length(interpreter, meth_str) != 0
+ && !default_meth) {
+ real_exception(interpreter, NULL, METH_NOT_FOUND,
+ "Class BUILD method ('%Ss') not found", meth_str);
}
+#if 0
+ }
+#endif
}
/*
1.18 +48 -6 parrot/t/pmc/object-meths.t
Index: object-meths.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/object-meths.t,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -w -r1.17 -r1.18
--- object-meths.t 10 Apr 2004 12:50:23 -0000 1.17
+++ object-meths.t 17 May 2004 21:09:08 -0000 1.18
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: object-meths.t,v 1.17 2004/04/10 12:50:23 leo Exp $
+# $Id: object-meths.t,v 1.18 2004/05/17 21:09:08 jrieks Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 19;
+use Parrot::Test tests => 21;
use Test::More;
output_like(<<'CODE', <<'OUTPUT', "callmethod - unknown method");
@@ -136,6 +136,52 @@
ok 2
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "disabling the constructor");
+ newclass P1, "Foo"
+ new P0, .PerlString
+ setprop P1, "BUILD", P0
+ find_type I1, "Foo"
+ new P3, I1
+ print "ok 1\n"
+ end
+.namespace ["Foo"]
+.pcc_sub __init:
+ print "nok ok!\n"
+ invoke P1
+CODE
+ok 1
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "specified constructor method does not exist");
+ newclass P1, "Foo"
+ new P0, .PerlString
+ set P0, "bar"
+ setprop P1, "BUILD", P0
+
+ newsub P20, .Exception_Handler, _handler
+ set_eh P20
+
+ find_type I1, "Foo"
+ new P3, I1
+ print "not ok 1\n"
+ end
+
+_handler:
+ print "catched it\n"
+ set S0, P5["_message"] # P5 is the exception object
+ print S0
+ print "\n"
+ end
+
+.namespace ["Foo"]
+.pcc_sub __init:
+ print "nok ok 2!\n"
+ invoke P1
+CODE
+catched it
+Class BUILD method ('bar') not found
+OUTPUT
+
output_is(<<'CODE', <<'OUTPUT', "constructor - init attr");
newclass P1, "Foo"
addattribute P1, ".i"
@@ -604,8 +650,6 @@
OUTPUT
};
-$ENV{"CALL__BUILD"} = "1";
-
output_is(<<'CODE', <<'OUTPUT', "constructor - parents BUILD");
new P10, .PerlString
set P10, "_new"
@@ -658,8 +702,6 @@
in sub
done
OUTPUT
-
-delete $ENV{"CALL__BUILD"};
output_is(<<'CODE', <<'OUTPUT', "same method name in two namespaces");
##PIR##
