XS-MLVP
/
swig
mirror of https://github.com/swig/swig
5
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
swig/Source/Modules/perl5.cxx

1542 lines
45 KiB
C++
Raw Blame History

/* ----------------------------------------------------------------------------
* perl5.cxx
*
* Generate Perl5 wrappers
*
* Author(s) : David Beazley (beazley@cs.uchicago.edu)
* Loic Dachary (loic@ceic.com)
* David Fletcher
* Gary Holt
* Jason Stewart (jason@openinformatics.com)
*
* Copyright (C) 1999-2000. The University of Chicago
* See the file LICENSE for information on usage and redistribution.
* ------------------------------------------------------------------------- */
char cvsroot_perl5_cxx[] = "$Header$";
#include "swigmod.h"
#include <ctype.h>
static const char *usage = (char*)"\
Perl5 Options (available with -perl5)\n\
-static - Omit code related to dynamic loading\n\
-nopm - Do not generate the .pm file\n\
-proxy - Create proxy classes\n\
-noproxy - Don't create proxy classes\n\
-const - Wrap constants as constants and not variables (implies -proxy)\n\
-compat - Compatibility mode\n\n";
static int compat = 0;
static int no_pmfile = 0;
static int export_all = 0;
/*
* pmfile
* set by the -pm flag, overrides the name of the .pm file
*/
static String *pmfile = 0;
/*
* module
* set by the %module directive, e.g. "Xerces". It will determine
* the name of the .pm file, and the dynamic library.
*/
static String *module = 0;
/*
* fullmodule
* the fully namespace qualified name of the module, e.g. "XML::Xerces"
* it will be used to set the package namespace in the .pm file, as
* well as the name of the initialization methods in the glue library
*/
static String *fullmodule = 0;
/*
* cmodule
* the namespace of the internal glue code, set to the value of
* module with a 'c' appended
*/
static String *cmodule = 0;
static String *command_tab = 0;
static String *constant_tab = 0;
static String *variable_tab = 0;
static File *f_runtime = 0;
static File *f_header = 0;
static File *f_wrappers = 0;
static File *f_init = 0;
static File *f_pm = 0;
static String *pm; /* Package initialization code */
static String *magic; /* Magic variable wrappers */
static int is_static = 0;
/* The following variables are used to manage Perl5 classes */
static int blessed = 1; /* Enable object oriented features */
static int do_constants = 0; /* Constant wrapping */
static List *classlist = 0; /* List of classes */
static int have_constructor = 0;
static int have_destructor= 0;
static int have_data_members = 0;
static String *class_name = 0; /* Name of the class (what Perl thinks it is) */
static String *real_classname = 0; /* Real name of C/C++ class */
static String *fullclassname = 0;
static String *pcode = 0; /* Perl code associated with each class */
/* static String *blessedmembers = 0; */ /* Member data associated with each class */
static int member_func = 0; /* Set to 1 when wrapping a member function */
static String *func_stubs = 0; /* Function stubs */
static String *const_stubs = 0; /* Constant stubs */
static int num_consts = 0; /* Number of constants */
static String *var_stubs = 0; /* Variable stubs */
static String *exported = 0; /* Exported symbols */
static String *pragma_include = 0;
static String *additional_perl_code = 0; /* Additional Perl code from %perlcode %{ ... %} */
static Hash *operators = 0;
static int have_operators = 0;
class PERL5 : public Language {
public:
/* Test to see if a type corresponds to something wrapped with a shadow class */
Node *is_shadow(SwigType *t) {
Node *n;
n = classLookup(t);
/* Printf(stdout,"'%s' --> '%x'\n", t, n); */
if (n) {
if (!Getattr(n,"perl5:proxy")) {
setclassname(n);
}
return Getattr(n,"perl5:proxy");
}
return 0;
}
/* ------------------------------------------------------------
* main()
* ------------------------------------------------------------ */
virtual void main(int argc, char *argv[]) {
int i = 1;
SWIG_library_directory("perl5");
for (i = 1; i < argc; i++) {
if (argv[i]) {
if(strcmp(argv[i],"-package") == 0) {
Printf(stderr,"*** -package is no longer supported\n*** use the directive '%module A::B::C' in your interface file instead\n*** see the Perl section in the manual for details.\n");
SWIG_exit(EXIT_FAILURE);
} else if(strcmp(argv[i],"-interface") == 0) {
Printf(stderr,"*** -interface is no longer supported\n*** use the directive '%module A::B::C' in your interface file instead\n*** see the Perl section in the manual for details.\n");
SWIG_exit(EXIT_FAILURE);
} else if (strcmp(argv[i],"-exportall") == 0) {
export_all = 1;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-static") == 0) {
is_static = 1;
Swig_mark_arg(i);
} else if ((strcmp(argv[i],"-shadow") == 0) || ((strcmp(argv[i],"-proxy") == 0))) {
blessed = 1;
Swig_mark_arg(i);
} else if ((strcmp(argv[i],"-noproxy") == 0)) {
blessed =0;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-const") == 0) {
do_constants = 1;
blessed = 1;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-nopm") == 0) {
no_pmfile = 1;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-pm") == 0) {
Swig_mark_arg(i);
i++;
pmfile = NewString(argv[i]);
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-compat") == 0) {
compat = 1;
Swig_mark_arg(i);
} else if (strcmp(argv[i],"-help") == 0) {
fputs(usage,stdout);
}
}
}
Preprocessor_define("SWIGPERL 1", 0);
Preprocessor_define("SWIGPERL5 1", 0);
SWIG_typemap_lang("perl5");
SWIG_config_file("perl5.swg");
allow_overloading();
}
/* ------------------------------------------------------------
* top()
* ------------------------------------------------------------ */
virtual int top(Node *n) {
/* Initialize all of the output files */
String *outfile = Getattr(n,"outfile");
f_runtime = NewFile(outfile,"w");
if (!f_runtime) {
Printf(stderr,"*** Can't open '%s'\n", outfile);
SWIG_exit(EXIT_FAILURE);
}
f_init = NewString("");
f_header = NewString("");
f_wrappers = 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);
classlist = NewList();
pm = NewString("");
func_stubs = NewString("");
var_stubs = NewString("");
const_stubs = NewString("");
exported = NewString("");
magic = NewString("");
pragma_include = NewString("");
additional_perl_code = NewString("");
command_tab = NewString("static swig_command_info swig_commands[] = {\n");
constant_tab = NewString("static swig_constant_info swig_constants[] = {\n");
variable_tab = NewString("static swig_variable_info swig_variables[] = {\n");
Swig_banner(f_runtime);
module = Copy(Getattr(n,"name"));
/* If we're in blessed mode, change the package name to "packagec" */
if (blessed) {
cmodule = NewStringf("%sc",module);
} else {
cmodule = NewString(module);
}
fullmodule = NewString(module);
/* Create a .pm file
* Need to strip off any prefixes that might be found in
* the module name */
if (no_pmfile) {
f_pm = NewString(0);
} else {
if (pmfile == NULL) {
char *m = Char(module) + Len(module);
while (m != Char(module)) {
if (*m == ':') {
m++;
break;
}
m--;
}
pmfile = NewStringf("%s.pm", m);
}
String *filen = NewStringf("%s%s", SWIG_output_directory(),pmfile);
if ((f_pm = NewFile(filen,"w")) == 0) {
Printf(stderr,"Unable to open %s\n", filen);
SWIG_exit (EXIT_FAILURE);
}
Delete(filen); filen = NULL;
Swig_register_filebyname("pm",f_pm);
Swig_register_filebyname("perl",f_pm);
}
{
String *tmp = NewString(fullmodule);
Replaceall(tmp,":","_");
Printf(f_header,"#define SWIG_init boot_%s\n\n", tmp);
Printf(f_header,"#define SWIG_name \"%s::boot_%s\"\n", cmodule, tmp);
Printf(f_header,"#define SWIG_prefix \"%s::\"\n", cmodule);
Delete(tmp);
}
Printf(f_pm,"# This file was automatically generated by SWIG\n");
Printf(f_pm,"package %s;\n",fullmodule);
Printf(f_pm,"require Exporter;\n");
if (!is_static) {
Printf(f_pm,"require DynaLoader;\n");
Printf(f_pm,"@ISA = qw(Exporter DynaLoader);\n");
} else {
Printf(f_pm,"@ISA = qw(Exporter);\n");
}
/* Start creating magic code */
Printv(magic,
"#ifdef PERL_OBJECT\n",
"#define MAGIC_CLASS _wrap_", module, "_var::\n",
"class _wrap_", module, "_var : public CPerlObj {\n",
"public:\n",
"#else\n",
"#define MAGIC_CLASS\n",
"#endif\n",
"SWIGCLASS_STATIC int swig_magic_readonly(pTHX_ SV *sv, MAGIC *mg) {\n",
tab4, "MAGIC_PPERL\n",
tab4, "sv = sv; mg = mg;\n",
tab4, "croak(\"Value is read-only.\");\n",
tab4, "return 0;\n",
"}\n",
NIL);
Printf(f_wrappers,"#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
/* emit wrappers */
Language::top(n);
String *base = NewString("");
/* Dump out variable wrappers */
Printv(magic,
"\n\n#ifdef PERL_OBJECT\n",
"};\n",
"#endif\n",
NIL);
Printf(f_header,"%s\n", magic);
String *type_table = NewString("");
SwigType_emit_type_table(f_runtime,type_table);
/* Patch the type table to reflect the names used by shadow classes */
if (blessed) {
Iterator cls;
for (cls = First(classlist); cls.item; cls = Next(cls)) {
if (Getattr(cls.item,"perl5:proxy")) {
SwigType *type = Copy(Getattr(cls.item,"classtype"));
if (!type) continue; /* If unnamed class, no type will be found */
SwigType_add_pointer(type);
String *mangle = NewStringf("\"%s\"", SwigType_manglestr(type));
String *rep = NewStringf("\"%s\"", Getattr(cls.item,"perl5:proxy"));
Replaceall(type_table,mangle,rep);
Delete(mangle);
Delete(rep);
Delete(type);
}
}
}
Printf(f_wrappers,"%s",type_table);
Delete(type_table);
Printf(constant_tab,"{0,0,0,0,0,0}\n};\n");
Printv(f_wrappers,constant_tab,NIL);
Printf(f_wrappers,"#ifdef __cplusplus\n}\n#endif\n");
Printf(f_init,"\t ST(0) = &PL_sv_yes;\n");
Printf(f_init,"\t XSRETURN(1);\n");
Printf(f_init,"}\n");
/* Finish off tables */
Printf(variable_tab, "{0,0,0,0}\n};\n");
Printv(f_wrappers,variable_tab,NIL);
Printf(command_tab,"{0,0}\n};\n");
Printv(f_wrappers,command_tab,NIL);
Printf(f_pm,"package %s;\n", cmodule);
if (!is_static) {
Printf(f_pm,"bootstrap %s;\n", fullmodule);
} else {
String *tmp = NewString(fullmodule);
Replaceall(tmp,":","_");
Printf(f_pm,"boot_%s();\n", tmp);
Delete(tmp);
}
Printf(f_pm,"package %s;\n", fullmodule);
Printf(f_pm,"@EXPORT = qw( %s);\n",exported);
Printf(f_pm,"%s",pragma_include);
if (blessed) {
Printv(base,
"\n# ---------- BASE METHODS -------------\n\n",
"package ", fullmodule, ";\n\n",
NIL);
/* Write out the TIE method */
Printv(base,
"sub TIEHASH {\n",
tab4, "my ($classname,$obj) = @_;\n",
tab4, "return bless $obj, $classname;\n",
"}\n\n",
NIL);
/* Output a CLEAR method. This is just a place-holder, but by providing it we
* can make declarations such as
* %$u = ( x => 2, y=>3, z =>4 );
*
* Where x,y,z are the members of some C/C++ object. */
Printf(base,"sub CLEAR { }\n\n");
/* Output default firstkey/nextkey methods */
Printf(base, "sub FIRSTKEY { }\n\n");
Printf(base, "sub NEXTKEY { }\n\n");
/* Output a FETCH method. This is actually common to all classes */
Printv(base,
"sub FETCH {\n",
tab4, "my ($self,$field) = @_;\n",
tab4, "my $member_func = \"swig_${field}_get\";\n",
tab4, "$self->$member_func();\n",
"}\n\n",
NIL);
/* Output a STORE method. This is also common to all classes (might move to base class) */
Printv(base,
"sub STORE {\n",
tab4, "my ($self,$field,$newval) = @_;\n",
tab4, "my $member_func = \"swig_${field}_set\";\n",
tab4, "$self->$member_func($newval);\n",
"}\n\n",
NIL);
/* Output a 'this' method */
Printv(base,
"sub this {\n",
tab4, "my $ptr = shift;\n",
tab4, "return tied(%$ptr);\n",
"}\n\n",
NIL);
Printf(f_pm,"%s",base);
/* Emit function stubs for stand-alone functions */
Printf(f_pm,"\n# ------- FUNCTION WRAPPERS --------\n\n");
Printf(f_pm,"package %s;\n\n",fullmodule);
Printf(f_pm,"%s",func_stubs);
/* Emit package code for different classes */
Printf(f_pm,"%s",pm);
if (num_consts > 0) {
/* Emit constant stubs */
Printf(f_pm,"\n# ------- CONSTANT STUBS -------\n\n");
Printf(f_pm,"package %s;\n\n",fullmodule);
Printf(f_pm,"%s",const_stubs);
}
/* Emit variable stubs */
Printf(f_pm,"\n# ------- VARIABLE STUBS --------\n\n");
Printf(f_pm,"package %s;\n\n",fullmodule);
Printf(f_pm,"%s",var_stubs);
}
/* Add additional Perl code at the end */
Printf(f_pm,"%s",additional_perl_code);
Printf(f_pm,"1;\n");
Close(f_pm);
Delete(f_pm);
Delete(base);
/* Close all of the files */
Dump(f_header,f_runtime);
Dump(f_wrappers,f_runtime);
Wrapper_pretty_print(f_init,f_runtime);
Delete(f_header);
Delete(f_wrappers);
Delete(f_init);
Close(f_runtime);
Delete(f_runtime);
return SWIG_OK;
}
/* ------------------------------------------------------------
* importDirective(Node *n)
* ------------------------------------------------------------ */
virtual int importDirective(Node *n) {
if (blessed) {
String *modname = Getattr(n,"module");
if (modname) {
Printf(f_pm,"require %s;\n", modname);
}
}
return Language::importDirective(n);
}
/* ------------------------------------------------------------
* functionWrapper()
* ------------------------------------------------------------ */
virtual int functionWrapper(Node *n) {
String *name = Getattr(n,"name");
String *iname = Getattr(n,"sym:name");
SwigType *d = Getattr(n,"type");
ParmList *l = Getattr(n,"parms");
String *overname = 0;
Parm *p;
int i;
Wrapper *f;
char source[256],target[256],temp[256];
String *tm;
String *cleanup, *outarg;
int num_saved = 0;
int num_arguments, num_required;
int varargs = 0;
if (Getattr(n,"sym:overloaded")) {
overname = Getattr(n,"sym:overname");
} else {
if (!addSymbol(iname,n)) return SWIG_ERROR;
}
f = NewWrapper();
cleanup = NewString("");
outarg = NewString("");
String *wname = Swig_name_wrapper(iname);
if (overname) {
Append(wname,overname);
}
Setattr(n,"wrap:name",wname);
Printv(f->def,
"XS(", wname, ") {\n",
"{\n", /* scope to destroy C++ objects before croaking */
NIL );
emit_args(d, l, f);
emit_attach_parmmaps(l,f);
Setattr(n,"wrap:parms",l);
num_arguments = emit_num_arguments(l);
num_required = emit_num_required(l);
varargs = emit_isvarargs(l);
Wrapper_add_local(f,"argvi","int argvi = 0");
/* Check the number of arguments */
if (!varargs) {
Printf(f->code," if ((items < %d) || (items > %d)) {\n", num_required, num_arguments);
} else {
Printf(f->code," if (items < %d) {\n", num_required);
}
Printf(f->code," SWIG_croak(\"Usage: %s\");\n", usage_func(Char(iname),d,l));
Printf(f->code,"}\n");
/* Write code to extract parameters. */
i = 0;
for (i = 0, p = l; i < num_arguments; i++) {
/* Skip ignored arguments */
while (checkAttribute(p,"tmap:in:numinputs","0")) {
p = Getattr(p,"tmap:in:next");
}
SwigType *pt = Getattr(p,"type");
String *ln = Getattr(p,"lname");
/* Produce string representation of source and target arguments */
sprintf(source,"ST(%d)",i);
sprintf(target,"%s", Char(ln));
if (i >= num_required) {
Printf(f->code," if (items > %d) {\n", i);
}
if ((tm = Getattr(p,"tmap:in"))) {
Replaceall(tm,"$target",target);
Replaceall(tm,"$source",source);
Replaceall(tm,"$input", source);
Setattr(p,"emit:input",source); /* Save input location */
Printf(f->code,"%s\n",tm);
p = Getattr(p,"tmap:in:next");
} else {
Swig_warning(WARN_TYPEMAP_IN_UNDEF, input_file, line_number,
"Unable to use type %s as a function argument.\n",SwigType_str(pt,0));
p = nextSibling(p);
}
if (i >= num_required) {
Printf(f->code," }\n");
}
}
if (varargs) {
if (p && (tm = Getattr(p,"tmap:in"))) {
sprintf(source,"ST(%d)",i);
Replaceall(tm,"$input", source);
Setattr(p,"emit:input", source);
Printf(f->code,"if (items >= %d) {\n", i);
Printv(f->code, tm, "\n", NIL);
Printf(f->code,"}\n");
}
}
/* Insert constraint checking code */
for (p = l; p;) {
if ((tm = Getattr(p,"tmap:check"))) {
Replaceall(tm,"$target",Getattr(p,"lname"));
Printv(f->code,tm,"\n",NIL);
p = Getattr(p,"tmap:check:next");
} else {
p = nextSibling(p);
}
}
/* Insert cleanup code */
for (i = 0, p = l; p; i++) {
if ((tm = Getattr(p,"tmap:freearg"))) {
Replaceall(tm,"$source",Getattr(p,"lname"));
Replaceall(tm,"$arg",Getattr(p,"emit:input"));
Replaceall(tm,"$input",Getattr(p,"emit:input"));
Printv(cleanup,tm,"\n",NIL);
p = Getattr(p,"tmap:freearg:next");
} else {
p = nextSibling(p);
}
}
/* Insert argument output code */
num_saved = 0;
for (i=0,p = l; p;i++) {
if ((tm = Getattr(p,"tmap:argout"))) {
Replaceall(tm,"$source",Getattr(p,"lname"));
Replaceall(tm,"$target","ST(argvi)");
Replaceall(tm,"$result","ST(argvi)");
String *in = Getattr(p,"emit:input");
if (in) {
sprintf(temp,"_saved[%d]", num_saved);
Replaceall(tm,"$arg",temp);
Replaceall(tm,"$input",temp);
Printf(f->code,"_saved[%d] = %s;\n", num_saved, in);
num_saved++;
}
Printv(outarg,tm,"\n",NIL);
p = Getattr(p,"tmap:argout:next");
} else {
p = nextSibling(p);
}
}
/* If there were any saved arguments, emit a local variable for them */
if (num_saved) {
sprintf(temp,"_saved[%d]",num_saved);
Wrapper_add_localv(f,"_saved","SV *",temp,NIL);
}
/* Now write code to make the function call */
emit_action(n,f);
if ((tm = Swig_typemap_lookup_new("out",n,"result",0))) {
SwigType *t = Getattr(n,"type");
Replaceall(tm,"$source","result");
Replaceall(tm,"$target","ST(argvi)");
Replaceall(tm,"$result", "ST(argvi)");
if (is_shadow(t)) {
Replaceall(tm, "$shadow", "SWIG_SHADOW");
} else {
Replaceall(tm, "$shadow", "0");
}
if ((!SwigType_ispointer(t) && !SwigType_isreference(t))
|| Getattr(n,"feature:new")) {
Replaceall(tm,"$owner","SWIG_OWNER");
} else {
Replaceall(tm,"$owner","0");
}
Printf(f->code, "%s\n", tm);
} else {
Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number,
"Unable to use return type %s in function %s.\n", SwigType_str(d,0), name);
}
/* If there were any output args, take care of them. */
Printv(f->code,outarg,NIL);
/* If there was any cleanup, do that. */
Printv(f->code,cleanup,NIL);
if (Getattr(n,"feature:new")) {
if ((tm = Swig_typemap_lookup_new("newfree",n,"result",0))) {
Replaceall(tm,"$source","result");
Printf(f->code,"%s\n",tm);
}
}
if ((tm = Swig_typemap_lookup_new("ret",n,"result", 0))) {
Replaceall(tm,"$source","result");
Printf(f->code,"%s\n", tm);
}
Printv(f->code,
"XSRETURN(argvi);\n",
"fail:\n",
cleanup,
";\n", /* empty statement */
"}\n",
"croak(Nullch);\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);
/* Dump the wrapper function */
Wrapper_print(f,f_wrappers);
/* Now register the function */
if (!Getattr(n,"sym:overloaded")) {
Printf(command_tab,"{\"%s::%s\", %s},\n", cmodule, iname, wname);
} else if (!Getattr(n,"sym:nextSibling")) {
/* Generate overloaded dispatch function */
int maxargs, ii;
String *dispatch = Swig_overload_dispatch(n,"(*PL_markstack_ptr++);SWIG_CALLXS(%s); return;",&maxargs);
/* Generate a dispatch wrapper for all overloaded functions */
Wrapper *df = NewWrapper();
String *dname = Swig_name_wrapper(iname);
Printv(df->def,
"XS(", dname, ") {\n", NIL);
Wrapper_add_local(df,"dXSARGS", "dXSARGS");
Replaceid(dispatch,"argc","items");
for (ii = 0; ii < maxargs; ii++) {
char pat[128];
char rep[128];
sprintf(pat,"argv[%d]",ii);
sprintf(rep,"ST(%d)",ii);
Replaceall(dispatch,pat,rep);
}
Printv(df->code,dispatch,"\n",NIL);
Printf(df->code,"croak(\"No matching function for overloaded '%s'\");\n", iname);
Printf(df->code,"XSRETURN(0);\n");
Printv(df->code,"}\n",NIL);
Wrapper_print(df,f_wrappers);
Printf(command_tab,"{\"%s::%s\", %s},\n", cmodule, iname, dname);
DelWrapper(df);
Delete(dispatch);
Delete(dname);
}
if (!Getattr(n,"sym:nextSibling")) {
if (export_all) {
Printf(exported,"%s ", iname);
}
/* --------------------------------------------------------------------
* Create a stub for this function, provided it's not a member function
* -------------------------------------------------------------------- */
if ((blessed) && (!member_func)) {
Printv(func_stubs,"*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
}
}
Delete(cleanup);
Delete(outarg);
DelWrapper(f);
return SWIG_OK;
}
/* ------------------------------------------------------------
* variableWrapper()
* ------------------------------------------------------------ */
virtual int variableWrapper(Node *n) {
String *name = Getattr(n,"name");
String *iname = Getattr(n,"sym:name");
SwigType *t = Getattr(n,"type");
Wrapper *getf, *setf;
String *tm;
String *set_name = NewStringf("_wrap_set_%s", iname);
String *val_name = NewStringf("_wrap_val_%s", iname);
if (!addSymbol(iname,n)) return SWIG_ERROR;
getf = NewWrapper();
setf = NewWrapper();
/* Create a Perl function for setting the variable value */
if (!Getattr(n,"feature:immutable")) {
Printf(setf->def,"SWIGCLASS_STATIC int %s(pTHX_ SV* sv, MAGIC *mg) {\n", set_name);
Printv(setf->code,
tab4, "MAGIC_PPERL\n",
tab4, "mg = mg;\n",
NIL);
/* Check for a few typemaps */
tm = Swig_typemap_lookup_new("varin",n,name,0);
if (tm) {
Replaceall(tm,"$source","sv");
Replaceall(tm,"$target",name);
Replaceall(tm,"$input","sv");
Printf(setf->code,"%s\n", tm);
} else {
Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number,
"Unable to set variable of type %s.\n", SwigType_str(t,0));
return SWIG_NOWRAP;
}
Printf(setf->code," return 1;\n}\n");
Replaceall(setf->code,"$symname",iname);
Wrapper_print(setf,magic);
}
/* Now write a function to evaluate the variable */
Printf(getf->def,"SWIGCLASS_STATIC int %s(pTHX_ SV *sv, MAGIC *mg) {\n", val_name);
Printv(getf->code,
tab4, "MAGIC_PPERL\n",
tab4, "mg = mg;\n",
NIL);
if ((tm = Swig_typemap_lookup_new("varout",n,name,0))) {
Replaceall(tm,"$target","sv");
Replaceall(tm,"$result","sv");
Replaceall(tm,"$source",name);
Printf(getf->code,"%s\n", tm);
} else {
Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number,
"Unable to read variable of type %s\n", SwigType_str(t,0));
return SWIG_NOWRAP;
}
Printf(getf->code," return 1;\n}\n");
Replaceall(getf->code,"$symname",iname);
Wrapper_print(getf,magic);
String *tt = Getattr(n,"tmap:varout:type");
if (tt) {
String *tm = NewStringf("&SWIGTYPE%s", SwigType_manglestr(t));
if (Replaceall(tt,"$1_descriptor", tm)) {
SwigType_remember(t);
}
Delete(tm);
SwigType *st = Copy(t);
SwigType_add_pointer(st);
tm = NewStringf("&SWIGTYPE%s", SwigType_manglestr(st));
if (Replaceall(tt,"$&1_descriptor", tm)) {
SwigType_remember(st);
}
Delete(tm);
Delete(st);
} else {
tt = (String *) "0";
}
/* Now add symbol to the PERL interpreter */
if (Getattr(n,"feature:immutable")) {
Printv(variable_tab, tab4, "{ \"", cmodule, "::", iname, "\", MAGIC_CLASS swig_magic_readonly, MAGIC_CLASS ", val_name,",", tt, " },\n",NIL);
} else {
Printv(variable_tab, tab4, "{ \"", cmodule, "::", iname, "\", MAGIC_CLASS ", set_name, ", MAGIC_CLASS ", val_name, ",", tt, " },\n",NIL);
}
/* If we're blessed, try to figure out what to do with the variable
1. If it's a Perl object of some sort, create a tied-hash
around it.
2. Otherwise, just hack Perl's symbol table */
if (blessed) {
if (is_shadow(t)) {
Printv(var_stubs,
"\nmy %__", iname, "_hash;\n",
"tie %__", iname, "_hash,\"", is_shadow(t), "\", $",
cmodule, "::", iname, ";\n",
"$", iname, "= \\%__", iname, "_hash;\n",
"bless $", iname, ", ", is_shadow(t), ";\n",
NIL);
} else {
Printv(var_stubs, "*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
}
}
if (export_all)
Printf(exported,"$%s ", iname);
DelWrapper(setf);
DelWrapper(getf);
Delete(set_name);
Delete(val_name);
return SWIG_OK;
}
/* ------------------------------------------------------------
* constantWrapper()
* ------------------------------------------------------------ */
virtual int constantWrapper(Node *n) {
String *name = Getattr(n,"name");
String *iname = Getattr(n,"sym:name");
SwigType *type = Getattr(n,"type");
String *value = Getattr(n,"value");
String *tm;
if (!addSymbol(iname,n)) return SWIG_ERROR;
/* Special hook for member pointer */
if (SwigType_type(type) == T_MPOINTER) {
String *wname = Swig_name_wrapper(iname);
Printf(f_wrappers, "static %s = %s;\n", SwigType_str(type,wname), value);
value = Char(wname);
}
if ((tm = Swig_typemap_lookup_new("consttab",n,name,0))) {
Replaceall(tm,"$source",value);
Replaceall(tm,"$target",name);
Replaceall(tm,"$value",value);
Printf(constant_tab,"%s,\n", tm);
} else if ((tm = Swig_typemap_lookup_new("constcode", n, name, 0))) {
Replaceall(tm,"$source", value);
Replaceall(tm,"$target", name);
Replaceall(tm,"$value",value);
Printf(f_init, "%s\n", tm);
} else {
Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number,
"Unsupported constant value.\n");
return SWIG_NOWRAP;
}
if (blessed) {
if (is_shadow(type)) {
Printv(var_stubs,
"\nmy %__", iname, "_hash;\n",
"tie %__", iname, "_hash,\"", is_shadow(type), "\", $",
cmodule, "::", iname, ";\n",
"$", iname, "= \\%__", iname, "_hash;\n",
"bless $", iname, ", ", is_shadow(type), ";\n",
NIL);
} else if (do_constants) {
Printv(const_stubs,"sub ", name, " () { $",
cmodule, "::", name, " }\n", NIL);
num_consts++;
} else {
Printv(var_stubs, "*",iname," = *", cmodule, "::", iname, ";\n", NIL);
}
}
if (export_all) {
if (do_constants && !is_shadow(type)) {
Printf(exported,"%s ",name);
} else {
Printf(exported,"$%s ",iname);
}
}
return SWIG_OK;
}
/* ------------------------------------------------------------
* usage_func()
* ------------------------------------------------------------ */
char *usage_func(char *iname, SwigType *, ParmList *l) {
static String *temp = 0;
Parm *p;
int i;
if (!temp) temp = NewString("");
Clear(temp);
Printf(temp,"%s(",iname);
/* Now go through and print parameters */
p = l;
i = 0;
while (p != 0) {
SwigType *pt = Getattr(p,"type");
String *pn = Getattr(p,"name");
if (!Getattr(p,"ignore")) {
/* If parameter has been named, use that. Otherwise, just print a type */
if (SwigType_type(pt) != T_VOID) {
if (Len(pn) > 0) {
Printf(temp,"%s",pn);
} else {
Printf(temp,"%s",SwigType_str(pt,0));
}
}
i++;
p = nextSibling(p);
if (p)
if (!Getattr(p,"ignore"))
Putc(',',temp);
} else {
p = nextSibling(p);
if (p)
if ((i>0) && (!Getattr(p,"ignore")))
Putc(',',temp);
}
}
Printf(temp,");");
return Char(temp);
}
/* ------------------------------------------------------------
* nativeWrapper()
* ------------------------------------------------------------ */
virtual int nativeWrapper(Node *n) {
String *name = Getattr(n,"sym:name");
String *funcname = Getattr(n,"wrap:name");
if (!addSymbol(funcname,n)) return SWIG_ERROR;
Printf(command_tab,"{\"%s::%s\", %s},\n", cmodule,name,funcname);
if (export_all)
Printf(exported,"%s ",name);
if (blessed) {
Printv(func_stubs,"*", name, " = *", cmodule, "::", name, ";\n", NIL);
}
return SWIG_OK;
}
/****************************************************************************
*** OBJECT-ORIENTED FEATURES
****************************************************************************
*** These extensions provide a more object-oriented interface to C++
*** classes and structures. The code here is based on extensions
*** provided by David Fletcher and Gary Holt.
***
*** I have generalized these extensions to make them more general purpose
*** and to resolve object-ownership problems.
***
*** The approach here is very similar to the Python module :
*** 1. All of the original methods are placed into a single
*** package like before except that a 'c' is appended to the
*** package name.
***
*** 2. All methods and function calls are wrapped with a new
*** perl function. While possibly inefficient this allows
*** us to catch complex function arguments (which are hard to
*** track otherwise).
***
*** 3. Classes are represented as tied-hashes in a manner similar
*** to Gary Holt's extension. This allows us to access
*** member data.
***
*** 4. Stand-alone (global) C functions are modified to take
*** tied hashes as arguments for complex datatypes (if
*** appropriate).
***
*** 5. Global variables involving a class/struct is encapsulated
*** in a tied hash.
***
****************************************************************************/
void setclassname(Node *n) {
String *symname = Getattr(n,"sym:name");
String *fullname;
String *actualpackage;
Node *clsmodule = Getattr(n,"module");
if (!clsmodule) {
/* imported module does not define a module name. Oh well */
return;
}
/* Do some work on the class name */
actualpackage = Getattr(clsmodule,"name");
if ((!compat) && (!Strchr(symname,':'))) {
fullname = NewStringf("%s::%s",actualpackage,symname);
} else {
fullname = NewString(symname);
}
Setattr(n,"perl5:proxy", fullname);
}
/* ------------------------------------------------------------
* classDeclaration()
* ------------------------------------------------------------ */
virtual int classDeclaration(Node *n) {
/* Do some work on the class name */
if (!Getattr(n,"feature:onlychildren")) {
if (blessed) {
setclassname(n);
Append(classlist,n);
}
}
return Language::classDeclaration(n);
}
/* ------------------------------------------------------------
* classHandler()
* ------------------------------------------------------------ */
virtual int classHandler(Node *n) {
if (blessed) {
have_constructor = 0;
have_operators = 0;
have_destructor = 0;
have_data_members = 0;
operators = NewHash();
class_name = Getattr(n,"sym:name");
if (!addSymbol(class_name,n)) return SWIG_ERROR;
/* Use the fully qualified name of the Perl class */
if (!compat) {
fullclassname = NewStringf("%s::%s",fullmodule,class_name);
} else {
fullclassname = NewString(class_name);
}
real_classname = Getattr(n,"name");
pcode = NewString("");
// blessedmembers = NewString("");
}
/* Emit all of the members */
Language::classHandler(n);
/* Finish the rest of the class */
if (blessed) {
/* Generate a client-data entry */
SwigType *ct = NewStringf("p.%s", real_classname);
Printv(f_init,"SWIG_TypeClientData(SWIGTYPE", SwigType_manglestr(ct),", (void*) \"",
fullclassname, "\");\n", NIL);
SwigType_remember(ct);
Delete(ct);
Printv(pm,
"\n############# Class : ", fullclassname, " ##############\n",
"\npackage ", fullclassname, ";\n",
NIL);
if (have_operators) {
Printf(pm, "use overload\n");
Iterator ki;
for (ki = First(operators); ki.key; ki = Next(ki)) {
char *name = Char(ki.key);
// fprintf(stderr,"found name: <%s>\n", name);
if (strstr(name, "operator_equal_to")) {
Printv(pm, tab4, "\"==\" => sub { $_[0]->operator_equal_to($_[1])},\n",NIL);
} else if (strstr(name, "operator_not_equal_to")) {
Printv(pm, tab4, "\"!=\" => sub { $_[0]->operator_not_equal_to($_[1])},\n",NIL);
} else if (strstr(name, "operator_assignment")) {
Printv(pm, tab4, "\"=\" => sub { $_[0]->operator_assignment($_[1])},\n",NIL);
} else {
fprintf(stderr,"Unknown operator: %s\n", name);
}
}
Printv(pm, tab4, "\"fallback\" => 1;\n",NIL);
}
/* If we are inheriting from a base class, set that up */
Printv(pm, "@ISA = qw( ", NIL);
if (!compat || Cmp(fullmodule, fullclassname)) {
Printv(pm, fullmodule, NIL);
}
/* Handle inheritance */
List *baselist = Getattr(n,"bases");
if (baselist && Len(baselist)) {
Iterator b;
b = First(baselist);
while (b.item) {
String *bname = Getattr(b.item, "perl5:proxy");
if (!bname) {
b = Next(b);
continue;
}
Printv(pm," ", bname, NIL);
b = Next(b);
}
}
Printf(pm, " );\n");
/* Dump out a hash table containing the pointers that we own */
Printf(pm, "%%OWNER = ();\n");
if (have_data_members || have_destructor)
Printf(pm, "%%ITERATORS = ();\n");
/* Dump out the package methods */
Printv(pm,pcode,NIL);
Delete(pcode);
/* Output methods for managing ownership */
Printv(pm,
"sub DISOWN {\n",
tab4, "my $self = shift;\n",
tab4, "my $ptr = tied(%$self);\n",
tab4, "delete $OWNER{$ptr};\n",
"}\n\n",
"sub ACQUIRE {\n",
tab4, "my $self = shift;\n",
tab4, "my $ptr = tied(%$self);\n",
tab4, "$OWNER{$ptr} = 1;\n",
"}\n\n",
NIL);
/* Only output the following methods if a class has member data */
Delete(operators); operators = 0;
}
return SWIG_OK;
}
/* ------------------------------------------------------------
* memberfunctionHandler()
* ------------------------------------------------------------ */
virtual int memberfunctionHandler(Node *n) {
String *symname = Getattr(n,"sym:name");
member_func = 1;
Language::memberfunctionHandler(n);
member_func = 0;
if ((blessed) && (!Getattr(n,"sym:nextSibling"))) {
if (Strstr(symname, "operator") == symname) {
if (Strstr(symname, "operator_equal_to")) {
DohSetInt(operators,"operator_equal_to",1);
have_operators = 1;
} else if (Strstr(symname, "operator_not_equal_to")) {
DohSetInt(operators,"operator_not_equal_to",1);
have_operators = 1;
} else if (Strstr(symname, "operator_assignment")) {
DohSetInt(operators,"operator_assignment",1);
have_operators = 1;
} else {
Printf(stderr,"Unknown operator: %s\n", symname);
}
// fprintf(stderr,"Found member_func operator: %s\n", symname);
}
if (Getattr(n,"feature:shadow")) {
String *plcode = perlcode(Getattr(n,"feature:shadow"),0);
String *plaction = NewStringf("%s::%s", module, Swig_name_member(class_name,symname));
Replaceall(plcode,"$action" ,plaction);
Delete(plaction);
Printv(pcode,plcode,NIL);
} else {
Printv(pcode,"*",symname," = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL);
}
}
return SWIG_OK;
}
/* ------------------------------------------------------------
* membervariableHandler()
*
* Adds an instance member.
* ----------------------------------------------------------------------------- */
virtual int membervariableHandler(Node *n) {
String *symname = Getattr(n,"sym:name");
/* SwigType *t = Getattr(n,"type"); */
/* Emit a pair of get/set functions for the variable */
member_func = 1;
Language::membervariableHandler(n);
member_func = 0;
if (blessed) {
Printv(pcode,"*swig_", symname, "_get = *", cmodule, "::", Swig_name_get(Swig_name_member(class_name,symname)), ";\n", NIL);
Printv(pcode,"*swig_", symname, "_set = *", cmodule, "::", Swig_name_set(Swig_name_member(class_name,symname)), ";\n", NIL);
/* Now we need to generate a little Perl code for this */
/* if (is_shadow(t)) {
*//* This is a Perl object that we have already seen. Add an
entry to the members list*//*
Printv(blessedmembers,
tab4, symname, " => '", is_shadow(t), "',\n",
NIL);
}
*/
}
have_data_members++;
return SWIG_OK;
}
/* ------------------------------------------------------------
* constructorDeclaration()
*
* Emits a blessed constructor for our class. In addition to our construct
* we manage a Perl hash table containing all of the pointers created by
* the constructor. This prevents us from accidentally trying to free
* something that wasn't necessarily allocated by malloc or new
* ------------------------------------------------------------ */
virtual int constructorHandler(Node *n) {
String *symname = Getattr(n,"sym:name");
member_func = 1;
Language::constructorHandler(n);
if ((blessed) && (!Getattr(n,"sym:nextSibling"))) {
if (Getattr(n,"feature:shadow")) {
String *plcode = perlcode(Getattr(n,"feature:shadow"),0);
String *plaction = NewStringf("%s::%s", module, Swig_name_member(class_name,symname));
Replaceall(plcode,"$action" ,plaction);
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;
}
}
member_func = 0;
return SWIG_OK;
}
/* ------------------------------------------------------------
* destructorHandler()
* ------------------------------------------------------------ */
virtual int destructorHandler(Node *n) {
String *symname = Getattr(n,"sym:name");
member_func = 1;
Language::destructorHandler(n);
if (blessed) {
if (Getattr(n,"feature:shadow")) {
String *plcode = perlcode(Getattr(n,"feature:shadow"),0);
String *plaction = NewStringf("%s::%s", module, Swig_name_member(class_name,symname));
Replaceall(plcode,"$action" ,plaction);
Delete(plaction);
Printv(pcode,plcode,NIL);
} else {
Printv(pcode,
"sub DESTROY {\n",
tab4, "return unless $_[0]->isa('HASH');\n",
tab4, "my $self = tied(%{$_[0]});\n",
tab4, "return unless defined $self;\n",
tab4, "delete $ITERATORS{$self};\n",
tab4, "if (exists $OWNER{$self}) {\n",
tab8, cmodule, "::", Swig_name_destroy(symname), "($self);\n",
tab8, "delete $OWNER{$self};\n",
tab4, "}\n}\n\n",
NIL);
have_destructor = 1;
}
}
member_func = 0;
return SWIG_OK;
}
/* ------------------------------------------------------------
* staticmemberfunctionHandler()
* ------------------------------------------------------------ */
virtual int staticmemberfunctionHandler(Node *n) {
member_func = 1;
Language::staticmemberfunctionHandler(n);
member_func = 0;
if ((blessed) && (!Getattr(n,"sym:nextSibling"))) {
String *symname = Getattr(n,"sym:name");
Printv(pcode,"*",symname," = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL);
}
return SWIG_OK;
}
/* ------------------------------------------------------------
* staticmembervariableHandler()
* ------------------------------------------------------------ */
virtual int staticmembervariableHandler(Node *n) {
Language::staticmembervariableHandler(n);
if (blessed) {
String *symname = Getattr(n,"sym:name");
Printv(pcode,"*",symname," = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL);
}
return SWIG_OK;
}
/* ------------------------------------------------------------
* memberconstantHandler()
* ------------------------------------------------------------ */
virtual int memberconstantHandler(Node *n) {
String *symname = Getattr(n,"sym:name");
int oldblessed = blessed;
/* Create a normal constant */
blessed = 0;
Language::memberconstantHandler(n);
blessed = oldblessed;
if (blessed) {
Printv(pcode, "*", symname, " = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL);
}
return SWIG_OK;
}
/* ------------------------------------------------------------
* pragma()
*
* Pragma directive.
*
* %pragma(perl5) code="String" # Includes a string in the .pm file
* %pragma(perl5) include="file.pl" # Includes a file in the .pm file
* ------------------------------------------------------------ */
virtual int pragmaDirective(Node *n) {
String *lang;
String *code;
String *value;
if (!ImportMode) {
lang = Getattr(n,"lang");
code = Getattr(n,"name");
value = Getattr(n,"value");
if (Strcmp(lang,"perl5") == 0) {
if (Strcmp(code,"code") == 0) {
/* Dump the value string into the .pm file */
if (value) {
Printf(pragma_include, "%s\n", value);
}
} else if (Strcmp(code,"include") == 0) {
/* Include a file into the .pm file */
if (value) {
FILE *f = Swig_open(value);
if (!f) {
Printf(stderr,"%s : Line %d. Unable to locate file %s\n", input_file, line_number,value);
} else {
char buffer[4096];
while (fgets(buffer,4095,f)) {
Printf(pragma_include,"%s",buffer);
}
}
}
} else {
Printf(stderr,"%s : Line %d. Unrecognized pragma.\n", input_file,line_number);
}
}
}
return Language::pragmaDirective(n);
}
/* ------------------------------------------------------------
* perlcode() - Output perlcode code into the shadow file
* ------------------------------------------------------------ */
String *perlcode(String *code, const String *indent) {
String *out = NewString("");
String *temp;
char *t;
if (!indent) indent = "";
temp = NewString(code);
t = Char(temp);
if (*t == '{') {
Delitem(temp,0);
Delitem(temp,DOH_END);
}
/* Split the input text into lines */
List *clist = DohSplitLines(temp);
Delete(temp);
int initial = 0;
String *s = 0;
Iterator si;
/* Get the initial indentation */
for (si = First(clist); si.item; si = Next(si)) {
s = si.item;
if (Len(s)) {
char *c = Char(s);
while (*c) {
if (!isspace(*c)) break;
initial++;
c++;
}
if (*c && !isspace(*c)) break;
else {
initial = 0;
}
}
}
while (si.item) {
s = si.item;
if (Len(s) > initial) {
char *c = Char(s);
c += initial;
Printv(out,indent,c,"\n",NIL);
} else {
Printv(out,"\n",NIL);
}
si = Next(si);
}
Delete(clist);
return out;
}
/* ------------------------------------------------------------
* insertDirective()
*
* Hook for %insert directive.
* ------------------------------------------------------------ */
virtual int insertDirective(Node *n) {
String *code = Getattr(n,"code");
String *section = Getattr(n,"section");
if ((!ImportMode) && (Cmp(section,"perl") == 0)) {
Printv(additional_perl_code, code, NIL);
} else {
Language::insertDirective(n);
}
return SWIG_OK;
}
};
/* -----------------------------------------------------------------------------
* swig_perl5() - Instantiate module
* ----------------------------------------------------------------------------- */
static Language * new_swig_perl5() {
return new PERL5();
}
extern "C" Language * swig_perl5(void) {
return new_swig_perl5();
}
Reference in New Issue View Git Blame Copy Permalink