c90f71dd8c
special cases and other things in wxPython, and since I plan on making several more, I've decided to put the SWIG sources in wxPython's CVS instead of relying on maintaining patches. This effectivly becomes a fork of an obsolete version of SWIG, :-( but since SWIG 1.3 still doesn't have some things I rely on in 1.1, not to mention that my custom patches would all have to be redone, I felt that this is the easier road to take. git-svn-id: https://svn.wxwidgets.org/svn/wx/wxWidgets/trunk@15307 c3d73ce0-8a6f-49c7-b76d-6d57e0e08775
2272 lines
66 KiB
C++
2272 lines
66 KiB
C++
/*******************************************************************************
|
|
* Simplified Wrapper and Interface Generator (SWIG)
|
|
*
|
|
* Author : David Beazley
|
|
*
|
|
* Department of Computer Science
|
|
* University of Chicago
|
|
* 1100 E 58th Street
|
|
* Chicago, IL 60637
|
|
* beazley@cs.uchicago.edu
|
|
*
|
|
* Please read the file LICENSE for the copyright and terms by which SWIG
|
|
* can be used and distributed.
|
|
*******************************************************************************/
|
|
|
|
/***********************************************************************
|
|
* $Header$
|
|
*
|
|
* perl5.c
|
|
*
|
|
* Definitions for adding functions to Perl 5
|
|
*
|
|
* How to extend perl5 (note : this is totally different in Perl 4) :
|
|
*
|
|
* 1. Variable linkage
|
|
*
|
|
* Must declare two functions :
|
|
*
|
|
* _var_set(SV *sv, MAGIC *mg);
|
|
* _var_get(SV *sv, MAGIC *mg);
|
|
*
|
|
* These functions must set/get the values of a variable using
|
|
* Perl5 internals.
|
|
*
|
|
* To add these to Perl5 (which isn't entirely clear), need to
|
|
* do the following :
|
|
*
|
|
* SV *sv;
|
|
* MAGIC *m;
|
|
* sv = perl_get_sv("varname",TRUE);
|
|
* sv_magic(sv,sv, 'U', "varname", strlen("varname));
|
|
* m = mg_find(sv, 'U');
|
|
* m->mg_virtual = (MGVTBL *) malloc(sizeof(MGVTBL));
|
|
* m->mg_virtual.svt_get = _var_set;
|
|
* m->mg_virtual.svt_set = _var_get;
|
|
* m->mg_virtual.svt_len = 0;
|
|
* m->mg_virtual.svt_free = 0;
|
|
* m->mg_virtual.svt_clear = 0;
|
|
*
|
|
*
|
|
* 2. Function extension
|
|
*
|
|
* Functions are declared as :
|
|
* XS(_wrap_func) {
|
|
* dXSARGS;
|
|
* if (items != parmcount) {
|
|
* croak("Usage :");
|
|
* }
|
|
* ... get arguments ...
|
|
*
|
|
* ... call function ...
|
|
* ... set return value in ST(0)
|
|
* XSRETURN(1);
|
|
* }
|
|
* To extract function arguments, use the following :
|
|
* _arg = (int) SvIV(ST(0))
|
|
* _arg = (double) SvNV(ST(0))
|
|
* _arg = (char *) SvPV(ST(0),na);
|
|
*
|
|
* For return values, use :
|
|
* ST(0) = sv_newmortal();
|
|
* sv_setiv(ST(0), (IV) RETVAL); // Integers
|
|
* sv_setnv(ST(0), (double) RETVAL); // Doubles
|
|
* sv_setpv((SV*) ST(0), RETVAL); // Strings
|
|
*
|
|
* New functions are added using
|
|
* newXS("name", _wrap_func, file)
|
|
*
|
|
*
|
|
* 3. Compilation.
|
|
*
|
|
* Code should be compiled into an object file for dynamic
|
|
* loading into Perl.
|
|
***********************************************************************/
|
|
|
|
#include "swig.h"
|
|
#include "perl5.h"
|
|
|
|
static String pragma_include;
|
|
|
|
static char *usage = "\
|
|
Perl5 Options (available with -perl5)\n\
|
|
-module name - Set module name\n\
|
|
-package name - Set package prefix\n\
|
|
-static - Omit code related to dynamic loading.\n\
|
|
-shadow - Create shadow classes.\n\
|
|
-compat - Compatibility mode.\n\
|
|
-alt-header file- Use an alternate header.\n\n";
|
|
|
|
static char *import_file = 0;
|
|
static char *smodule = 0;
|
|
static int compat = 0;
|
|
|
|
// ---------------------------------------------------------------------
|
|
// PERL5::parse_args(int argc, char *argv[])
|
|
//
|
|
// Parse command line options.
|
|
// ---------------------------------------------------------------------
|
|
|
|
void
|
|
PERL5::parse_args(int argc, char *argv[]) {
|
|
|
|
int i = 1;
|
|
|
|
export_all = 0;
|
|
sprintf(LibDir,"%s", perl_path);
|
|
|
|
// Look for certain command line options
|
|
|
|
// Get options
|
|
for (i = 1; i < argc; i++) {
|
|
if (argv[i]) {
|
|
if(strcmp(argv[i],"-package") == 0) {
|
|
if (argv[i+1]) {
|
|
package = new char[strlen(argv[i+1])+1];
|
|
strcpy(package, argv[i+1]);
|
|
mark_arg(i);
|
|
mark_arg(i+1);
|
|
i++;
|
|
} else {
|
|
arg_error();
|
|
}
|
|
} else if (strcmp(argv[i],"-module") == 0) {
|
|
if (argv[i+1]) {
|
|
module = new char[strlen(argv[i+1])+1];
|
|
strcpy(module, argv[i+1]);
|
|
cmodule = module;
|
|
cmodule.replace(":","_");
|
|
mark_arg(i);
|
|
mark_arg(i+1);
|
|
i++;
|
|
} else {
|
|
arg_error();
|
|
}
|
|
} else if (strcmp(argv[i],"-exportall") == 0) {
|
|
export_all = 1;
|
|
mark_arg(i);
|
|
} else if (strcmp(argv[i],"-static") == 0) {
|
|
is_static = 1;
|
|
mark_arg(i);
|
|
} else if (strcmp(argv[i],"-shadow") == 0) {
|
|
blessed = 1;
|
|
mark_arg(i);
|
|
} else if (strcmp(argv[i],"-alt-header") == 0) {
|
|
if (argv[i+1]) {
|
|
alt_header = copy_string(argv[i+1]);
|
|
mark_arg(i);
|
|
mark_arg(i+1);
|
|
i++;
|
|
} else {
|
|
arg_error();
|
|
}
|
|
} else if (strcmp(argv[i],"-compat") == 0) {
|
|
compat = 1;
|
|
mark_arg(i);
|
|
} else if (strcmp(argv[i],"-help") == 0) {
|
|
fputs(usage,stderr);
|
|
}
|
|
}
|
|
}
|
|
// Add a symbol for this module
|
|
|
|
add_symbol("SWIGPERL",0,0);
|
|
add_symbol("SWIGPERL5",0,0);
|
|
|
|
// Set name of typemaps
|
|
|
|
typemap_lang = "perl5";
|
|
|
|
}
|
|
|
|
// ------------------------------------------------------------------
|
|
// PERL5::parse()
|
|
//
|
|
// Parse an interface file
|
|
// ------------------------------------------------------------------
|
|
|
|
void
|
|
PERL5::parse() {
|
|
|
|
|
|
printf("Generating wrappers for Perl 5\n");
|
|
|
|
// Print out PERL5 specific headers
|
|
|
|
headers();
|
|
|
|
// Run the parser
|
|
|
|
yyparse();
|
|
fputs(vinit.get(),f_wrappers);
|
|
}
|
|
|
|
|
|
// ---------------------------------------------------------------------
|
|
// PERL5::set_module(char *mod_name, char **mod_list)
|
|
//
|
|
// Sets the module name.
|
|
// Does nothing if it's already set (so it can be overridden as a command
|
|
// line option).
|
|
//
|
|
//----------------------------------------------------------------------
|
|
static String modinit, modextern;
|
|
|
|
void PERL5::set_module(char *mod_name, char **mod_list) {
|
|
int i;
|
|
if (import_file) {
|
|
if (!(strcmp(import_file,input_file+strlen(input_file)-strlen(import_file)))) {
|
|
if (blessed) {
|
|
fprintf(f_pm,"require %s;\n", mod_name);
|
|
}
|
|
delete [] import_file;
|
|
import_file = 0;
|
|
}
|
|
}
|
|
|
|
if (module) return;
|
|
|
|
module = new char[strlen(mod_name)+1];
|
|
strcpy(module,mod_name);
|
|
|
|
// if there was a mod_list specified, make this big hack
|
|
if (mod_list) {
|
|
modinit << "#define SWIGMODINIT ";
|
|
modextern << "#ifdef __cplusplus\n"
|
|
<< "extern \"C\" {\n"
|
|
<< "#endif\n";
|
|
i = 0;
|
|
while(mod_list[i]) {
|
|
modinit << "newXS(\"" << mod_list[i] << "::boot_" << mod_list[i] << "\", boot_" << mod_list[i] << ", file);\\\n";
|
|
modextern << "extern void boot_" << mod_list[i] << "(CV *);\n";
|
|
i++;
|
|
}
|
|
modextern << "#ifdef __cplusplus\n"
|
|
<< "}\n"
|
|
<< "#endif\n";
|
|
modinit << "/* End of extern module initialization */\n";
|
|
}
|
|
|
|
// Create a C module name and put it in 'cmodule'
|
|
|
|
cmodule = module;
|
|
cmodule.replace(":","_");
|
|
}
|
|
|
|
// ---------------------------------------------------------------------
|
|
// PERL5::set_init(char *iname)
|
|
//
|
|
// Sets the initialization function name.
|
|
// Does nothing if it's already set
|
|
//
|
|
//----------------------------------------------------------------------
|
|
|
|
void PERL5::set_init(char *iname) {
|
|
set_module(iname,0);
|
|
}
|
|
|
|
// ---------------------------------------------------------------------
|
|
// PERL5::headers(void)
|
|
//
|
|
// Generate the appropriate header files for PERL5 interface.
|
|
// ----------------------------------------------------------------------
|
|
|
|
void PERL5::headers(void)
|
|
{
|
|
|
|
emit_banner(f_header);
|
|
|
|
if (!alt_header) {
|
|
if (insert_file("headers.swg", f_header) == -1) {
|
|
fprintf(stderr,"Perl5 : Fatal error. Unable to locate headers.swg. Possible installation problem.\n");
|
|
SWIG_exit(1);
|
|
}
|
|
} else {
|
|
if (insert_file(alt_header, f_header) == -1) {
|
|
fprintf(stderr,"SWIG : Fatal error. Unable to locate %s.\n",alt_header);
|
|
SWIG_exit(1);
|
|
}
|
|
}
|
|
|
|
if (NoInclude) {
|
|
fprintf(f_header,"#define SWIG_NOINCLUDE\n");
|
|
}
|
|
|
|
// Get special SWIG related declarations
|
|
if (insert_file("perl5.swg", f_header) == -1) {
|
|
fprintf(stderr,"SWIG : Fatal error. Unable to locate 'perl5.swg' in SWIG library.\n");
|
|
SWIG_exit(1);
|
|
}
|
|
|
|
// Get special SWIG related declarations
|
|
if (insert_file("perl5mg.swg", f_header) == -1) {
|
|
fprintf(stderr,"SWIG : Fatal error. Unable to locate 'perl5mg.swg' in SWIG library.\n");
|
|
SWIG_exit(1);
|
|
}
|
|
|
|
}
|
|
|
|
// --------------------------------------------------------------------
|
|
// PERL5::initialize()
|
|
//
|
|
// Output initialization code that registers functions with the
|
|
// interface.
|
|
// ---------------------------------------------------------------------
|
|
|
|
void PERL5::initialize()
|
|
{
|
|
|
|
char filen[256];
|
|
|
|
if (!module){
|
|
module = "swig";
|
|
fprintf(stderr,"SWIG : *** Warning. No module name specified.\n");
|
|
}
|
|
|
|
if (!package) {
|
|
package = new char[strlen(module)+1];
|
|
strcpy(package,module);
|
|
}
|
|
|
|
// If we're in blessed mode, change the package name to "packagec"
|
|
|
|
if (blessed) {
|
|
char *newpackage = new char[strlen(package)+2];
|
|
sprintf(newpackage,"%sc",package);
|
|
realpackage = package;
|
|
package = newpackage;
|
|
} else {
|
|
realpackage = package;
|
|
}
|
|
|
|
// Create a .pm file
|
|
// Need to strip off any prefixes that might be found in
|
|
// the module name
|
|
|
|
{
|
|
char *m = module + strlen(module);
|
|
while (m != module) {
|
|
if (*m == ':') {
|
|
m++;
|
|
break;
|
|
}
|
|
m--;
|
|
}
|
|
sprintf(filen,"%s%s.pm", output_dir,m);
|
|
if ((f_pm = fopen(filen,"w")) == 0) {
|
|
fprintf(stderr,"Unable to open %s\n", filen);
|
|
SWIG_exit(0);
|
|
}
|
|
}
|
|
if (!blessed) {
|
|
smodule = module;
|
|
} else if (is_static) {
|
|
smodule = new char[strlen(module)+2];
|
|
strcpy(smodule,module);
|
|
strcat(smodule,"c");
|
|
cmodule << "c";
|
|
} else {
|
|
smodule = module;
|
|
}
|
|
|
|
fprintf(f_header,"#define SWIG_init boot_%s\n\n", cmodule.get());
|
|
fprintf(f_header,"#define SWIG_name \"%s::boot_%s\"\n", package, cmodule.get());
|
|
fprintf(f_header,"#define SWIG_varinit \"%s::var_%s_init();\"\n", package, cmodule.get());
|
|
fprintf(f_header,"#ifdef __cplusplus\n");
|
|
fprintf(f_header,"extern \"C\"\n");
|
|
fprintf(f_header,"#endif\n");
|
|
fprintf(f_header,"#ifndef PERL_OBJECT\n");
|
|
fprintf(f_header,"SWIGEXPORT(void) boot_%s(CV* cv);\n", cmodule.get());
|
|
fprintf(f_header,"#else\n");
|
|
fprintf(f_header,"SWIGEXPORT(void) boot_%s(CV *cv, CPerlObj *);\n",cmodule.get());
|
|
fprintf(f_header,"#endif\n");
|
|
fprintf(f_init,"#ifdef __cplusplus\n");
|
|
fprintf(f_init,"extern \"C\"\n");
|
|
fprintf(f_init,"#endif\n");
|
|
fprintf(f_init,"XS(boot_%s) {\n", cmodule.get());
|
|
fprintf(f_init,"\t dXSARGS;\n");
|
|
fprintf(f_init,"\t char *file = __FILE__;\n");
|
|
fprintf(f_init,"\t cv = cv; items = items;\n");
|
|
fprintf(f_init,"\t newXS(\"%s::var_%s_init\", _wrap_perl5_%s_var_init, file);\n",package,cmodule.get(), cmodule.get());
|
|
vinit << "XS(_wrap_perl5_" << cmodule << "_var_init) {\n"
|
|
<< tab4 << "dXSARGS;\n"
|
|
<< tab4 << "SV *sv;\n"
|
|
<< tab4 << "cv = cv; items = items;\n";
|
|
|
|
fprintf(f_pm,"# This file was automatically generated by SWIG\n");
|
|
fprintf(f_pm,"package %s;\n",module);
|
|
fprintf(f_pm,"require Exporter;\n");
|
|
if (!is_static) {
|
|
fprintf(f_pm,"require DynaLoader;\n");
|
|
fprintf(f_pm,"@ISA = qw(Exporter DynaLoader);\n");
|
|
} else {
|
|
fprintf(f_pm,"@ISA = qw(Exporter);\n");
|
|
}
|
|
|
|
// Start creating magic code
|
|
|
|
|
|
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(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"; // Dump out external module declarations
|
|
|
|
/* Process additional initialization files here */
|
|
|
|
if (strlen(modinit.get()) > 0) {
|
|
fprintf(f_header,"%s\n",modinit.get());
|
|
}
|
|
if (strlen(modextern.get()) > 0) {
|
|
fprintf(f_header,"%s\n",modextern.get());
|
|
}
|
|
}
|
|
|
|
// ---------------------------------------------------------------------
|
|
// PERL5::import(char *filename)
|
|
//
|
|
// Import directive
|
|
// ---------------------------------------------------------------------
|
|
|
|
void PERL5::import(char *filename) {
|
|
if (import_file) delete [] import_file;
|
|
import_file = copy_string(filename);
|
|
}
|
|
|
|
|
|
// ---------------------------------------------------------------------
|
|
// PERL5::close(void)
|
|
//
|
|
// Wrap things up. Close initialization function.
|
|
// ---------------------------------------------------------------------
|
|
|
|
void PERL5::close(void)
|
|
{
|
|
String base;
|
|
|
|
// Dump out variable wrappers
|
|
|
|
magic << "\n\n#ifdef PERL_OBJECT\n"
|
|
<< "};\n"
|
|
<< "#endif\n";
|
|
|
|
fprintf(f_header,"%s\n", magic.get());
|
|
|
|
emit_ptr_equivalence(f_init);
|
|
|
|
fprintf(f_init,"\t ST(0) = &PL_sv_yes;\n");
|
|
fprintf(f_init,"\t XSRETURN(1);\n");
|
|
fprintf(f_init,"}\n");
|
|
|
|
vinit << tab4 << "XSRETURN(1);\n"
|
|
<< "}\n";
|
|
|
|
fprintf(f_pm,"package %s;\n", package);
|
|
|
|
if (!is_static) {
|
|
fprintf(f_pm,"bootstrap %s;\n", smodule);
|
|
} else {
|
|
fprintf(f_pm,"boot_%s();\n", smodule);
|
|
}
|
|
fprintf(f_pm,"var_%s_init();\n", cmodule.get());
|
|
fprintf(f_pm,"%s",pragma_include.get());
|
|
fprintf(f_pm,"package %s;\n", realpackage);
|
|
fprintf(f_pm,"@EXPORT = qw(%s );\n",exported.get());
|
|
|
|
if (blessed) {
|
|
|
|
base << "\n# ---------- BASE METHODS -------------\n\n"
|
|
<< "package " << realpackage << ";\n\n";
|
|
|
|
// Write out the TIE method
|
|
|
|
base << "sub TIEHASH {\n"
|
|
<< tab4 << "my ($classname,$obj) = @_;\n"
|
|
<< tab4 << "return bless $obj, $classname;\n"
|
|
<< "}\n\n";
|
|
|
|
// 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.
|
|
|
|
base << "sub CLEAR { }\n\n";
|
|
|
|
// Output default firstkey/nextkey methods
|
|
|
|
base << "sub FIRSTKEY { }\n\n";
|
|
base << "sub NEXTKEY { }\n\n";
|
|
|
|
// Output a 'this' method
|
|
|
|
base << "sub this {\n"
|
|
<< tab4 << "my $ptr = shift;\n"
|
|
<< tab4 << "return tied(%$ptr);\n"
|
|
<< "}\n\n";
|
|
|
|
fprintf(f_pm,"%s",base.get());
|
|
|
|
// Emit function stubs for stand-alone functions
|
|
|
|
fprintf(f_pm,"\n# ------- FUNCTION WRAPPERS --------\n\n");
|
|
fprintf(f_pm,"package %s;\n\n",realpackage);
|
|
fprintf(f_pm,"%s",func_stubs.get());
|
|
|
|
|
|
// Emit package code for different classes
|
|
|
|
fprintf(f_pm,"%s",pm.get());
|
|
|
|
// Emit variable stubs
|
|
|
|
fprintf(f_pm,"\n# ------- VARIABLE STUBS --------\n\n");
|
|
fprintf(f_pm,"package %s;\n\n",realpackage);
|
|
fprintf(f_pm,"%s",var_stubs.get());
|
|
|
|
}
|
|
|
|
fprintf(f_pm,"1;\n");
|
|
fclose(f_pm);
|
|
|
|
// Patch up documentation title
|
|
|
|
if ((doc_entry) && (module)) {
|
|
doc_entry->cinfo << "Module : " << module << ", "
|
|
<< "Package : " << realpackage;
|
|
}
|
|
|
|
}
|
|
|
|
// ----------------------------------------------------------------------
|
|
// char *PERL5::type_mangle(DataType *t)
|
|
//
|
|
// Mangles a datatype into a Perl5 name compatible with xsubpp type
|
|
// T_PTROBJ.
|
|
// ----------------------------------------------------------------------
|
|
|
|
char *
|
|
PERL5::type_mangle(DataType *t) {
|
|
static char result[128];
|
|
int i;
|
|
char *r, *c;
|
|
|
|
if (blessed) {
|
|
|
|
// Check to see if we've blessed this datatype
|
|
|
|
if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
|
|
|
|
// This is a blessed class. Return just the type-name
|
|
strcpy(result,(char *) classes.lookup(t->name));
|
|
return result;
|
|
}
|
|
}
|
|
|
|
r = result;
|
|
c = t->name;
|
|
|
|
for ( c = t->name; *c; c++,r++) {
|
|
*r = *c;
|
|
}
|
|
for (i = 0; i < (t->is_pointer-t->implicit_ptr); i++, r++) {
|
|
strcpy(r,"Ptr");
|
|
r+=2;
|
|
}
|
|
*r = 0;
|
|
return result;
|
|
}
|
|
|
|
// ----------------------------------------------------------------------
|
|
// PERL5::get_pointer(char *iname, char *srcname, char *src, char *target,
|
|
// DataType *t, String &f, char *ret)
|
|
//
|
|
// Emits code to get a pointer from a parameter and do type checking.
|
|
// ----------------------------------------------------------------------
|
|
|
|
void PERL5::get_pointer(char *iname, char *srcname, char *src, char *dest,
|
|
DataType *t, String &f, char *ret) {
|
|
|
|
// Now get the pointer value from the string and save in dest
|
|
|
|
f << tab4 << "if (SWIG_GetPtr(" << src << ",(void **) &" << dest << ",";
|
|
|
|
// If we're passing a void pointer, we give the pointer conversion a NULL
|
|
// pointer, otherwise pass in the expected type.
|
|
|
|
if (t->type == T_VOID) f << "(char *) 0 )) {\n";
|
|
else
|
|
f << "\"" << t->print_mangle() << "\")) {\n";
|
|
|
|
// This part handles the type checking according to three different
|
|
// levels. 0 = no checking, 1 = warning message, 2 = strict.
|
|
|
|
switch(TypeStrict) {
|
|
case 0: // No type checking
|
|
f << tab4 << "}\n";
|
|
break;
|
|
|
|
case 1: // Warning message only
|
|
|
|
// Change this part to how you want to handle a type-mismatch warning.
|
|
// By default, it will just print to stderr.
|
|
|
|
f << tab8 << "fprintf(stderr,\"Warning : type mismatch in " << srcname
|
|
<< " of " << iname << ". Expected " << t->print_mangle()
|
|
<< ", received %s\\n\"," << src << ");\n"
|
|
<< tab4 << "}\n";
|
|
|
|
break;
|
|
case 2: // Super strict mode.
|
|
|
|
// Change this part to return an error.
|
|
|
|
f << tab8 << "croak(\"Type error in " << srcname
|
|
<< " of " << iname << ". Expected " << t->print_mangle() << ".\");\n"
|
|
<< tab8 << ret << ";\n"
|
|
<< tab4 << "}\n";
|
|
|
|
break;
|
|
|
|
default :
|
|
fprintf(stderr,"SWIG Error. Unknown strictness level\n");
|
|
break;
|
|
}
|
|
}
|
|
|
|
// ----------------------------------------------------------------------
|
|
// PERL5::create_command(char *cname, char *iname)
|
|
//
|
|
// Create a command and register it with the interpreter
|
|
// ----------------------------------------------------------------------
|
|
|
|
void PERL5::create_command(char *cname, char *iname) {
|
|
fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, name_wrapper(cname,""));
|
|
if (export_all) {
|
|
exported << iname << " ";
|
|
}
|
|
}
|
|
|
|
// ----------------------------------------------------------------------
|
|
// PERL5::create_function(char *name, char *iname, DataType *d,
|
|
// ParmList *l)
|
|
//
|
|
// Create a function declaration and register it with the interpreter.
|
|
// ----------------------------------------------------------------------
|
|
|
|
void PERL5::create_function(char *name, char *iname, DataType *d, ParmList *l)
|
|
{
|
|
Parm *p;
|
|
int pcount,i,j;
|
|
char *wname;
|
|
char *usage = 0;
|
|
WrapperFunction f;
|
|
char source[256],target[256],temp[256], argnum[32];
|
|
char *tm;
|
|
String cleanup,outarg,build;
|
|
int numopt = 0;
|
|
int need_save, num_saved = 0; // Number of saved arguments.
|
|
int have_build = 0;
|
|
|
|
// Make a wrapper name for this
|
|
|
|
wname = name_wrapper(iname,"");
|
|
|
|
// Now write the wrapper function itself....this is pretty ugly
|
|
|
|
f.def << "XS(" << wname << ") {\n";
|
|
f.code << tab4 << "cv = cv;\n";
|
|
|
|
pcount = emit_args(d, l, f);
|
|
numopt = l->numopt();
|
|
|
|
f.add_local("int","argvi = 0");
|
|
|
|
// Check the number of arguments
|
|
|
|
usage = usage_func(iname,d,l);
|
|
f.code << tab4 << "if ((items < " << (pcount-numopt) << ") || (items > " << l->numarg() << ")) \n"
|
|
<< tab8 << "croak(\"Usage: " << usage << "\");\n";
|
|
|
|
// Write code to extract parameters.
|
|
// This section should be able to extract virtually any kind
|
|
// parameter, represented as a string
|
|
|
|
i = 0;
|
|
j = 0;
|
|
p = l->get_first();
|
|
while (p != 0) {
|
|
// Produce string representation of source and target arguments
|
|
sprintf(source,"ST(%d)",j);
|
|
sprintf(target,"_arg%d",i);
|
|
sprintf(argnum,"%d",j+1);
|
|
|
|
// Check to see if this argument is being ignored
|
|
|
|
if (!p->ignore) {
|
|
|
|
// If there are optional arguments, check for this
|
|
|
|
if (j>= (pcount-numopt))
|
|
f.code << tab4 << "if (items > " << j << ") {\n";
|
|
|
|
// See if there is a type-map
|
|
if ((tm = typemap_lookup("in","perl5",p->t,p->name,source,target,&f))) {
|
|
f.code << tm << "\n";
|
|
f.code.replace("$argnum",argnum);
|
|
f.code.replace("$arg",source);
|
|
} else {
|
|
|
|
if (!p->t->is_pointer) {
|
|
|
|
// Extract a parameter by "value"
|
|
|
|
switch(p->t->type) {
|
|
|
|
// Integers
|
|
|
|
case T_BOOL:
|
|
case T_INT :
|
|
case T_SHORT :
|
|
case T_LONG :
|
|
case T_SINT :
|
|
case T_SSHORT:
|
|
case T_SLONG:
|
|
case T_SCHAR:
|
|
case T_UINT:
|
|
case T_USHORT:
|
|
case T_ULONG:
|
|
case T_UCHAR:
|
|
f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
|
|
<< "SvIV(ST(" << j << "));\n";
|
|
break;
|
|
case T_CHAR :
|
|
|
|
|
|
|
|
f.code << tab4 << "_arg" << i << " = (char) *SvPV(ST(" << j << "),PL_na);\n";
|
|
break;
|
|
|
|
// Doubles
|
|
|
|
case T_DOUBLE :
|
|
case T_FLOAT :
|
|
f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
|
|
<< " SvNV(ST(" << j << "));\n";
|
|
break;
|
|
|
|
// Void.. Do nothing.
|
|
|
|
case T_VOID :
|
|
break;
|
|
|
|
// User defined. This is invalid here. Note, user-defined types by
|
|
// value are handled in the parser.
|
|
|
|
case T_USER:
|
|
|
|
// Unsupported data type
|
|
|
|
default :
|
|
fprintf(stderr,"%s : Line %d. Unable to use type %s as a function argument.\n",input_file, line_number, p->t->print_type());
|
|
break;
|
|
}
|
|
} else {
|
|
|
|
// Argument is a pointer type. Special case is for char *
|
|
// since that is usually a string.
|
|
|
|
if ((p->t->type == T_CHAR) && (p->t->is_pointer == 1)) {
|
|
f.code << tab4 << "if (! SvOK((SV*) ST(" << j << "))) { "
|
|
<< "_arg" << i << " = 0; }\n";
|
|
f.code << tab4 << "else { _arg"
|
|
<< i << " = (char *) SvPV(ST(" << j << "),PL_na); }\n";
|
|
} else {
|
|
|
|
// Have a generic pointer type here. Read it in as a swig
|
|
// typed pointer.
|
|
|
|
sprintf(temp,"argument %d", i+1);
|
|
get_pointer(iname,temp,source,target, p->t, f.code, "XSRETURN(1)");
|
|
}
|
|
}
|
|
}
|
|
// The source is going to be an array of saved values.
|
|
|
|
sprintf(temp,"_saved[%d]",num_saved);
|
|
if (j>= (pcount-numopt))
|
|
f.code << tab4 << "} \n";
|
|
j++;
|
|
} else {
|
|
temp[0] = 0;
|
|
}
|
|
// Check to see if there is any sort of "build" typemap (highly complicated)
|
|
|
|
if ((tm = typemap_lookup("build","perl5",p->t,p->name,source,target))) {
|
|
build << tm << "\n";
|
|
have_build = 1;
|
|
}
|
|
|
|
// Check if there is any constraint code
|
|
if ((tm = typemap_lookup("check","perl5",p->t,p->name,source,target))) {
|
|
f.code << tm << "\n";
|
|
f.code.replace("$argnum",argnum);
|
|
}
|
|
need_save = 0;
|
|
|
|
if ((tm = typemap_lookup("freearg","perl5",p->t,p->name,target,temp))) {
|
|
cleanup << tm << "\n";
|
|
cleanup.replace("$argnum",argnum);
|
|
cleanup.replace("$arg",temp);
|
|
need_save = 1;
|
|
}
|
|
if ((tm = typemap_lookup("argout","perl5",p->t,p->name,target,"ST(argvi)"))) {
|
|
String tempstr;
|
|
tempstr = tm;
|
|
tempstr.replace("$argnum",argnum);
|
|
tempstr.replace("$arg",temp);
|
|
outarg << tempstr << "\n";
|
|
need_save = 1;
|
|
}
|
|
// If we needed a saved variable, we need to emit to emit some code for that
|
|
// This only applies if the argument actually existed (not ignore)
|
|
if ((need_save) && (!p->ignore)) {
|
|
f.code << tab4 << temp << " = " << source << ";\n";
|
|
num_saved++;
|
|
}
|
|
p = l->get_next();
|
|
i++;
|
|
}
|
|
|
|
// If there were any saved arguments, emit a local variable for them
|
|
|
|
if (num_saved) {
|
|
sprintf(temp,"_saved[%d]",num_saved);
|
|
f.add_local("SV *",temp);
|
|
}
|
|
|
|
// If there was a "build" typemap, we need to go in and perform a serious hack
|
|
|
|
if (have_build) {
|
|
char temp1[32];
|
|
char temp2[256];
|
|
l->sub_parmnames(build); // Replace all parameter names
|
|
j = 1;
|
|
for (i = 0; i < l->nparms; i++) {
|
|
p = l->get(i);
|
|
if (strlen(p->name) > 0) {
|
|
sprintf(temp1,"_in_%s", p->name);
|
|
} else {
|
|
sprintf(temp1,"_in_arg%d", i);
|
|
}
|
|
sprintf(temp2,"argv[%d]",j);
|
|
build.replaceid(temp1,temp2);
|
|
if (!p->ignore)
|
|
j++;
|
|
}
|
|
f.code << build;
|
|
}
|
|
|
|
// Now write code to make the function call
|
|
|
|
emit_func_call(name,d,l,f);
|
|
|
|
// See if there was a typemap
|
|
|
|
if ((tm = typemap_lookup("out","perl5",d,iname,"_result","ST(argvi)"))) {
|
|
// Yep. Use it instead of the default
|
|
f.code << tm << "\n";
|
|
} else if ((d->type != T_VOID) || (d->is_pointer)) {
|
|
if (!d->is_pointer) {
|
|
|
|
// Function returns a "value"
|
|
f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
|
|
switch(d->type) {
|
|
case T_INT: case T_BOOL: case T_SINT: case T_UINT:
|
|
case T_SHORT: case T_SSHORT: case T_USHORT:
|
|
case T_LONG : case T_SLONG : case T_ULONG:
|
|
case T_SCHAR: case T_UCHAR :
|
|
f.code << tab4 << "sv_setiv(ST(argvi++),(IV) _result);\n";
|
|
break;
|
|
case T_DOUBLE :
|
|
case T_FLOAT :
|
|
f.code << tab4 << "sv_setnv(ST(argvi++), (double) _result);\n";
|
|
break;
|
|
case T_CHAR :
|
|
f.add_local("char", "_ctemp[2]");
|
|
f.code << tab4 << "_ctemp[0] = _result;\n"
|
|
<< tab4 << "_ctemp[1] = 0;\n"
|
|
<< tab4 << "sv_setpv((SV*)ST(argvi++),_ctemp);\n";
|
|
break;
|
|
|
|
// Return a complex type by value
|
|
|
|
case T_USER:
|
|
d->is_pointer++;
|
|
f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
|
|
<< "\", (void *) _result);\n";
|
|
d->is_pointer--;
|
|
break;
|
|
|
|
default :
|
|
fprintf(stderr,"%s: Line %d. Unable to use return type %s in function %s.\n", input_file, line_number, d->print_type(), name);
|
|
break;
|
|
}
|
|
} else {
|
|
|
|
// Is a pointer return type
|
|
f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
|
|
if ((d->type == T_CHAR) && (d->is_pointer == 1)) {
|
|
|
|
// Return a character string
|
|
f.code << tab4 << "sv_setpv((SV*)ST(argvi++),(char *) _result);\n";
|
|
|
|
} else {
|
|
// Is an ordinary pointer type.
|
|
f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
|
|
<< "\", (void *) _result);\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
// If there were any output args, take care of them.
|
|
|
|
f.code << outarg;
|
|
|
|
// If there was any cleanup, do that.
|
|
|
|
f.code << cleanup;
|
|
|
|
if (NewObject) {
|
|
if ((tm = typemap_lookup("newfree","perl5",d,iname,"_result",""))) {
|
|
f.code << tm << "\n";
|
|
}
|
|
}
|
|
|
|
if ((tm = typemap_lookup("ret","perl5",d,iname,"_result",""))) {
|
|
// Yep. Use it instead of the default
|
|
f.code << tm << "\n";
|
|
}
|
|
|
|
// Wrap things up (in a manner of speaking)
|
|
|
|
f.code << tab4 << "XSRETURN(argvi);\n}\n";
|
|
|
|
// Add the dXSARGS last
|
|
|
|
f.add_local("dXSARGS","");
|
|
|
|
// Substitute the cleanup code
|
|
f.code.replace("$cleanup",cleanup);
|
|
f.code.replace("$name",iname);
|
|
|
|
// Dump this function out
|
|
|
|
f.print(f_wrappers);
|
|
|
|
// Create a first crack at a documentation entry
|
|
|
|
if (doc_entry) {
|
|
static DocEntry *last_doc_entry = 0;
|
|
doc_entry->usage << usage;
|
|
if (last_doc_entry != doc_entry) {
|
|
doc_entry->cinfo << "returns " << d->print_type();
|
|
last_doc_entry = doc_entry;
|
|
}
|
|
}
|
|
|
|
// Now register the function
|
|
|
|
fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, wname);
|
|
|
|
if (export_all) {
|
|
exported << iname << " ";
|
|
}
|
|
|
|
|
|
// --------------------------------------------------------------------
|
|
// Create a stub for this function, provided it's not a member function
|
|
//
|
|
// Really we only need to create a stub if this function involves
|
|
// complex datatypes. If it does, we'll make a small wrapper to
|
|
// process the arguments. If it doesn't, we'll just make a symbol
|
|
// table entry.
|
|
// --------------------------------------------------------------------
|
|
|
|
if ((blessed) && (!member_func)) {
|
|
int need_stub = 0;
|
|
String func;
|
|
|
|
// We'll make a stub since we may need it anyways
|
|
|
|
func << "sub " << iname << " {\n"
|
|
<< tab4 << "my @args = @_;\n";
|
|
|
|
|
|
// Now we have to go through and patch up the argument list. If any
|
|
// arguments to our function correspond to other Perl objects, we
|
|
// need to extract them from a tied-hash table object.
|
|
|
|
Parm *p = l->get_first();
|
|
int i = 0;
|
|
while(p) {
|
|
|
|
if (!p->ignore) {
|
|
// Look up the datatype name here
|
|
|
|
if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
|
|
if (i >= (pcount - numopt))
|
|
func << tab4 << "if (scalar(@args) >= " << i << ") {\n" << tab4;
|
|
|
|
func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
|
|
|
|
if (i >= (pcount - numopt))
|
|
func << tab4 << "}\n";
|
|
|
|
need_stub = 1;
|
|
}
|
|
i++;
|
|
}
|
|
p = l->get_next();
|
|
}
|
|
|
|
func << tab4 << "my $result = " << package << "::" << iname << "(@args);\n";
|
|
|
|
// Now check to see what kind of return result was found.
|
|
// If this function is returning a result by 'value', SWIG did an
|
|
// implicit malloc/new. We'll mark the object like it was created
|
|
// in Perl so we can garbage collect it.
|
|
|
|
if ((classes.lookup(d->name)) && (d->is_pointer <=1)) {
|
|
|
|
func << tab4 << "return undef if (!defined($result));\n";
|
|
|
|
// If we're returning an object by value, put it's reference
|
|
// into our local hash table
|
|
|
|
if ((d->is_pointer == 0) || ((d->is_pointer == 1) && NewObject)) {
|
|
func << tab4 << "$" << (char *) classes.lookup(d->name) << "::OWNER{$result} = 1;\n";
|
|
}
|
|
|
|
// We're returning a Perl "object" of some kind. Turn it into
|
|
// a tied hash
|
|
|
|
func << tab4 << "my %resulthash;\n"
|
|
/* << tab4 << "tie %resulthash, \"" << (char *) classes.lookup(d->name) << "\", $result;\n"
|
|
<< tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(d->name) << "\";\n"
|
|
*/
|
|
<< tab4 << "tie %resulthash, ref($result), $result;\n"
|
|
<< tab4 << "return bless \\%resulthash, ref($result);\n"
|
|
<< "}\n";
|
|
|
|
need_stub = 1;
|
|
} else {
|
|
|
|
// Hmmm. This doesn't appear to be anything I know about so just
|
|
// return it unmolested.
|
|
|
|
func << tab4 <<"return $result;\n"
|
|
<< "}\n";
|
|
|
|
}
|
|
|
|
// Now check if we needed the stub. If so, emit it, otherwise
|
|
// Emit code to hack Perl's symbol table instead
|
|
|
|
if (need_stub) {
|
|
func_stubs << func;
|
|
} else {
|
|
func_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
// -----------------------------------------------------------------------
|
|
// PERL5::link_variable(char *name, char *iname, DataType *d)
|
|
//
|
|
// Create a link to a C variable.
|
|
// -----------------------------------------------------------------------
|
|
|
|
void PERL5::link_variable(char *name, char *iname, DataType *t)
|
|
{
|
|
char set_name[256];
|
|
char val_name[256];
|
|
WrapperFunction getf, setf;
|
|
char *tm;
|
|
sprintf(set_name,"_wrap_set_%s",iname);
|
|
sprintf(val_name,"_wrap_val_%s",iname);
|
|
|
|
// Create a new scalar that we will attach magic to
|
|
|
|
vinit << tab4 << "sv = perl_get_sv(\"" << package << "::" << iname << "\",TRUE | 0x2);\n";
|
|
|
|
// Create a Perl function for setting the variable value
|
|
|
|
if (!(Status & STAT_READONLY)) {
|
|
setf.def << "SWIGCLASS_STATIC int " << set_name << "(SV* sv, MAGIC *mg) {\n";
|
|
|
|
setf.code << tab4 << "MAGIC_PPERL\n";
|
|
setf.code << tab4 << "mg = mg;\n";
|
|
|
|
/* Check for a few typemaps */
|
|
if ((tm = typemap_lookup("varin","perl5",t,"","sv",name))) {
|
|
setf.code << tm << "\n";
|
|
} else if ((tm = typemap_lookup("in","perl5",t,"","sv",name))) {
|
|
setf.code << tm << "\n";
|
|
} else {
|
|
if (!t->is_pointer) {
|
|
|
|
// Set the value to something
|
|
|
|
switch(t->type) {
|
|
case T_INT : case T_BOOL: case T_SINT : case T_UINT:
|
|
case T_SHORT : case T_SSHORT : case T_USHORT:
|
|
case T_LONG : case T_SLONG : case T_ULONG:
|
|
case T_UCHAR: case T_SCHAR:
|
|
setf.code << tab4 << name << " = " << t->print_cast() << " SvIV(sv);\n";
|
|
break;
|
|
case T_DOUBLE :
|
|
case T_FLOAT :
|
|
setf.code << tab4 << name << " = " << t->print_cast() << " SvNV(sv);\n";
|
|
break;
|
|
case T_CHAR :
|
|
setf.code << tab4 << name << " = (char) *SvPV(sv,PL_na);\n";
|
|
break;
|
|
|
|
case T_USER:
|
|
|
|
// Add support for User defined type here
|
|
// Get as a pointer value
|
|
|
|
t->is_pointer++;
|
|
setf.add_local("void","*_temp");
|
|
get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
|
|
setf.code << tab4 << name << " = *(" << t->print_cast() << " _temp);\n";
|
|
t->is_pointer--;
|
|
break;
|
|
|
|
default :
|
|
fprintf(stderr,"%s : Line %d. Unable to link with datatype %s (ignored).\n", input_file, line_number, t->print_type());
|
|
return;
|
|
}
|
|
} else {
|
|
// Have some sort of pointer type here, Process it differently
|
|
if ((t->type == T_CHAR) && (t->is_pointer == 1)) {
|
|
setf.add_local("char","*_a");
|
|
setf.code << tab4 << "_a = (char *) SvPV(sv,PL_na);\n";
|
|
|
|
if (CPlusPlus)
|
|
setf.code << tab4 << "if (" << name << ") delete [] " << name << ";\n"
|
|
<< tab4 << name << " = new char[strlen(_a)+1];\n";
|
|
else
|
|
setf.code << tab4 << "if (" << name << ") free(" << name << ");\n"
|
|
<< tab4 << name << " = (char *) malloc(strlen(_a)+1);\n";
|
|
setf.code << "strcpy(" << name << ",_a);\n";
|
|
} else {
|
|
// Set the value of a pointer
|
|
|
|
setf.add_local("void","*_temp");
|
|
get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
|
|
setf.code << tab4 << name << " = " << t->print_cast() << " _temp;\n";
|
|
}
|
|
}
|
|
}
|
|
setf.code << tab4 << "return 1;\n"
|
|
<< "}\n";
|
|
|
|
setf.code.replace("$name",iname);
|
|
setf.print(magic);
|
|
|
|
}
|
|
|
|
// Now write a function to evaluate the variable
|
|
|
|
getf.def << "SWIGCLASS_STATIC int " << val_name << "(SV *sv, MAGIC *mg) {\n";
|
|
getf.code << tab4 << "MAGIC_PPERL\n";
|
|
getf.code << tab4 << "mg = mg;\n";
|
|
|
|
// Check for a typemap
|
|
|
|
if ((tm = typemap_lookup("varout","perl5",t,"",name, "sv"))) {
|
|
getf.code << tm << "\n";
|
|
} else if ((tm = typemap_lookup("out","perl5",t,"",name,"sv"))) {
|
|
setf.code << tm << "\n";
|
|
} else {
|
|
if (!t->is_pointer) {
|
|
switch(t->type) {
|
|
case T_INT : case T_BOOL: case T_SINT: case T_UINT:
|
|
case T_SHORT : case T_SSHORT: case T_USHORT:
|
|
case T_LONG : case T_SLONG : case T_ULONG:
|
|
case T_UCHAR: case T_SCHAR:
|
|
getf.code << tab4 << "sv_setiv(sv, (IV) " << name << ");\n";
|
|
vinit << tab4 << "sv_setiv(sv,(IV)" << name << ");\n";
|
|
break;
|
|
case T_DOUBLE :
|
|
case T_FLOAT :
|
|
getf.code << tab4 << "sv_setnv(sv, (double) " << name << ");\n";
|
|
vinit << tab4 << "sv_setnv(sv,(double)" << name << ");\n";
|
|
break;
|
|
case T_CHAR :
|
|
getf.add_local("char","_ptemp[2]");
|
|
getf.code << tab4 << "_ptemp[0] = " << name << ";\n"
|
|
<< tab4 << "_ptemp[1] = 0;\n"
|
|
<< tab4 << "sv_setpv((SV*) sv, _ptemp);\n";
|
|
break;
|
|
case T_USER:
|
|
t->is_pointer++;
|
|
getf.code << tab4 << "rsv = SvRV(sv);\n"
|
|
<< tab4 << "sv_setiv(rsv,(IV) &" << name << ");\n";
|
|
|
|
// getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
|
|
// << "\", (void *) &" << name << ");\n";
|
|
|
|
getf.add_local("SV","*rsv");
|
|
vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) &" << name << ");\n";
|
|
t->is_pointer--;
|
|
|
|
break;
|
|
default :
|
|
break;
|
|
}
|
|
} else {
|
|
|
|
// Have some sort of arbitrary pointer type. Return it as a string
|
|
|
|
if ((t->type == T_CHAR) && (t->is_pointer == 1))
|
|
getf.code << tab4 << "sv_setpv((SV*) sv, " << name << ");\n";
|
|
else {
|
|
getf.code << tab4 << "rsv = SvRV(sv);\n"
|
|
<< tab4 << "sv_setiv(rsv,(IV) " << name << ");\n";
|
|
getf.add_local("SV","*rsv");
|
|
vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) 1);\n";
|
|
|
|
//getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
|
|
// << "\", (void *) " << name << ");\n";
|
|
}
|
|
}
|
|
}
|
|
getf.code << tab4 << "return 1;\n"
|
|
<< "}\n";
|
|
|
|
getf.code.replace("$name",iname);
|
|
getf.print(magic);
|
|
|
|
// Now add symbol to the PERL interpreter
|
|
if (Status & STAT_READONLY) {
|
|
vinit << tab4 << "swig_create_magic(sv,\"" << package << "::" << iname << "\",MAGIC_CAST MAGIC_CLASS swig_magic_readonly, MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
|
|
} else {
|
|
vinit << tab4 << "swig_create_magic(sv,\"" << package << "::" << iname << "\", MAGIC_CAST MAGIC_CLASS " << set_name << ", MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
|
|
}
|
|
// Add a documentation entry
|
|
|
|
if (doc_entry) {
|
|
doc_entry->usage << usage_var(iname,t);
|
|
doc_entry->cinfo << "Global : " << t->print_type() << " " << name;
|
|
}
|
|
|
|
// 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 ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
|
|
var_stubs << "\nmy %__" << iname << "_hash;\n"
|
|
<< "tie %__" << iname << "_hash,\"" << (char *) classes.lookup(t->name) << "\", $"
|
|
<< package << "::" << iname << ";\n"
|
|
<< "$" << iname << "= \\%__" << iname << "_hash;\n"
|
|
<< "bless $" << iname << ", " << (char *) classes.lookup(t->name) << ";\n";
|
|
} else {
|
|
var_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
|
|
}
|
|
if (export_all)
|
|
exported << "$" << name << " ";
|
|
}
|
|
}
|
|
|
|
// -----------------------------------------------------------------------
|
|
// PERL5::declare_const(char *name, char *iname, DataType *type, char *value)
|
|
//
|
|
// Makes a constant. Really just creates a variable and creates a read-only
|
|
// link to it.
|
|
// ------------------------------------------------------------------------
|
|
|
|
// Functions used to create constants
|
|
|
|
static const char *setiv = "#ifndef PERL_OBJECT\
|
|
\n#define swig_setiv(a,b) _swig_setiv(a,b)\
|
|
\nstatic void _swig_setiv(char *name, long value) { \
|
|
\n#else\
|
|
\n#define swig_setiv(a,b) _swig_setiv(pPerl,a,b)\
|
|
\nstatic void _swig_setiv(CPerlObj *pPerl, char *name, long value) { \
|
|
\n#endif\
|
|
\n SV *sv; \
|
|
\n sv = perl_get_sv(name,TRUE | 0x2);\
|
|
\n sv_setiv(sv, (IV) value);\
|
|
\n SvREADONLY_on(sv);\
|
|
\n}\n";
|
|
|
|
static const char *setnv = "#ifndef PERL_OBJECT\
|
|
\n#define swig_setnv(a,b) _swig_setnv(a,b)\
|
|
\nstatic void _swig_setnv(char *name, double value) { \
|
|
\n#else\
|
|
\n#define swig_setnv(a,b) _swig_setnv(pPerl,a,b)\
|
|
\nstatic void _swig_setnv(CPerlObj *pPerl, char *name, double value) { \
|
|
\n#endif\
|
|
\n SV *sv; \
|
|
\n sv = perl_get_sv(name,TRUE | 0x2);\
|
|
\n sv_setnv(sv, value);\
|
|
\n SvREADONLY_on(sv);\
|
|
\n}\n";
|
|
|
|
static const char *setpv = "#ifndef PERL_OBJECT\
|
|
\n#define swig_setpv(a,b) _swig_setpv(a,b)\
|
|
\nstatic void _swig_setpv(char *name, char *value) { \
|
|
\n#else\
|
|
\n#define swig_setpv(a,b) _swig_setpv(pPerl,a,b)\
|
|
\nstatic void _swig_setpv(CPerlObj *pPerl, char *name, char *value) { \
|
|
\n#endif\
|
|
\n SV *sv; \
|
|
\n sv = perl_get_sv(name,TRUE | 0x2);\
|
|
\n sv_setpv(sv, value);\
|
|
\n SvREADONLY_on(sv);\
|
|
\n}\n";
|
|
|
|
static const char *setrv = "#ifndef PERL_OBJECT\
|
|
\n#define swig_setrv(a,b,c) _swig_setrv(a,b,c)\
|
|
\nstatic void _swig_setrv(char *name, void *value, char *type) { \
|
|
\n#else\
|
|
\n#define swig_setrv(a,b,c) _swig_setrv(pPerl,a,b,c)\
|
|
\nstatic void _swig_setrv(CPerlObj *pPerl, char *name, void *value, char *type) { \
|
|
\n#endif\
|
|
\n SV *sv; \
|
|
\n sv = perl_get_sv(name,TRUE | 0x2);\
|
|
\n sv_setref_pv(sv, type, value);\
|
|
\n SvREADONLY_on(sv);\
|
|
\n}\n";
|
|
|
|
void
|
|
PERL5::declare_const(char *name, char *, DataType *type, char *value)
|
|
{
|
|
|
|
char *tm;
|
|
static int have_int_func = 0;
|
|
static int have_double_func = 0;
|
|
static int have_char_func = 0;
|
|
static int have_ref_func = 0;
|
|
|
|
if ((tm = typemap_lookup("const","perl5",type,name,value,name))) {
|
|
fprintf(f_init,"%s\n",tm);
|
|
} else {
|
|
if ((type->type == T_USER) && (!type->is_pointer)) {
|
|
fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
|
|
return;
|
|
}
|
|
// Generate a constant
|
|
// vinit << tab4 << "sv = perl_get_sv(\"" << package << "::" << name << "\",TRUE);\n";
|
|
if (type->is_pointer == 0) {
|
|
switch(type->type) {
|
|
case T_INT:case T_SINT: case T_UINT: case T_BOOL:
|
|
case T_SHORT: case T_SSHORT: case T_USHORT:
|
|
case T_LONG: case T_SLONG: case T_ULONG:
|
|
case T_SCHAR: case T_UCHAR:
|
|
if (!have_int_func) {
|
|
fprintf(f_header,"%s\n",setiv);
|
|
have_int_func = 1;
|
|
}
|
|
vinit << tab4 << "swig_setiv(\"" << package << "::" << name << "\", (long) " << value << ");\n";
|
|
break;
|
|
case T_DOUBLE:
|
|
case T_FLOAT:
|
|
if (!have_double_func) {
|
|
fprintf(f_header,"%s\n",setnv);
|
|
have_double_func = 1;
|
|
}
|
|
vinit << tab4 << "swig_setnv(\"" << package << "::" << name << "\", (double) (" << value << "));\n";
|
|
break;
|
|
case T_CHAR :
|
|
if (!have_char_func) {
|
|
fprintf(f_header,"%s\n",setpv);
|
|
have_char_func = 1;
|
|
}
|
|
vinit << tab4 << "swig_setpv(\"" << package << "::" << name << "\", \"" << value << "\");\n";
|
|
break;
|
|
default:
|
|
fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
|
|
break;
|
|
}
|
|
} else {
|
|
if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
|
|
if (!have_char_func) {
|
|
fprintf(f_header,"%s\n",setpv);
|
|
have_char_func = 1;
|
|
}
|
|
vinit << tab4 << "swig_setpv(\"" << package << "::" << name << "\", \"" << value << "\");\n";
|
|
} else {
|
|
// A user-defined type. We're going to munge it into a string pointer value
|
|
if (!have_ref_func) {
|
|
fprintf(f_header,"%s\n",setrv);
|
|
have_ref_func = 1;
|
|
}
|
|
vinit << tab4 << "swig_setrv(\"" << package << "::" << name << "\", (void *) " << value << ", \""
|
|
<< type->print_mangle() << "\");\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
// Patch up the documentation entry
|
|
|
|
if (doc_entry) {
|
|
doc_entry->usage = "";
|
|
doc_entry->usage << usage_const(name,type,value);
|
|
doc_entry->cinfo = "";
|
|
doc_entry->cinfo << "Constant: " << type->print_type();
|
|
}
|
|
|
|
if (blessed) {
|
|
if ((classes.lookup(type->name)) && (type->is_pointer <= 1)) {
|
|
var_stubs << "\nmy %__" << name << "_hash;\n"
|
|
<< "tie %__" << name << "_hash,\"" << (char *) classes.lookup(type->name) << "\", $"
|
|
<< package << "::" << name << ";\n"
|
|
<< "$" << name << "= \\%__" << name << "_hash;\n"
|
|
<< "bless $" << name << ", " << (char *) classes.lookup(type->name) << ";\n";
|
|
} else {
|
|
var_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
|
|
}
|
|
}
|
|
if (export_all)
|
|
exported << "$" << name << " ";
|
|
}
|
|
|
|
// ----------------------------------------------------------------------
|
|
// PERL5::usage_var(char *iname, DataType *t)
|
|
//
|
|
// Produces a usage string for a Perl 5 variable.
|
|
// ----------------------------------------------------------------------
|
|
|
|
char *PERL5::usage_var(char *iname, DataType *) {
|
|
|
|
static char temp[1024];
|
|
char *c;
|
|
|
|
sprintf(temp,"$%s", iname);
|
|
c = temp + strlen(temp);
|
|
return temp;
|
|
}
|
|
|
|
// ---------------------------------------------------------------------------
|
|
// char *PERL5::usage_func(pkg, char *iname, DataType *t, ParmList *l)
|
|
//
|
|
// Produces a usage string for a function in Perl
|
|
// ---------------------------------------------------------------------------
|
|
|
|
char *PERL5::usage_func(char *iname, DataType *, ParmList *l) {
|
|
|
|
static String temp;
|
|
Parm *p;
|
|
int i;
|
|
|
|
temp = "";
|
|
temp << iname << "(";
|
|
|
|
/* Now go through and print parameters */
|
|
|
|
p = l->get_first();
|
|
i = 0;
|
|
while (p != 0) {
|
|
if (!p->ignore) {
|
|
/* If parameter has been named, use that. Otherwise, just print a type */
|
|
|
|
if ((p->t->type != T_VOID) || (p->t->is_pointer)) {
|
|
if (strlen(p->name) > 0) {
|
|
temp << p->name;
|
|
} else {
|
|
temp << p->t->print_type();
|
|
}
|
|
}
|
|
i++;
|
|
p = l->get_next();
|
|
if (p)
|
|
if (!p->ignore)
|
|
temp << ",";
|
|
} else {
|
|
p = l->get_next();
|
|
if (p)
|
|
if ((i>0) && (!p->ignore))
|
|
temp << ",";
|
|
}
|
|
}
|
|
temp << ");";
|
|
return temp.get();
|
|
}
|
|
|
|
// ----------------------------------------------------------------------
|
|
// PERL5::usage_const(char *iname, DataType *type, char *value)
|
|
//
|
|
// Produces a usage string for a Perl 5 constant
|
|
// ----------------------------------------------------------------------
|
|
|
|
char *PERL5::usage_const(char *iname, DataType *, char *value) {
|
|
|
|
static char temp[1024];
|
|
if (value) {
|
|
sprintf(temp,"$%s = %s", iname, value);
|
|
} else {
|
|
sprintf(temp,"$%s", iname);
|
|
}
|
|
return temp;
|
|
}
|
|
|
|
// -----------------------------------------------------------------------
|
|
// PERL5::add_native(char *name, char *funcname)
|
|
//
|
|
// Add a native module name to Perl5.
|
|
// -----------------------------------------------------------------------
|
|
|
|
void PERL5::add_native(char *name, char *funcname) {
|
|
fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package,name, funcname);
|
|
if (export_all)
|
|
exported << name << " ";
|
|
if (blessed) {
|
|
func_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
|
|
}
|
|
}
|
|
|
|
/****************************************************************************
|
|
*** 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.
|
|
***
|
|
*** 6. Object ownership is maintained by having a hash table
|
|
*** within in each package called "this". It is unlikely
|
|
*** that C++ program will use this so it's a somewhat
|
|
*** safe variable name.
|
|
***
|
|
****************************************************************************/
|
|
|
|
static int class_renamed = 0;
|
|
static String fullclassname;
|
|
|
|
// --------------------------------------------------------------------------
|
|
// PERL5::cpp_open_class(char *classname, char *rname, int strip)
|
|
//
|
|
// Opens a new C++ class or structure. Basically, this just records
|
|
// the class name and clears a few variables.
|
|
// --------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_open_class(char *classname, char *rname, char *ctype, int strip) {
|
|
|
|
char temp[256];
|
|
extern void typeeq_addtypedef(char *, char *);
|
|
|
|
// Register this with the default class handler
|
|
|
|
this->Language::cpp_open_class(classname, rname, ctype, strip);
|
|
|
|
if (blessed) {
|
|
have_constructor = 0;
|
|
have_destructor = 0;
|
|
have_data_members = 0;
|
|
|
|
// If the class is being renamed to something else, use the renaming
|
|
|
|
if (rname) {
|
|
class_name = copy_string(rname);
|
|
class_renamed = 1;
|
|
// Now things get even more hideous. Need to register an equivalence
|
|
// between the renamed name and the new name. Yuck!
|
|
// printf("%s %s\n", classname, rname);
|
|
typeeq_addtypedef(classname,rname);
|
|
typeeq_addtypedef(rname,classname);
|
|
/*
|
|
fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",classname,rname);
|
|
fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",rname,classname);
|
|
*/
|
|
} else {
|
|
class_name = copy_string(classname);
|
|
class_renamed = 0;
|
|
}
|
|
|
|
// A highly experimental feature. This is the fully qualified
|
|
// name of the Perl class
|
|
|
|
if (!compat) {
|
|
fullclassname = realpackage;
|
|
fullclassname << "::" << class_name;
|
|
} else {
|
|
fullclassname = class_name;
|
|
}
|
|
|
|
fullclassname = class_name;
|
|
|
|
real_classname = copy_string(classname);
|
|
if (base_class) delete base_class;
|
|
base_class = 0;
|
|
class_type = copy_string(ctype);
|
|
pcode = new String();
|
|
blessedmembers = new String();
|
|
member_keys = new String();
|
|
|
|
// Add some symbols to the hash tables
|
|
|
|
// classes.add(real_classname,copy_string(class_name)); /* Map original classname to class */
|
|
classes.add(real_classname,copy_string(fullclassname)); /* Map original classname to class */
|
|
|
|
// Add full name of datatype to the hash table just in case the user uses it
|
|
|
|
sprintf(temp,"%s %s", class_type, fullclassname.get());
|
|
// classes.add(temp,copy_string(class_name)); /* Map full classname to classs */
|
|
}
|
|
}
|
|
|
|
// -------------------------------------------------------------------------------
|
|
// PERL5::cpp_close_class()
|
|
//
|
|
// These functions close a class definition.
|
|
//
|
|
// This also sets up the hash table of classes we've seen go by.
|
|
// -------------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_close_class() {
|
|
|
|
// We need to check to make sure we got constructors, and other
|
|
// stuff here.
|
|
|
|
if (blessed) {
|
|
pm << "\n############# Class : " << fullclassname << " ##############\n";
|
|
pm << "\npackage " << fullclassname << ";\n";
|
|
|
|
// If we are inheriting from a base class, set that up
|
|
|
|
if (strcmp(class_name,realpackage))
|
|
pm << "@ISA = qw( " << realpackage;
|
|
else
|
|
pm << "@ISA = qw( ";
|
|
|
|
if (base_class) {
|
|
pm << " " << *base_class;
|
|
}
|
|
pm << " );\n";
|
|
|
|
// Dump out a hash table containing the pointers that we own
|
|
|
|
pm << "%OWNER = ();\n";
|
|
if (have_data_members) {
|
|
pm << "%BLESSEDMEMBERS = (\n"
|
|
<< blessedmembers->get()
|
|
<< ");\n\n";
|
|
}
|
|
if (have_data_members || have_destructor)
|
|
pm << "%ITERATORS = ();\n";
|
|
|
|
|
|
// Dump out the package methods
|
|
|
|
pm << *pcode;
|
|
delete pcode;
|
|
|
|
// Output methods for managing ownership
|
|
|
|
pm << "sub DISOWN {\n"
|
|
<< tab4 << "my $self = shift;\n"
|
|
<< tab4 << "my $ptr = tied(%$self);\n"
|
|
<< tab4 << "delete $OWNER{$ptr};\n"
|
|
<< tab4 << "};\n\n"
|
|
<< "sub ACQUIRE {\n"
|
|
<< tab4 << "my $self = shift;\n"
|
|
<< tab4 << "my $ptr = tied(%$self);\n"
|
|
<< tab4 << "$OWNER{$ptr} = 1;\n"
|
|
<< tab4 << "};\n\n";
|
|
|
|
// Only output the following methods if a class has member data
|
|
|
|
if (have_data_members) {
|
|
|
|
// Output a FETCH method. This is actually common to all classes
|
|
pm << "sub FETCH {\n"
|
|
<< tab4 << "my ($self,$field) = @_;\n"
|
|
<< tab4 << "my $member_func = \"" << package << "::" << name_get(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
|
|
<< tab4 << "my $val = &$member_func($self);\n"
|
|
<< tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
|
|
<< tab8 << "return undef if (!defined($val));\n"
|
|
<< tab8 << "my %retval;\n"
|
|
<< tab8 << "tie %retval,$BLESSEDMEMBERS{$field},$val;\n"
|
|
<< tab8 << "return bless \\%retval, $BLESSEDMEMBERS{$field};\n"
|
|
<< tab4 << "}\n"
|
|
<< tab4 << "return $val;\n"
|
|
<< "}\n\n";
|
|
|
|
// Output a STORE method. This is also common to all classes (might move to base class)
|
|
|
|
pm << "sub STORE {\n"
|
|
<< tab4 << "my ($self,$field,$newval) = @_;\n"
|
|
<< tab4 << "my $member_func = \"" << package << "::" << name_set(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
|
|
<< tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
|
|
<< tab8 << "&$member_func($self,tied(%{$newval}));\n"
|
|
<< tab4 << "} else {\n"
|
|
<< tab8 << "&$member_func($self,$newval);\n"
|
|
<< tab4 << "}\n"
|
|
<< "}\n\n";
|
|
|
|
// Output a FIRSTKEY method. This is to allow iteration over a structure's keys.
|
|
|
|
pm << "sub FIRSTKEY {\n"
|
|
<< tab4 << "my $self = shift;\n"
|
|
<< tab4 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
|
|
<< tab4 << "my $first = shift @{$ITERATORS{$self}};\n"
|
|
<< tab4 << "return $first;\n"
|
|
<< "}\n\n";
|
|
|
|
// Output a NEXTKEY method. This is the iterator so that each and keys works
|
|
|
|
pm << "sub NEXTKEY {\n"
|
|
<< tab4 << "my $self = shift;\n"
|
|
<< tab4 << "$nelem = scalar @{$ITERATORS{$self}};\n"
|
|
<< tab4 << "if ($nelem > 0) {\n"
|
|
<< tab8 << "my $member = shift @{$ITERATORS{$self}};\n"
|
|
<< tab8 << "return $member;\n"
|
|
<< tab4 << "} else {\n"
|
|
<< tab8 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
|
|
<< tab8 << "return ();\n"
|
|
<< tab4 << "}\n"
|
|
<< "}\n\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
// --------------------------------------------------------------------------
|
|
// PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l)
|
|
//
|
|
// Handles a C++ member function. This basically does the same thing as
|
|
// the non-C++ version, but we set up a few status variables that affect
|
|
// the function generation function.
|
|
//
|
|
// --------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l) {
|
|
|
|
String func;
|
|
char *realname;
|
|
Parm *p;
|
|
int i;
|
|
String cname = "perl5:";
|
|
int pcount, numopt;
|
|
|
|
// First emit normal member function
|
|
|
|
member_func = 1;
|
|
this->Language::cpp_member_func(name,iname,t,l);
|
|
member_func = 0;
|
|
|
|
if (!blessed) return;
|
|
|
|
// Now emit a Perl wrapper function around our member function, we might need
|
|
// to patch up some arguments along the way
|
|
|
|
if (!iname)
|
|
realname = name;
|
|
else
|
|
realname = iname;
|
|
|
|
cname << class_name << "::" << realname;
|
|
if (add_symbol(cname.get(),0,0)) {
|
|
return; // Forget it, we saw this function already
|
|
}
|
|
|
|
func << "sub " << realname << " {\n"
|
|
<< tab4 << "my @args = @_;\n"
|
|
<< tab4 << "$args[0] = tied(%{$args[0]});\n";
|
|
|
|
// Now we have to go through and patch up the argument list. If any
|
|
// arguments to our function correspond to other Perl objects, we
|
|
// need to extract them from a tied-hash table object.
|
|
|
|
p = l->get_first();
|
|
pcount = l->nparms;
|
|
numopt = l->numopt();
|
|
i = 1;
|
|
while(p) {
|
|
if (!p->ignore) {
|
|
|
|
// Look up the datatype name here
|
|
if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
|
|
// Yep. This smells alot like an object, patch up the arguments
|
|
|
|
if (i >= (pcount - numopt))
|
|
func << tab4 << "if (scalar(@args) >= " << i << ") {\n";
|
|
|
|
func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
|
|
|
|
if (i >= (pcount - numopt))
|
|
func << tab4 << "}\n";
|
|
}
|
|
i++;
|
|
}
|
|
p = l->get_next();
|
|
}
|
|
|
|
// Okay. We've made argument adjustments, now call into the package
|
|
|
|
func << tab4 << "my $result = " << package << "::" << name_member(realname,class_name)
|
|
<< "(@args);\n";
|
|
|
|
// Now check to see what kind of return result was found.
|
|
// If this function is returning a result by 'value', SWIG did an
|
|
// implicit malloc/new. We'll mark the object like it was created
|
|
// in Perl so we can garbage collect it.
|
|
|
|
if ((classes.lookup(t->name)) && (t->is_pointer <=1)) {
|
|
|
|
func << tab4 << "return undef if (!defined($result));\n";
|
|
|
|
// If we're returning an object by value, put it's reference
|
|
// into our local hash table
|
|
|
|
if ((t->is_pointer == 0) || ((t->is_pointer == 1) && NewObject)) {
|
|
func << tab4 << "$" << (char *) classes.lookup(t->name) << "::OWNER{$result} = 1;\n";
|
|
}
|
|
|
|
// We're returning a Perl "object" of some kind. Turn it into
|
|
// a tied hash
|
|
|
|
func << tab4 << "my %resulthash;\n"
|
|
/* << tab4 << "tie %resulthash, \"" << (char *) classes.lookup(t->name) << "\", $result;\n"
|
|
<< tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(t->name) << "\";\n" */
|
|
<< tab4 << "tie %resulthash, ref($result), $result;\n"
|
|
<< tab4 << "return bless \\%resulthash, ref($result);\n"
|
|
|
|
<< "}\n";
|
|
|
|
} else {
|
|
|
|
// Hmmm. This doesn't appear to be anything I know about so just
|
|
// return it unmolested.
|
|
|
|
func << tab4 <<"return $result;\n"
|
|
<< "}\n";
|
|
|
|
}
|
|
|
|
// Append our function to the pcode segment
|
|
|
|
*pcode << func;
|
|
|
|
// Create a new kind of documentation entry for the shadow class
|
|
|
|
if (doc_entry) {
|
|
doc_entry->usage = ""; // Blow away whatever was there before
|
|
doc_entry->usage << usage_func(realname,t,l);
|
|
}
|
|
}
|
|
|
|
// --------------------------------------------------------------------------------
|
|
// PERL5::cpp_variable(char *name, char *iname, DataType *t)
|
|
//
|
|
// Adds an instance member. This is a little hairy because data members are
|
|
// really added with a tied-hash table that is attached to the object.
|
|
//
|
|
// On the low level, we will emit a pair of get/set functions to retrieve
|
|
// values just like before. These will then be encapsulated in a FETCH/STORE
|
|
// method associated with the tied-hash.
|
|
//
|
|
// In the event that a member is an object that we have already wrapped, then
|
|
// we need to retrieve the data a tied-hash as opposed to what SWIG normally
|
|
// returns. To determine this, we build an internal hash called 'BLESSEDMEMBERS'
|
|
// that contains the names and types of tied data members. If a member name
|
|
// is in the list, we tie it, otherwise, we just return the normal SWIG value.
|
|
// --------------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_variable(char *name, char *iname, DataType *t) {
|
|
|
|
char *realname;
|
|
String cname = "perl5:";
|
|
|
|
// Emit a pair of get/set functions for the variable
|
|
|
|
member_func = 1;
|
|
this->Language::cpp_variable(name, iname, t);
|
|
member_func = 0;
|
|
|
|
if (iname) realname = iname;
|
|
else realname = name;
|
|
|
|
if (blessed) {
|
|
cname << class_name << "::" << realname;
|
|
if (add_symbol(cname.get(),0,0)) {
|
|
return; // Forget it, we saw this already
|
|
}
|
|
|
|
// Store name of key for future reference
|
|
|
|
*member_keys << "'" << realname << "', ";
|
|
|
|
// Now we need to generate a little Perl code for this
|
|
|
|
if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
|
|
|
|
// This is a Perl object that we have already seen. Add an
|
|
// entry to the members list
|
|
|
|
*blessedmembers << tab4 << realname << " => '" << (char *) classes.lookup(t->name) << "',\n";
|
|
|
|
}
|
|
|
|
// Patch up the documentation entry
|
|
|
|
if (doc_entry) {
|
|
doc_entry->usage = "";
|
|
doc_entry->usage << "$this->{" << realname << "}";
|
|
}
|
|
}
|
|
have_data_members++;
|
|
}
|
|
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// void PERL5::cpp_constructor(char *name, char *iname, ParmList *l)
|
|
//
|
|
// 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
|
|
// -----------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_constructor(char *name, char *iname, ParmList *l) {
|
|
Parm *p;
|
|
int i;
|
|
char *realname;
|
|
String cname="perl5:constructor:";
|
|
|
|
// Emit an old-style constructor for this class
|
|
|
|
member_func = 1;
|
|
this->Language::cpp_constructor(name, iname, l);
|
|
|
|
if (blessed) {
|
|
|
|
if (iname)
|
|
realname = iname;
|
|
else {
|
|
if (class_renamed) realname = class_name;
|
|
else realname = class_name;
|
|
}
|
|
|
|
cname << class_name << "::" << realname;
|
|
if (add_symbol(cname.get(),0,0)) {
|
|
return; // Forget it, we saw this already
|
|
}
|
|
if ((strcmp(realname,class_name) == 0) || ((!iname) && (ObjCClass)) ){
|
|
|
|
// Emit a blessed constructor
|
|
|
|
*pcode << "sub new {\n";
|
|
|
|
} else {
|
|
|
|
// Constructor doesn't match classname so we'll just use the normal name
|
|
|
|
*pcode << "sub " << name_construct(realname) << " () {\n";
|
|
|
|
}
|
|
|
|
*pcode << tab4 << "my $self = shift;\n"
|
|
<< tab4 << "my @args = @_;\n";
|
|
|
|
// We are going to need to patch up arguments here if necessary
|
|
// Now we have to go through and patch up the argument list. If any
|
|
// arguments to our function correspond to other Perl objects, we
|
|
// need to extract them from a tied-hash table object.
|
|
|
|
p = l->get_first();
|
|
i = 0;
|
|
while(p) {
|
|
|
|
// Look up the datatype name here
|
|
|
|
if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
|
|
|
|
// Yep. This smells alot like an object, patch up the arguments
|
|
*pcode << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
|
|
}
|
|
p = l->get_next();
|
|
i++;
|
|
}
|
|
|
|
*pcode << tab4 << "$self = " << package << "::" << name_construct(realname) << "(@args);\n"
|
|
<< tab4 << "return undef if (!defined($self));\n"
|
|
<< tab4 << "bless $self, \"" << fullclassname << "\";\n"
|
|
<< tab4 << "$OWNER{$self} = 1;\n"
|
|
<< tab4 << "my %retval;\n"
|
|
<< tab4 << "tie %retval, \"" << fullclassname << "\", $self;\n"
|
|
<< tab4 << "return bless \\%retval,\"" << fullclassname << "\";\n"
|
|
<< "}\n\n";
|
|
have_constructor = 1;
|
|
|
|
// Patch up the documentation entry
|
|
|
|
if (doc_entry) {
|
|
doc_entry->usage = "";
|
|
doc_entry->usage << usage_func("new",0,l);
|
|
}
|
|
}
|
|
member_func = 0;
|
|
}
|
|
|
|
|
|
// ------------------------------------------------------------------------------
|
|
// void PERL5::cpp_destructor(char *name, char *newname)
|
|
//
|
|
// Creates a destructor for a blessed object
|
|
// ------------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_destructor(char *name, char *newname) {
|
|
|
|
char *realname;
|
|
member_func = 1;
|
|
this->Language::cpp_destructor(name, newname);
|
|
|
|
if (blessed) {
|
|
if (newname) realname = newname;
|
|
else {
|
|
if (class_renamed) realname = class_name;
|
|
else realname = name;
|
|
}
|
|
|
|
// Emit a destructor for this object
|
|
|
|
*pcode << "sub DESTROY {\n"
|
|
<< tab4 << "my $self = tied(%{$_[0]});\n"
|
|
<< tab4 << "delete $ITERATORS{$self};\n"
|
|
<< tab4 << "if (exists $OWNER{$self}) {\n"
|
|
<< tab8 << package << "::" << name_destroy(realname) << "($self);\n"
|
|
<< tab8 << "delete $OWNER{$self};\n"
|
|
<< tab4 << "}\n}\n\n";
|
|
|
|
have_destructor = 1;
|
|
|
|
if (doc_entry) {
|
|
doc_entry->usage = "DESTROY";
|
|
doc_entry->cinfo = "Destructor";
|
|
}
|
|
}
|
|
member_func = 0;
|
|
}
|
|
// -----------------------------------------------------------------------------
|
|
// void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l)
|
|
//
|
|
// Emits a wrapper for a static class function. Basically, we just call the
|
|
// appropriate method in the module package.
|
|
// ------------------------------------------------------------------------------
|
|
void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l) {
|
|
this->Language::cpp_static_func(name,iname,t,l);
|
|
char *realname;
|
|
if (iname) realname = name;
|
|
else realname = iname;
|
|
|
|
if (blessed) {
|
|
*pcode << "*" << realname << " = *" << realpackage << "::" << name_member(realname,class_name) << ";\n";
|
|
}
|
|
}
|
|
|
|
// ------------------------------------------------------------------------------
|
|
// void PERL5::cpp_inherit(char **baseclass, int mode)
|
|
//
|
|
// This sets the Perl5 baseclass (if possible).
|
|
// ------------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_inherit(char **baseclass, int) {
|
|
|
|
char *bc;
|
|
int i = 0, have_first = 0;
|
|
if (!blessed) {
|
|
this->Language::cpp_inherit(baseclass);
|
|
return;
|
|
}
|
|
|
|
// Inherit variables and constants from base classes, but not
|
|
// functions (since Perl can handle that okay).
|
|
|
|
this->Language::cpp_inherit(baseclass, INHERIT_CONST | INHERIT_VAR);
|
|
|
|
// Now tell the Perl5 module that we're inheriting from base classes
|
|
|
|
base_class = new String;
|
|
while (baseclass[i]) {
|
|
// See if this is a class we know about
|
|
bc = (char *) classes.lookup(baseclass[i]);
|
|
if (bc) {
|
|
if (have_first) *base_class << " ";
|
|
*base_class << bc;
|
|
have_first = 1;
|
|
}
|
|
i++;
|
|
}
|
|
if (!have_first) {
|
|
delete base_class;
|
|
base_class = 0;
|
|
}
|
|
}
|
|
|
|
// --------------------------------------------------------------------------------
|
|
// PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value)
|
|
//
|
|
// Add access to a C++ constant. We can really just do this by hacking
|
|
// the symbol table
|
|
// --------------------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value) {
|
|
char *realname;
|
|
int oldblessed = blessed;
|
|
String cname;
|
|
|
|
// Create a normal constant
|
|
blessed = 0;
|
|
this->Language::cpp_declare_const(name, iname, type, value);
|
|
blessed = oldblessed;
|
|
|
|
if (blessed) {
|
|
if (!iname)
|
|
realname = name;
|
|
else
|
|
realname = iname;
|
|
|
|
cname << class_name << "::" << realname;
|
|
if (add_symbol(cname.get(),0,0)) {
|
|
return; // Forget it, we saw this already
|
|
}
|
|
|
|
// Create a symbol table entry for it
|
|
*pcode << "*" << realname << " = *" << package << "::" << name_member(realname,class_name) << ";\n";
|
|
|
|
// Fix up the documentation entry
|
|
|
|
if (doc_entry) {
|
|
doc_entry->usage = "";
|
|
doc_entry->usage << realname;
|
|
if (value) {
|
|
doc_entry->usage << " = " << value;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
// -----------------------------------------------------------------------
|
|
// PERL5::cpp_class_decl(char *name, char *rename, char *type)
|
|
//
|
|
// Treatment of an empty class definition. Used to handle
|
|
// shadow classes across modules.
|
|
// -----------------------------------------------------------------------
|
|
|
|
void PERL5::cpp_class_decl(char *name, char *rename, char *type) {
|
|
char temp[256];
|
|
if (blessed) {
|
|
classes.add(name,copy_string(rename));
|
|
// Add full name of datatype to the hash table
|
|
if (strlen(type) > 0) {
|
|
sprintf(temp,"%s %s", type, name);
|
|
classes.add(temp,copy_string(rename));
|
|
}
|
|
}
|
|
}
|
|
|
|
// --------------------------------------------------------------------------------
|
|
// PERL5::add_typedef(DataType *t, char *name)
|
|
//
|
|
// This is called whenever a typedef is encountered. When shadow classes are
|
|
// used, this function lets us discovered hidden uses of a class. For example :
|
|
//
|
|
// struct FooBar {
|
|
// ...
|
|
// }
|
|
//
|
|
// typedef FooBar *FooBarPtr;
|
|
//
|
|
// --------------------------------------------------------------------------------
|
|
|
|
void PERL5::add_typedef(DataType *t, char *name) {
|
|
|
|
if (!blessed) return;
|
|
|
|
// First check to see if there aren't too many pointers
|
|
|
|
if (t->is_pointer > 1) return;
|
|
|
|
if (classes.lookup(name)) return; // Already added
|
|
|
|
// Now look up the datatype in our shadow class hash table
|
|
|
|
if (classes.lookup(t->name)) {
|
|
|
|
// Yep. This datatype is in the hash
|
|
|
|
// Put this types 'new' name into the hash
|
|
|
|
classes.add(name,copy_string((char *) classes.lookup(t->name)));
|
|
}
|
|
}
|
|
|
|
|
|
// --------------------------------------------------------------------------------
|
|
// PERL5::pragma(char *, char *, char *)
|
|
//
|
|
// 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
|
|
//
|
|
// --------------------------------------------------------------------------------
|
|
|
|
void PERL5::pragma(char *lang, char *code, char *value) {
|
|
if (strcmp(lang,"perl5") == 0) {
|
|
if (strcmp(code,"code") == 0) {
|
|
// Dump the value string into the .pm file
|
|
if (value) {
|
|
pragma_include << value << "\n";
|
|
}
|
|
} else if (strcmp(code,"include") == 0) {
|
|
// Include a file into the .pm file
|
|
if (value) {
|
|
if (get_file(value,pragma_include) == -1) {
|
|
fprintf(stderr,"%s : Line %d. Unable to locate file %s\n", input_file, line_number,value);
|
|
}
|
|
}
|
|
} else {
|
|
fprintf(stderr,"%s : Line %d. Unrecognized pragma.\n", input_file,line_number);
|
|
}
|
|
}
|
|
}
|