Index: Source/Modules/perl5.cxx =================================================================== --- Source/Modules/perl5.cxx (revision 10377) +++ Source/Modules/perl5.cxx (working copy) @@ -68,7 +68,10 @@ static String *variable_tab = 0; static File *f_runtime = 0; +static File *f_runtime_h = 0; static File *f_header = 0; +static File *f_directors = 0; +static File *f_directors_h = 0; static File *f_wrappers = 0; static File *f_init = 0; static File *f_pm = 0; @@ -110,6 +113,9 @@ Printv(argc_template_string, "items", NIL); Clear(argv_template_string); Printv(argv_template_string, "ST(%d)", NIL); + /* will need to evaluate the viability of MI directors later */ + director_multiple_inheritance = 0; + director_language = 1; } /* Test to see if a type corresponds to something wrapped with a shadow class */ @@ -204,21 +210,51 @@ /* Initialize all of the output files */ String *outfile = Getattr(n, "outfile"); + String *outfile_h = Getattr(n, "outfile_h"); + { + Node *options = Getattr(Getattr(n, "module"), "options"); + if (options) { + if (Getattr(options, "directors")) { + allow_directors(); + } + if (Getattr(options, "dirprot")) { + allow_dirprot(); + } + } + } + f_runtime = NewFile(outfile, "w"); if (!f_runtime) { FileErrorDisplay(outfile); SWIG_exit(EXIT_FAILURE); } + + if (directorsEnabled()) { + if (!outfile_h) { + Printf(stderr, "Unable to determine outfile_h\n"); + SWIG_exit(EXIT_FAILURE); + } + f_runtime_h = NewFile(outfile_h, "w"); + if (!f_runtime_h) { + FileErrorDisplay(outfile_h); + SWIG_exit(EXIT_FAILURE); + } + } + f_init = NewString(""); f_header = NewString(""); f_wrappers = NewString(""); + f_directors_h = NewString(""); + f_directors = NewString(""); /* Register file targets with the SWIG file handler */ Swig_register_filebyname("header", f_header); Swig_register_filebyname("wrapper", f_wrappers); Swig_register_filebyname("runtime", f_runtime); Swig_register_filebyname("init", f_init); + Swig_register_filebyname("director", f_directors); + Swig_register_filebyname("director_h", f_directors_h); classlist = NewList(); @@ -237,6 +273,25 @@ Swig_banner(f_runtime); + if(directorsEnabled()) { + Printf(f_runtime, "#define SWIG_DIRECTORS\n"); + /* Emit initial director header and director code: */ + Swig_banner(f_directors_h); + Printf(f_directors_h, + "#ifndef SWIG_%s_WRAP_H_\n" + "#define SWIG_%s_WRAP_H_\n\n", + Getattr(n, "name"), + Getattr(n, "name")); + Printf(f_directors, + "\n\n" + "/* ---------------------------------------------------\n" + " * C++ director class methods\n" + " * --------------------------------------------------- */\n\n"); + if(outfile_h) + Printf(f_directors, "#include \"%s\"\n\n", Swig_file_filename(outfile_h)); + + } + Printf(f_runtime, "#define SWIGPERL\n"); Printf(f_runtime, "#define SWIG_CASTRANK_MODE\n"); @@ -324,6 +379,11 @@ /* emit wrappers */ Language::top(n); + if (directorsEnabled()) { + // Insert director runtime into the f_runtime file (make it occur before %header section) + Swig_insert_file("director.swg", f_runtime); + } + String *base = NewString(""); /* Dump out variable wrappers */ @@ -462,9 +522,24 @@ /* Close all of the files */ Dump(f_header, f_runtime); + if (directorsEnabled()) { + Dump(f_directors, f_runtime); + Dump(f_directors_h, f_runtime_h); + Printf(f_runtime_h, + "\n" + "#endif\n"); + Close(f_runtime_h); + Delete(f_runtime_h); + f_runtime_h = NULL; + Delete(f_directors); + f_directors = NULL; + Delete(f_directors_h); + f_directors_h = NULL; + } Dump(f_wrappers, f_runtime); Wrapper_pretty_print(f_init, f_runtime); Delete(f_header); + Delete(f_directors); Delete(f_wrappers); Delete(f_init); Close(f_runtime); @@ -506,6 +581,8 @@ int num_saved = 0; int num_arguments, num_required; int varargs = 0; + bool should_bless = false; + bool director_goop = false; if (Getattr(n, "sym:overloaded")) { overname = Getattr(n, "sym:overname"); @@ -526,6 +603,26 @@ Printv(f->def, "XS(", wname, ") {\n", "{\n", /* scope to destroy C++ objects before croaking */ NIL); + if (Strcmp(nodeType(n), "constructor") == 0 || + Getattr(n, "handled_as_constructor")) { + /* A better check for the "implicit first argument" functions is + * if this is a class method or not, but for now it only really + * matters for constructor calls. */ + if (!l || !Getattr(l, "arg:implicit")) { + Parm *proto; + SwigType *p_sv = NewString("SV"); + SwigType_add_pointer(p_sv); + proto = NewParm(p_sv, "proto"); + Delete(p_sv); + Setattr(proto, "arg:byname", "1"); + Setattr(proto, "arg:implicit", "1"); + Setattr(proto, "lname", "proto"); + set_nextSibling(proto, l); + l = proto; + } + should_bless = true; + } + emit_args(d, l, f); emit_attach_parmmaps(l, f); Setattr(n, "wrap:parms", l); @@ -657,10 +754,73 @@ Wrapper_add_localv(f, "_saved", "SV *", temp, NIL); } + if (is_member_director(n) && !is_smart_pointer() && + Cmp(nodeType(n), "destructor") != 0) { + Wrapper_add_local(f, "upcall", "bool upcall"); + /* This early attempt couldn't distinguish between $obj->method() + * and $obj->SUPER::method() and so was scrapped. Nevertheless, + * it seems like the "does the inner object implement a method?" + * question may pop up at some point. + * + * Wrapper_add_local(f, "director", "Swig::Director *director"); + * Printf(f->code, + * " director = dynamic_cast(arg1);\n" + * " if(director) {\n" + * " CV *ch_cv = GvCV(gv_fetchmeth(SvSTASH(SvRV(director->getSelf())), \"%s\", %d, -1));\n" + * " upcall = cv == ch_cv;\n" + * " warn(\"%%08p %%08p %%s\", cv, ch_cv, (upcall ? \"up\" : \"down\"));\n" + * " } else upcall = true;\n", + * name, Len(name)); + */ + /* I think for this test to be completely correct, it should be + * some form of an isa() test between inner and outer classes. + * for now, inequality passes testcases. + * + * if outer == inner then assume $obj->SUPER::method was + * requested. this may be a hack. */ + Append(f->code, + "{\n" + " Swig::Director *director = dynamic_cast(arg1);\n" + " if(director) {\n" + " HV *outer_stash = SvSTASH(SvRV(ST(0)));\n" + " HV *inner_stash = SvSTASH(SvRV(director->getSelf()));\n" + " upcall = outer_stash == inner_stash;\n" + " } else {\n"); + if (dirprot_mode() && !is_public(n)) { + /* the director class has added a ${method}SwigPublic. The + * the protection level must now be checked to see if we should + * use it. */ + Append(f->code, + " SWIG_Error(SWIG_RuntimeError, \"accessing protected member\");\n" + " SWIG_fail;\n" + ); + } else { + Append(f->code, + " upcall = false;\n" + ); + } + Append(f->code, + " }\n" + "}\n"); + director_goop = true; + Append(f->code, "try {\n"); + } + /* Now write code to make the function call */ emit_action(n, f); + if(director_goop) { + Append(f->code, + " } catch(Swig::DirectorRunException &e) {\n" + " sv_setsv(ERRSV, e.e_sv);\n" + " croak(Nullch);\n" + " } catch(Swig::DirectorException &e) {\n" + " croak(\"%s\", e.getMessage());\n" + " }\n" + ); + } + if ((tm = Swig_typemap_lookup_new("out", n, "result", 0))) { SwigType *t = Getattr(n, "type"); Replaceall(tm, "$source", "result"); @@ -701,12 +861,40 @@ Printf(f->code, "%s\n", tm); } + if (should_bless) { + /* this is a bit of a hack, we are assuming that a constructor + * will always return the constructed object first, I think it's + * safe. */ + Append(f->code, + "{\n" + " HV *stash = gv_stashsv(proto, 0);\n"); + if(Swig_directorclass(n) && Getattr(parentNode(n), "abstract")) { + Printf(f->code, + "if(stash == gv_stashpvn(\"%s\", %d, 0)) {\n" + " croak(\"Attempt to instantiate pure abstract class\");\n" + "}\n", + fullclassname, Len(fullclassname)); + } + Append(f->code, + " sv_bless(ST(0), stash);\n"); + if (Swig_directorclass(n)) { + Append(f->code, + " {\n" + " Swig::Director *director = dynamic_cast(result);\n" + " if(director) director->setSelf(ST(0));\n" + " }\n"); + } + Append(f->code, + "}\n"); + } + Printv(f->code, "XSRETURN(argvi);\n", "fail:\n", cleanup, "SWIG_croak_null();\n" "}\n" "}\n", NIL); /* Add the dXSARGS last */ Wrapper_add_local(f, "dXSARGS", "dXSARGS"); + /* Substitute the cleanup code */ Replaceall(f->code, "$cleanup", cleanup); Replaceall(f->code, "$symname", iname); @@ -1030,6 +1218,345 @@ } /* ---------------------------------------------------------------------------- + * a (sloppy) crack at Directors + * ------------------------------------------------------------------------- */ +// int classDirector(Node *n) { +// return Language::classDirector(n); +// } + int classDirectorInit(Node *n) { + String *declaration = Swig_director_declaration(n); + Printf(f_directors_h, "%s\n public:\n", declaration); + Delete(declaration); + return Language::classDirectorInit(n); + } +// int classDirectorConstructors(Node *n) { +// return Language::classDirectorConstructors(n); +// } + int classDirectorConstructor(Node *n) { + String *name = NewStringf("SwigDirector_%s", + Getattr(parentNode(n), "sym:name")); + ParmList *parms = Getattr(n, "parms"); + String *mdecl = NewStringf(""); + String *mdefn = NewStringf(""); + String *signature; + + { /* resolve the function signature */ + ParmList *oparms; + SwigType *p_sv = NewString("SV"); + SwigType_add_pointer(p_sv); + oparms = NewParm(p_sv, "proto"); + Delete(p_sv); + set_nextSibling(oparms, parms); + signature = Swig_method_decl(Getattr(n, "type"), + Getattr(n, "decl"), "$name", oparms, 0, 0); + set_nextSibling(oparms, NULL); + Delete(oparms); + } + { /* prep method decl */ + String *target = Copy(signature); + Replaceall(target, "$name", name); + Printf(mdecl, " %s;\n", target); + Delete(target); + } + { /* prep method defn */ + String *qname; + String *target; + String *scall; + qname = NewStringf("%s::%s", name, name); + target = Copy(signature); + Replaceall(target, "$name", qname); + Delete(qname); + scall = Swig_csuperclass_call(0, + Getattr(parentNode(n), "classtype"), parms); + Printf(mdefn, + "%s : %s, Swig::Director() {\n" + "}\n", + target, scall); + Delete(target); + Delete(scall); + } + Dump(mdecl, f_directors_h); + Dump(mdefn, f_directors); + Delete(signature); + Delete(mdecl); + Delete(mdefn); + return Language::classDirectorConstructor(n); + } +// int classDirectorDefaultConstructor(Node *n) { +// return Language::classDirectorDefaultConstructor(n); +// } +// int classDirectorDestructor(Node *n) { +// return Language::classDirectorDestructor(n); +// } +// int classDirectorMethods(Node *n) { +// return Language::classDirectorMethods(n); +// } + int classDirectorMethod(Node *n, Node *parent, String *super) { + SwigType *type = Getattr(n, "type"); + String *decl = Getattr(n, "decl"); + String *name = Getattr(n, "name"); + ParmList *parms = Getattr(n, "parms"); + String *mdecl = NewStringf(""); + String *mdefn = NewStringf(""); + String *signature; + bool output_director = true; + + { /* resolve the function signature */ + SwigType *ret_type = Getattr(n, "conversion_operator") ? NULL : type; + signature = Swig_method_decl(ret_type, decl, "$name", parms, 0, 0); + if(Getattr(n, "throw")) { /* prep throws() fragment */ + Parm *p = Getattr(n, "throws"); + String *tm; + bool needComma = false; + + Append(signature, " throw("); + Swig_typemap_attach_parms("throws", p, 0); + while(p) { + tm = Getattr(p, "tmap:throws"); + if(tm) { + String *tmp = SwigType_str(Getattr(p, "type"), NULL); + if(needComma) + Append(signature, ", "); + else + needComma = true; + Append(signature, tmp); + Delete(tmp); + Delete(tm); + } + p = nextSibling(p); + } + Append(signature, ")"); + } + } + { /* prep method decl */ + String *target = Copy(signature); + Replaceall(target, "$name", name); + Printf(mdecl, " virtual %s;\n", target); + Delete(target); + } + { /* prep method defn */ + String *qname; + String *target; + Wrapper *w; + int outputs = 0; + + if(SwigType_type(type) != T_VOID) outputs = 1; + + qname = NewStringf("SwigDirector_%s::%s", + Swig_class_name(parent), name); + target = Copy(signature); + Replaceall(target, "$name", qname); + Delete(qname); + + w = NewWrapper(); + Printf(w->def, "%s {", target); + { /* generate method body */ + char *retstmt = ""; + Wrapper_add_local(w, "SP", "dSP"); + Printf(w->code, + " ENTER;\n" + " SAVETMPS;\n" + " PUSHMARK(SP);\n" + " XPUSHs(this->Swig::Director::getSelf());\n"); + if(parms) { /* convert call parms */ + Parm *p; + String *tm; + + Wrapper_add_local(w, "argsv", "SV *argsv"); + for(p = parms; p; p = nextSibling(p)) { + /* really not sure why this is necessary but + * Swig_typemap_attach_parms() didn't expand $1 without it... */ + Setattr(p, "lname", Getattr(p, "name")); + } + /* no clue why python checks the "in" typemaps, I imagine I'll + * figure out soon enough once I have testcases runnning. + * "out" typemaps might be a fallback attempt, but "in"? */ + /*Swig_typemap_attach_parms("in", parms, w);*/ + Swig_typemap_attach_parms("directorin", parms, w); + Swig_typemap_attach_parms("directorargout", parms, w); + for(p = parms; p; ) { + SwigType *ptype = Getattr(p, "type"); + if (Getattr(p, "tmap:directorargout") != NULL) outputs++; + tm = Getattr(p, "tmap:directorin"); + if(tm) { + Replaceall(tm, "$input", "argsv"); + Replaceall(tm, "$owner", "0"); + if (is_shadow(ptype)) + Replaceall(tm, "$shadow", "SWIG_SHADOW"); + else + Replaceall(tm, "$shadow", "0"); + Printf(w->code, + " %s\n" + " XPUSHs(argsv);\n", + tm); + p = Getattr(p, "tmap:directorin:next"); + Delete(tm); + } else { + if(SwigType_type(ptype) != T_VOID) { + Swig_warning(WARN_TYPEMAP_DIRECTORIN_UNDEF, + input_file, line_number, + "Unable to use type %s as a function argument " + "in director method %s (skipping method).\n", + SwigType_str(ptype, 0), target); + output_director = false; + } + p = nextSibling(p); + } + } + } + /* This whole G_ARRAY probably needs to be rethought. it overly + * complicates the code and I'm not sure it DWIMs the way any + * person should M. */ + Append(w->code, + " PUTBACK;\n" + ); + switch(outputs) { + case 0: + Printf(w->code, "call_method(\"%s\", G_EVAL | G_VOID);\n", name); + break; + case 1: + Wrapper_add_local(w, "w_count", "I32 w_count"); + Printf(w->code, "w_count = call_method(\"%s\", G_EVAL | G_SCALAR);\n", name); + break; + default: + Wrapper_add_local(w, "w_count", "I32 w_count"); + Printf(w->code, + "w_count = call_method(\"%s\", G_EVAL | G_ARRAY);\n" + "if(w_count != %d) {\n" + " croak(\"expected %d values in return from %%s->%s\",\n" + " SvPV_nolen(this->Swig::Director::getSelf()));\n" + "}\n", name, outputs, outputs, name); + break; + } + Printf(w->code, + "if(SvTRUE(ERRSV)) {\n" + " /* need to clean up the perl call stack here */\n" + " Swig::DirectorRunException::raise(ERRSV);\n" + "}\n", name); + if(outputs) { + SwigType *ret_type; + String *tm; + Parm *p; + char buf[256]; + int outnum = 0; + Wrapper_add_local(w, "ax", "I32 ax"); + { /* return value frobnication */ + ret_type = Copy(type); + SwigType *t = Copy(decl); + SwigType *f = SwigType_pop_function(t); + SwigType_push(ret_type, t); + Delete(f); + Delete(t); + } + Append(w->code, + " SPAGAIN;\n" + " SP -= w_count;\n" + " ax = (SP - PL_stack_base) + 1;\n"); + if(SwigType_type(type) != T_VOID) { + { + String *restype; + restype = SwigType_lstr(ret_type, "w_result"); + Wrapper_add_local(w, "w_result", restype); + Delete(restype); + } + p = NewParm(ret_type, "w_result"); + tm = Swig_typemap_lookup_new("directorout", p, "w_result", w); + if(!tm) { + Swig_warning(WARN_TYPEMAP_DIRECTOROUT_UNDEF, + input_file, line_number, + "Unable to use return type %s " + "in director method %s (skipping method).\n", + SwigType_str(type, 0), target); + output_director = false; + } + Delete(p); + sprintf(buf, "ST(%d)", outnum++); + Replaceall(tm, "$result", "w_result"); + Replaceall(tm, "$input", buf); +// if (Getattr(p, "wrap:disown") || (Getattr(p, "tmap:out:disown"))) { +// Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN"); +// } else { + Replaceall(tm, "$disown", "0"); +// } + Printf(w->code, "%s\n", tm); + Delete(tm); + if(SwigType_isreference(ret_type)) + retstmt = " return *w_result;\n"; + else + retstmt = " return w_result;\n"; + } + /* now handle directorargout... */ + for(p = parms; p; ) { + tm = Getattr(p, "tmap:directorargout"); + if(tm) { + sprintf(buf, "ST(%d)", outnum++); + Replaceall(tm, "$input", buf); + Replaceall(tm, "$result", Getattr(p, "name")); + Printf(w->code, "%s\n", tm); + p = Getattr(p, "tmap:directorargout:next"); + } else { + p = nextSibling(p); + } + } + if(outnum != outputs) { + Swig_warning(WARN_TYPEMAP_DIRECTOROUT_UNDEF, + input_file, line_number, + "expected %d outputs, but found %d typemaps " + "in director method %s (skipping method).\n", + outputs, outnum, target); + output_director = false; + } + Append(w->code, "PUTBACK;\n"); + Delete(ret_type); + } + Printf(w->code, + " FREETMPS;\n" + " LEAVE;\n" + "%s}", retstmt); + } + Delete(target); + Wrapper_print(w, mdefn); + } + + /* borrowed from python.cxx - director.cxx apparently expects us + * to emit a "${methodname}SwigPublic" at times */ + if (dirprot_mode() && !is_public(n)) { + if(Cmp(Getattr(n, "storage"), "virtual") || + Cmp(Getattr(n, "value"), "0")) { + /* not pure virtual */ + String *target = Copy(signature); + String *einame = NewStringf("%sSwigPublic", name); + const char *returns = SwigType_type(type) != T_VOID ? "return " : ""; + String *upcall = Swig_method_call(super, parms); + Replaceall(target, "$name", einame); + Printf(mdecl, + " virtual %s {\n" + " %s%s;\n" + " }\n", target, returns, upcall); + Delete(upcall); + Delete(target); + } + } + + if(output_director) { + Dump(mdecl, f_directors_h); + Dump(mdefn, f_directors); + } + Delete(mdecl); + Delete(mdefn); + + return Language::classDirectorMethod(n, parent, super); + } + int classDirectorEnd(Node *n) { + Printf(f_directors_h, + "};\n"); + return Language::classDirectorEnd(n); + } +// int classDirectorDisown(Node *n) { +// return Language::classDirectorDisown(n); +// } + +/* ---------------------------------------------------------------------------- * OBJECT-ORIENTED FEATURES * * These extensions provide a more object-oriented interface to C++ @@ -1407,10 +1934,41 @@ virtual int constructorHandler(Node *n) { String *symname = Getattr(n, "sym:name"); + int use_director = Swig_directorclass(n); + String *nc_saved = NULL; member_func = 1; + + if (use_director) { + nc_saved = none_comparison; + /* this definition is a bit sloppy, it should probably be a + * function call dropped in the swig runtime to do better + * inspection. For now this works. */ + none_comparison = NewStringf( + "!strEQ(SvPV_nolen(proto), \"%s\") && sv_derived_from(proto, \"%s\")", + fullclassname, fullclassname); + } + if(use_director) { + ParmList *l = Getattr(n, "parms"); + Parm *proto; + SwigType *p_sv = NewString("SV"); + SwigType_add_pointer(p_sv); + proto = NewParm(p_sv, "proto"); + Delete(p_sv); + Setattr(proto, "arg:byname", "1"); + Setattr(proto, "arg:implicit", "1"); + Setattr(proto, "lname", "proto"); + set_nextSibling(proto, l); + Setattr(n, "parms", proto); + } + Language::constructorHandler(n); + if(nc_saved) { + Delete(none_comparison); + none_comparison = nc_saved; + } + if ((blessed) && (!Getattr(n, "sym:nextSibling"))) { if (Getattr(n, "feature:shadow")) { String *plcode = perlcode(Getattr(n, "feature:shadow"), 0); @@ -1419,19 +1977,15 @@ Delete(plaction); Printv(pcode, plcode, NIL); } else { - if ((Cmp(symname, class_name) == 0)) { - /* Emit a blessed constructor */ - Printf(pcode, "sub new {\n"); - } else { - /* Constructor doesn't match classname so we'll just use the normal name */ - Printv(pcode, "sub ", Swig_name_construct(symname), " () {\n", NIL); - } - - Printv(pcode, - tab4, "my $pkg = shift;\n", - tab4, "my $self = ", cmodule, "::", Swig_name_construct(symname), "(@_);\n", tab4, "bless $self, $pkg if defined($self);\n", "}\n\n", NIL); - - have_constructor = 1; + /* hoisting constructors to C/C++ */ + if ((Cmp(symname, class_name) == 0)) { + /* Emit a blessed constructor */ + Printv(pcode, "*", "new", " = *", cmodule, "::", Swig_name_construct(symname), ";\n", NIL); + } else { + /* Constructor doesn't match classname so we'll just use the normal name */ + Printv(pcode, "*", Swig_name_construct(symname), " = *", cmodule, "::", Swig_name_construct(symname), ";\n", NIL); + } + have_constructor = 1; } } member_func = 0; Index: Source/Swig/cwrap.c =================================================================== --- Source/Swig/cwrap.c (revision 10377) +++ Source/Swig/cwrap.c (working copy) @@ -188,7 +188,7 @@ int compactdefargs = ParmList_is_compactdefargs(p); while (p != 0) { - String *lname = Swig_cparm_name(p, i); + String *lname; SwigType *pt = Getattr(p, "type"); if ((SwigType_type(pt) != T_VOID)) { String *local = 0; @@ -197,6 +197,15 @@ String *pvalue = (compactdefargs) ? Getattr(p, "value") : 0; SwigType *altty = SwigType_alttype(type, 0); int tycode = SwigType_type(type); + if (!Getattr(p, "arg:implicit")) { + lname = Swig_cparm_name(p, i); + i++; + } else { + if ((lname = Getattr(p, "value"))) + lname = Copy(lname); + else + lname = Copy(Getattr(p, "name")); + } if (tycode == T_REFERENCE) { if (pvalue) { SwigType *tvalue; @@ -236,9 +245,8 @@ } Wrapper_add_localv(w, lname, local, NIL); Delete(local); - i++; + Delete(lname); } - Delete(lname); p = nextSibling(p); } return (i); @@ -495,9 +503,11 @@ Parm *p = parms; SwigType *pt; if (skip_self) { - if (p) + if (p) { + if(!Getattr(p, "arg:implicit")) i++; p = nextSibling(p); - i++; + } else + i++; } nname = SwigType_namestr(name); func = NewStringEmpty(); Index: Lib/perl5/perltypemaps.swg =================================================================== --- Lib/perl5/perltypemaps.swg (revision 10377) +++ Lib/perl5/perltypemaps.swg (working copy) @@ -35,9 +35,9 @@ * Unified typemap section * ------------------------------------------------------------ */ -/* No director supported in Perl */ -#ifdef SWIG_DIRECTOR_TYPEMAPS -#undef SWIG_DIRECTOR_TYPEMAPS +/* director support in Perl is experimental */ +#ifndef SWIG_DIRECTOR_TYPEMAPS +#define SWIG_DIRECTOR_TYPEMAPS #endif Index: Lib/perl5/perlrun.swg =================================================================== --- Lib/perl5/perlrun.swg (revision 10377) +++ Lib/perl5/perlrun.swg (working copy) @@ -17,7 +17,8 @@ /* Common SWIG API */ /* for raw pointers */ -#define SWIG_ConvertPtr(obj, pp, type, flags) SWIG_Perl_ConvertPtr(SWIG_PERL_OBJECT_CALL obj, pp, type, flags) +#define SWIG_ConvertPtr(obj, pp, type, flags) SWIG_Perl_ConvertPtrAndOwn(SWIG_PERL_OBJECT_CALL obj, pp, type, flags, 0) +#define SWIG_ConvertPtrAndOwn(obj,pp,type,flags,own) SWIG_Perl_ConvertPtrAndOwn(SWIG_PERL_OBJECT_CALL obj, pp, type, flags, own) #define SWIG_NewPointerObj(p, type, flags) SWIG_Perl_NewPointerObj(SWIG_PERL_OBJECT_CALL p, type, flags) /* for raw packed data */ @@ -215,7 +216,7 @@ /* Function for getting a pointer value */ SWIGRUNTIME int -SWIG_Perl_ConvertPtr(SWIG_MAYBE_PERL_OBJECT SV *sv, void **ptr, swig_type_info *_t, int flags) { +SWIG_Perl_ConvertPtrAndOwn(SWIG_MAYBE_PERL_OBJECT SV *sv, void **ptr, swig_type_info *_t, int flags, SV **own) { swig_cast_info *tc; void *voidptr = (void *)0; SV *tsv = 0; @@ -223,6 +224,7 @@ if (SvGMAGICAL(sv)) mg_get(sv); + if(own) *own = sv; /* Check to see if this is an object */ if (sv_isobject(sv)) { IV tmp = 0; Index: Lib/perl5/director.swg =================================================================== --- Lib/perl5/director.swg (revision 0) +++ Lib/perl5/director.swg (revision 0) @@ -0,0 +1,136 @@ +/* ----------------------------------------------------------------------------- + * See the LICENSE file for information on copyright, usage and redistribution + * of SWIG, and the README file for authors - http://www.swig.org/release.html. + * + * director.swg + * + * This file contains support for director classes that proxy + * method calls from C++ to Perl extensions. + * ----------------------------------------------------------------------------- */ + +#ifdef __cplusplus + +#include +#include +#include + +#define swig_owntype SV * + +namespace Swig { + + /* base class for director exceptions */ + class DirectorException { + protected: + std::string e_msg; + public: + DirectorException(const char* msg="") : e_msg(msg) { } + const char *getMessage() const { + return e_msg.c_str(); + } + virtual ~DirectorException() {} + }; + + /* type mismatch in the return value from a python method call */ + class DirectorTypeMismatchException : public DirectorException { + public: + std::string e_type; + DirectorTypeMismatchException(const char* type, const char* msg="") : + e_type(type) { + e_msg = "type mismatch "; + e_msg += msg; + } + static void raise(const char* type, const char *msg) { + throw DirectorTypeMismatchException(type, msg); + } + }; + + /* attempt to call a pure virtual method via a director method */ + class DirectorPureVirtualException : public DirectorException { + public: + DirectorPureVirtualException(const char *msg) { + e_msg = msg; + e_msg += " is abstract"; + } + static void raise(const char *msg) { + throw DirectorPureVirtualException(msg); + } + }; + + /* Perl exceptions generated during director methods get wrapped for + * their journey though C++ */ + class DirectorRunException : public DirectorException { + public: + SV *e_sv; + DirectorRunException(SV *err) : + DirectorException(SvPV_nolen(err)), e_sv(err) { } + static void raise(SV *err) { + throw DirectorRunException(err); + } + }; + + /* director base class */ + class Director { + private: + SV *mSelf; + bool mDisowned; + AV *mOwned; + + /* TODO: understand ownership handling */ + /* working assumption: a "disowned" director must keep the perl + * self SV alive manually because + * C++ holds director and director must hold the sv. + * but an "owned" one must not hold a reference it's sv because + * the perl interpreter will expect it to fall out when it lets + * go. + */ + public: + Director() : mSelf(NULL), mDisowned(false), mOwned(newAV()) { + } + virtual ~Director() { + if(mDisowned) + SvREFCNT_dec(mSelf); + av_undef(mOwned); + } + void setSelf(SV *self) { + if(mSelf) croak("can not recycle directors"); + if(!self || !SvOK(self)) croak("refusing to wrap bogus perl val"); + mSelf = newSVsv(self); + sv_rvweaken(mSelf); +// do_sv_dump(0, Perl_debug_log, mSelf, 0, 0, false, 0); + } + SV *getSelf() const { + if(!mSelf || !SvOK(mSelf)) { + croak("director has no identity %p(%p) %c", + this, mSelf, mDisowned ? 't' : 'f'); + } + return mSelf; + } + void swig_disown() { + if(mDisowned) return; + mDisowned = true; + // our weak ref should become a hard ref now. + // don't know how to unweaken, but I can create a stong copy. + sv_2mortal(mSelf); + mSelf = newSVrv(SvRV(mSelf), NULL); + SvREFCNT_inc(mSelf); + warn("disowning %s and I don't know why", SvPV_nolen(mSelf)); + } + void swig_acquire_ownership_obj(void *vptr, SV *own) const { + warn("acquiring ownership obj 0x%08p %s", vptr, SvPV_nolen(own)); + //warn(">|> %d\n", SvREFCNT(own)); + av_push(mOwned, own); + //warn(">|> %d\n", SvREFCNT(own)); + } + void swig_acquire_ownership_array(void *vptr) const { + warn("acquiring ownership array 0x%08p", vptr); + } + void swig_acquire_ownership(void *vptr) const { + warn("acquiring ownership 0x%08p", vptr); + } + int swig_release_ownership(void *vptr) const { + warn("swig_release_ownership 0x%08p", vptr); + } + }; +} + +#endif /* __cplusplus */ Index: Examples/test-suite/perl5/director_detect_runme.pl =================================================================== --- Examples/test-suite/perl5/director_detect_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_detect_runme.pl (revision 0) @@ -0,0 +1,45 @@ +use strict; +use warnings; +use director_detect; + +{ + package MyBar; + use base 'director_detect::Bar'; + # workaround until attributes work. + our %val; + sub new { my $class = shift; + my $val = @_ ? shift : 2; + my $self = $class->SUPER::new(); + $val{$self} = $val; + return $self; + } + sub get_value { my($self) = @_; + $val{$self}++; + return $val{$self}; + } + sub get_class { my($self) = @_; + $val{$self}++; + return director_detect::A->new(); + } + sub just_do_it { my($self) = @_; + $val{$self}++; + } + sub clone { my($self) = @_; + MyBar->new($val{$self}); + } +} + +my $b = MyBar->new(); + +my $f = $b->baseclass(); + +my $v = $f->get_value(); +my $a = $f->get_class(); +$f->just_do_it(); + +my $c = $b->clone(); +my $vc = $c->get_value(); + +if( ($v != 3) or ($MyBar::val{$b} != 5) or ($vc != 6) ) { + die "Bad virtual detection"; +} Property changes on: Examples/test-suite/perl5/director_detect_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_unroll_runme.pl =================================================================== --- Examples/test-suite/perl5/director_unroll_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_unroll_runme.pl (revision 0) @@ -0,0 +1,19 @@ +use strict; +use warnings; +use director_unroll; + +{ + package MyFoo; + use base 'director_unroll::Foo'; + sub ping { "MyFoo::ping()" } +} + +$a = MyFoo->new(); + +$b = director_unroll::Bar->new(); + +$b->set($a); +my $c = $b->get(); + +die "RuntimeError" unless + $a->this ne $c->this; Property changes on: Examples/test-suite/perl5/director_unroll_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_primitives_runme.pl =================================================================== --- Examples/test-suite/perl5/director_primitives_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_primitives_runme.pl (revision 0) @@ -0,0 +1,65 @@ +use strict; +use warnings; +use director_primitives; + +{ + package PerlDerived; + use base 'director_primitives::Base'; + sub NoParmsMethod { + } + sub BoolMethod { my($self, $x) = @_; + return $x; + } + sub IntMethod { my($self, $x) = @_; + return $x; + } + sub UIntMethod { my($self, $x) = @_; + return $x; + } + sub FloatMethod { my($self, $x) = @_; + return $x; + } + sub CharPtrMethod { my($self, $x) = @_; + return $x; + } + sub ConstCharPtrMethod { my($self, $x) = @_; + return $x; + } + sub EnumMethod { my($self, $x) = @_; + return $x; + } + sub ManyParmsMethod { + } +} + +my $myCaller = director_primitives::Caller->new(); + +{ + my $myBase = director_primitives::Base->new(100.0); + makeCalls($myCaller, $myBase); +} +{ + my $myBase = director_primitives::Derived->new(200.0); + makeCalls($myCaller, $myBase); +} +{ + my $myBase = PerlDerived->new(300.0); + makeCalls($myCaller, $myBase); +} + +sub makeCalls { my($myCaller, $myBase) = @_; + $myCaller->set($myBase); + $myCaller->NoParmsMethodCall(); + die "failed" unless $myCaller->BoolMethodCall(1); + die "failed" if $myCaller->BoolMethodCall(0); + die "failed" if $myCaller->IntMethodCall(-123) != -123; + die "failed" if $myCaller->UIntMethodCall(123) != 123; + die "failed" if $myCaller->FloatMethodCall(-123 / 128) != -0.9609375; + die "failed" if $myCaller->CharPtrMethodCall("test string") ne "test string"; + die "failed" if $myCaller->ConstCharPtrMethodCall("another string") ne "another string"; + die "failed" if $myCaller->EnumMethodCall($director_primitives::HShadowHard) != $director_primitives::HShadowHard; + $myCaller->ManyParmsMethodCall(1, -123, 123, 123.456, "test string", "another string", $director_primitives::HShadowHard); + $myCaller->NotOverriddenMethodCall(); + $myCaller->reset(); +} + Property changes on: Examples/test-suite/perl5/director_primitives_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_exception_runme.pl =================================================================== --- Examples/test-suite/perl5/director_exception_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_exception_runme.pl (revision 0) @@ -0,0 +1,41 @@ +use strict; +use warnings; +use director_exception; + +{ + package MyFoo; + use base 'director_exception::Foo'; + sub ping { + die "MyFoo::ping() EXCEPTION"; + } +} +{ + package MyFoo2; + use base 'director_exception::Foo'; + sub ping { + # error should return a string + return sub { 1 }; + } +} + +my $ok = 0; + +my $a = MyFoo->new(); +my $b = director_exception::launder($a); + +eval { $b->pong() }; +die "should have thrown" unless $@; +die "error content not preserved" unless $@ =~ /\bMyFoo::ping\(\) EXCEPTION\b/; + +$ok = 0; + +$a = MyFoo2->new(); +$b = director_exception::launder($a); + +eval { $b->pong() }; +die "should have thrown" unless $@; +die "error content not preserved" unless $@ =~ /\bstd::string\b/; + +eval { die director_exception::Exception2->new() }; + +eval { die director_exception::Exception1->new() }; Property changes on: Examples/test-suite/perl5/director_exception_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_enum_runme.pl =================================================================== --- Examples/test-suite/perl5/director_enum_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_enum_runme.pl (revision 0) @@ -0,0 +1,17 @@ +use strict; +use warnings; +use director_enum; + +{ + package MyFoo; + use base 'director_enum::Foo'; + sub say_hi { my($self, $val) = @_; + return $val; + } +} + +my $b = director_enum::Foo->new(); +my $a = MyFoo->new(); + +die "RuntimeError" if $a->say_hi($director_enum::hello) != + $a->say_hello($director_enum::hi); Property changes on: Examples/test-suite/perl5/director_enum_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/profiletest_runme.pl =================================================================== --- Examples/test-suite/perl5/profiletest_runme.pl (revision 10377) +++ Examples/test-suite/perl5/profiletest_runme.pl (working copy) @@ -1,6 +1,6 @@ use profiletest; -$a = profiletestc::new_A(); -$b = profiletestc::new_B(); +$a = profiletestc->new_A(); +$b = profiletestc->new_B(); for ($i = 0; $i < 100000; $i++) { $a = profiletestc::B_fn($b, $a); Index: Examples/test-suite/perl5/director_string_runme.pl =================================================================== --- Examples/test-suite/perl5/director_string_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_string_runme.pl (revision 0) @@ -0,0 +1,33 @@ +use strict; +use warnings; +use director_string; + +{ + package B; + use base 'director_string::A'; + our $in_first = 0; + sub get_first { my($self) = @_; + die "SUPER RESOLVE BAD" if $in_first; + local $in_first = 1; + return $self->SUPER::get_first() . " world!"; + } + our %smem; + our $in_process_text = 0; + sub process_text { my($self, $string) = @_; + die "SUPER RESOLVE BAD" if $in_process_text; + local $in_process_text = 1; + $self->SUPER::process_text($string); + $smem{$self} = "hello"; + } +} + +my $b = B->new("hello"); + +$b->get(0); + +die "RuntimeError" if + $b->get_first() ne "hello world!"; + +$b->call_process_func(); + +die "RuntimeError" if $B::smem{$b} ne "hello"; Property changes on: Examples/test-suite/perl5/director_string_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_basic_runme.pl =================================================================== --- Examples/test-suite/perl5/director_basic_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_basic_runme.pl (revision 0) @@ -0,0 +1,99 @@ +use strict; +use warnings; +use director_basic; + +{ + package PlFoo; + use base 'director_basic::Foo'; + sub ping { my($self) = @_; + return "PlFoo::ping()"; + } +} + +my $a = PlFoo->new(); + +die $a->ping() if $a->ping() ne 'PlFoo::ping()'; + +die $a->pong() if $a->pong() ne 'Foo::pong();PlFoo::ping()'; + +$b = director_basic::Foo->new(); + +die $b->ping() if $b->ping() ne 'Foo::ping()'; + +die $b->pong() if $b->pong() ne 'Foo::pong();Foo::ping()'; + +$a = director_basic::A1->new(1); + +die "RuntimeError" if $a->rg(2) != 2; + + +{ + package PlClass; + use base 'director_basic::MyClass'; + our %cmethod; + sub method { my($self, $vptr) = @_; + # custom subclass attributes are broken for now. (cheating) + $cmethod{$self} = 7; + } + sub vmethod { my($self, $b) = @_; + $b->{x} = $b->{x} + 31; + return $b; + } +} + +$b = director_basic::Bar->new(3); + +my $d = director_basic::MyClass->new(); +my $c = PlClass->new(); + +my $cc = $c->director_basic::MyClass::get_self(); +my $dd = $d->director_basic::MyClass::get_self(); + +my $bc = $cc->cmethod($b); +my $bd = $dd->cmethod($b); + +$cc->method($b); +# custom subclass attributes are broken for now. (cheating) +die "RuntimeError" if $PlClass::cmethod{$c} != 7; + +die "RuntimeError" if $bc->{x} != 34; + +die "RuntimeError" if $bd->{x} != 16; + + +## no multiple inheritance support yet. +## +##class PyMulti(director_basic.Foo, director_basic.MyClass): +## def __init__(self): +## director_basic.Foo.__init__(self) +## director_basic.MyClass.__init__(self) +## pass +## +## +## def vmethod(self, b): +## b.x = b.x + 31 +## return b +## +## +## def ping(self): +## return "PyFoo::ping()" +## +##a = 0 +##for i in range(0,100): +## pymult = PyMulti() +## pymult.pong() +## del pymult +## +## +## +##pymult = PyMulti() +## +## +## +## +##p1 = director_basic.Foo_get_self(pymult) +##p2 = director_basic.MyClass_get_self(pymult) +## +##p1.ping() +##p2.vmethod(bc) +## Property changes on: Examples/test-suite/perl5/director_basic_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_nested_runme.pl =================================================================== --- Examples/test-suite/perl5/director_nested_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_nested_runme.pl (revision 0) @@ -0,0 +1,56 @@ +use strict; +use warnings; +use director_nested; + +{ + package A; + use base 'director_nested::FooBar_int'; + sub do_step { 'A::do_step;' } + sub get_value { 'A::get_value' } +} + +my $a = A->new(); +die "Bad A virtual resolution" if + $a->step() ne "Bar::step;Foo::advance;Bar::do_advance;A::do_step;"; + +{ + package B; + use base 'director_nested::FooBar_int'; + sub do_advance { my($self) = @_; + return "B::do_advance;" . $self->do_step(); + } + sub do_step { "B::do_step;" } + sub get_value { 1 } +} + +my $b = B->new(); + +die "Bad B virtual resolution" if + $b->step() ne "Bar::step;Foo::advance;B::do_advance;B::do_step;"; + +{ + package C; + use base 'director_nested::FooBar_int'; + our $in_do_advance = 0; + sub do_advance { my($self) = @_; + # found a case where upcall didn't happen right in a perl space + # SUPER:: call. + die "SUPERCALL RESOLVE FAILURE" if $in_do_advance; + local $in_do_advance = 1; + return "C::do_advance;" . + $self->SUPER::do_advance(); + } + sub do_step { "C::do_step;" } + sub get_value { 2 } + sub get_name { my($self) = @_; + return $self->director_nested::FooBar_int::get_name() . " hello"; + } +} + +my $cc = C->new(); +my $c = $cc->director_nested::FooBar_int::get_self(); +$c->advance(); + +die "RuntimeError" if $c->get_name() ne "FooBar::get_name hello"; + +die "RuntimeError" if $c->name() ne "FooBar::get_name hello"; Property changes on: Examples/test-suite/perl5/director_nested_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_ignore_runme.pl =================================================================== --- Examples/test-suite/perl5/director_ignore_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_ignore_runme.pl (revision 0) @@ -0,0 +1,21 @@ +use strict; +use warnings; +use director_ignore; + +{ + package DIgnoresDerived; + use base 'director_ignore::DIgnores'; +} +{ + package DAbstractIgnoresDerived; + use base 'director_ignore::DAbstractIgnores'; +} + +my $a = DIgnoresDerived->new(); + +die "Triple failed" if $a->Triple(5) != 15; + +my $b = DAbstractIgnoresDerived->new(); + +die "Quadruple failed" if $b->Quadruple(5) != 20; + Property changes on: Examples/test-suite/perl5/director_ignore_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_default_runme.pl =================================================================== --- Examples/test-suite/perl5/director_default_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_default_runme.pl (revision 0) @@ -0,0 +1,11 @@ +use strict; +use warnings; +use director_default; + + +my $f = director_default::Foo->new(); +$f = director_default::Foo->new(1); + + +$f = director_default::Bar->new(); +$f = director_default::Bar->new(1); Property changes on: Examples/test-suite/perl5/director_default_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_constructor_runme.pl =================================================================== --- Examples/test-suite/perl5/director_constructor_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_constructor_runme.pl (revision 0) @@ -0,0 +1,20 @@ +use strict; +use warnings; +use director_constructor; + +{ + package Test; + use base 'director_constructor::Foo'; + sub doubleit { my($self) = @_; + $self->{a} *= 2; + } + sub test { 3 } +} +my $a = Test->new(5); + +die "RuntimeError" if $a->getit != 5; +die "RuntimeError" if $a->do_test != 3; + +$a->doubleit(); + +die "RuntimeError" if $a->getit != 10; Property changes on: Examples/test-suite/perl5/director_constructor_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_extend_runme.pl =================================================================== --- Examples/test-suite/perl5/director_extend_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_extend_runme.pl (revision 0) @@ -0,0 +1,18 @@ +# Test case from bug #1506850 +#"When threading is enabled, the interpreter will infinitely wait on a mutex the second +#time this type of extended method is called. Attached is an example +#program that waits on the mutex to be unlocked." +use strict; +use warnings; +use director_extend; +# I don't think this test applies to perl, but including for completness + +{ + package MyObject; + use base 'director_extend::SpObject'; + sub getFoo { 123 } +} + +my $m = MyObject->new(); +die "1st call" if $m->dummy() != 666; +die "2nd call" if $m->dummy() != 666; # Locked system Property changes on: Examples/test-suite/perl5/director_extend_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_frob_runme.pl =================================================================== --- Examples/test-suite/perl5/director_frob_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_frob_runme.pl (revision 0) @@ -0,0 +1,9 @@ +use strict; +use warnings; +use director_frob; + +my $foo = director_frob::Bravo->new(); + +my $s = $foo->abs_method(); + +die "RuntimeError: $s" if $s ne "Bravo::abs_method()"; Property changes on: Examples/test-suite/perl5/director_frob_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_wombat_runme.pl =================================================================== --- Examples/test-suite/perl5/director_wombat_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_wombat_runme.pl (revision 0) @@ -0,0 +1,47 @@ +use strict; +use warnings; +use director_wombat; + +{ + package director_wombat_Foo_integers_derived; + use base 'director_wombat::Foo_integers'; + sub meth { my($self, $param) = @_; + return $param + 2; + } +} +{ + package director_wombat_Foo_integers_derived_2; + use base 'director_wombat::Foo_integers'; +} +{ + package director_wombat_Bar_derived_1; + use base 'director_wombat::Bar'; + sub foo_meth_ref { my($self, $foo_obj, $param) = @_; + die "foo_obj in foo_meth_ref is not director_wombat_Foo_integers_derived_2" + unless $foo_obj->isa('director_wombat_Foo_integers_derived_2'); + } + sub foo_meth_ptr { my($self, $foo_obj, $param) = @_; + die "foo_obj in foo_meth_ptr is not director_wombat_Foo_integers_derived_2" + unless $foo_obj->isa('director_wombat_Foo_integers_derived_2'); + } + sub foo_meth_val { my($self, $foo_obj, $param) = @_; + die "foo_obj in foo_meth_val is not director_wombat_Foo_integers_derived_2" + unless $foo_obj->isa('director_wombat_Foo_integers_derived_2'); + } +} + +my $b = director_wombat::Bar->new(); +my $a = $b->meth(); +die "failure" if $a->meth(49) != 49; + +$a = director_wombat_Foo_integers_derived->new(); +die "failure" if $a->meth(62) != 62 + 2; + +$a = director_wombat_Foo_integers_derived_2->new(); +die "failure" if $a->meth(37) != 37; + +$b = director_wombat_Bar_derived_1->new(); +$b->foo_meth_ref($a, 0); +$b->foo_meth_ptr($a, 1); +$b->foo_meth_val($a, 2); + Property changes on: Examples/test-suite/perl5/director_wombat_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/director_protected_runme.pl =================================================================== --- Examples/test-suite/perl5/director_protected_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_protected_runme.pl (revision 0) @@ -0,0 +1,75 @@ +use strict; +use warnings; +use director_protected; + +{ + package FooBar; + use base 'director_protected::Bar'; + sub ping { 'FooBar::ping();' } +} +{ + package FooBar2; + use base 'director_protected::Bar'; + sub ping { 'FooBar2::ping();' } + sub pang { 'FooBar2::pang();' } +} + +my $b = director_protected::Bar->new(); +my $f = $b->create(); +my $fb = FooBar->new(); +my $fb2 = FooBar2->new(); + +my $s = $fb->used(); +die "RuntimeError" if + $s ne "Foo::pang();Bar::pong();Foo::pong();FooBar::ping();"; + +eval { + $s = $fb->used(); + die if $s ne "Foo::pang();Bar::pong();Foo::pong();FooBar::ping();"; +}; +die "bad FooBar::used" if $@; + +eval { + $s = $fb2->used(); + die if $s ne "FooBar2::pang();Bar::pong();Foo::pong();FooBar2::ping();"; +}; +die "bad FooBar2::used" if $@; + +eval { + $s = $b->pong(); + die if $s ne "Bar::pong();Foo::pong();Bar::ping();"; +}; +die "bad Bar::pong" if $@; + +eval { + $s = $f->pong(); + die if $s ne "Bar::pong();Foo::pong();Bar::ping();"; +}; +die "bad Foo::pong $@" if $@; + +eval { + $s = $fb->pong(); + die if $s ne "Bar::pong();Foo::pong();FooBar::ping();"; +}; +die "bad FooBar::pong" if $@; + +my $protected = 1; +eval { + $b->ping(); + $protected = 0; +}; +die "Boo::ping is protected" unless $protected; + +$protected = 1; +eval { + $f->ping(); + $protected = 0; +}; +die "Foo::ping is protected" unless $protected; + +$protected = 1; +eval { + $f->pang(); + $protected = 0; +}; +die "FooBar::pang is protected" unless $protected; Property changes on: Examples/test-suite/perl5/director_protected_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL" Index: Examples/test-suite/perl5/imports_runme.pl =================================================================== --- Examples/test-suite/perl5/imports_runme.pl (revision 10377) +++ Examples/test-suite/perl5/imports_runme.pl (working copy) @@ -1,5 +1,5 @@ use imports_b; use imports_a; -$x = imports_bc::new_B(); +$x = imports_bc->new_B(); imports_ac::A_hello($x); Index: Examples/test-suite/perl5/director_abstract_runme.pl =================================================================== --- Examples/test-suite/perl5/director_abstract_runme.pl (revision 0) +++ Examples/test-suite/perl5/director_abstract_runme.pl (revision 0) @@ -0,0 +1,74 @@ +use strict; +use warnings; +use director_abstract; + +{ + package MyFoo; + use base 'director_abstract::Foo'; + sub ping { + return 'MyFoo::ping()'; + } +} + +$a = MyFoo->new(); + +die $a->ping() if $a->ping() ne "MyFoo::ping()"; + +die $a->pong() if $a->pong() ne "Foo::pong();MyFoo::ping()"; + +{ + package MyExample1; + use base 'director_abstract::Example1'; + sub Color { my($self, $r, $g, $b) = @_; + return $r; + } +} +{ + package MyExample2; + use base 'director_abstract::Example2'; + sub Color { my($self, $r, $g, $b) = @_; + return $g; + } +} +{ + package MyExample3; + use base 'director_abstract::Example3_i'; + sub Color { my($self, $r, $g, $b) = @_; + return $b; + } +} +my $me1 = MyExample1->new(); +die "darn" if $me1->director_abstract::Example1::get_color(1,2,3) != 1; + +my $me2 = MyExample2->new(1,2); +die "darn" if $me2->get_color(1,2,3) != 2; + +my $me3 = MyExample3->new(); +die "darn" if $me3->get_color(1,2,3) != 3; + +eval { + $me1 = director_abstract::Example1->new(); +}; +die "darn" unless $@; + +eval { + $me2 = director_abstract::Example2->new(); +}; +die "darn" unless $@; + +eval { + $me3 = director_abstract::Example3_i->new(); +}; +die "darn" unless $@; + +# I'm not even clear what the heck this is supposed to test +# every way I interpret it, it ought to fail. +# * (new A())->f() should die because A is abstract +# * new A::f() is garbage +# * A.f is a protected method +# Let's skip it. +# +#try: +# f = director_abstract.A.f +#except: +# raise RuntimeError Property changes on: Examples/test-suite/perl5/director_abstract_runme.pl ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + "Id URL"