+++ /dev/null
-/*******************************************************************************
- * 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);
- }
- }
-}
projects / wxWidgets.git / blobdiff