[wxWidgets.git] / wxPython / wxSWIG / Modules / perl5.cxx

/*******************************************************************************
 * 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);
    }
  }
}