wxPython/wxSWIG/Modules/perl5.cxx

   1 /*******************************************************************************
   2  * Simplified Wrapper and Interface Generator  (SWIG)
   3  *
   4  * Author : David Beazley
   5  *
   6  * Department of Computer Science
   7  * University of Chicago
   8  * 1100 E 58th Street
   9  * Chicago, IL  60637
  10  * beazley@cs.uchicago.edu
  11  *
  12  * Please read the file LICENSE for the copyright and terms by which SWIG
  13  * can be used and distributed.
  14  *******************************************************************************/
  15
  16 /***********************************************************************
  17  * $Header$
  18  *
  19  * perl5.c
  20  *
  21  * Definitions for adding functions to Perl 5
  22  *
  23  * How to extend perl5 (note : this is totally different in Perl 4) :
  24  *
  25  * 1.   Variable linkage
  26  *
  27  *      Must declare two functions :
  28  *
  29  *          _var_set(SV *sv, MAGIC *mg);
  30  *          _var_get(SV *sv, MAGIC *mg);
  31  *
  32  *      These functions must set/get the values of a variable using
  33  *      Perl5 internals.
  34  *
  35  *      To add these to Perl5 (which isn't entirely clear), need to
  36  *      do the following :
  37  *
  38  *            SV  *sv;
  39  *            MAGIC  *m;
  40  *            sv = perl_get_sv("varname",TRUE);
  41  *            sv_magic(sv,sv, 'U', "varname", strlen("varname));
  42  *            m = mg_find(sv, 'U');
  43  *            m->mg_virtual = (MGVTBL *) malloc(sizeof(MGVTBL));
  44  *            m->mg_virtual.svt_get = _var_set;
  45  *            m->mg_virtual.svt_set = _var_get;
  46  *            m->mg_virtual.svt_len = 0;
  47  *            m->mg_virtual.svt_free = 0;
  48  *            m->mg_virtual.svt_clear = 0;
  49  *
  50  *
  51  * 2.   Function extension
  52  *
  53  *      Functions are declared as :
  54  *             XS(_wrap_func) {
  55  *                 dXSARGS;
  56  *                 if (items != parmcount) {
  57  *                     croak("Usage :");
  58  *                 }
  59  *              ... get arguments ...
  60  *
  61  *              ... call function ...
  62  *              ... set return value in ST(0)
  63  *                 XSRETURN(1);
  64  *              }
  65  *      To extract function arguments, use the following :
  66  *              _arg = (int) SvIV(ST(0))
  67  *              _arg = (double) SvNV(ST(0))
  68  *              _arg = (char *) SvPV(ST(0),na);
  69  *
  70  *      For return values, use :
  71  *              ST(0) = sv_newmortal();
  72  *              sv_setiv(ST(0), (IV) RETVAL);     // Integers
  73  *              sv_setnv(ST(0), (double) RETVAL); // Doubles
  74  *              sv_setpv((SV*) ST(0), RETVAL);    // Strings
  75  *
  76  *      New functions are added using
  77  *              newXS("name", _wrap_func, file)
  78  *
  79  *
  80  * 3.   Compilation.
  81  *
  82  *      Code should be compiled into an object file for dynamic
  83  *      loading into Perl.
  84  ***********************************************************************/
  85
  86 #include "swig.h"
  87 #include "perl5.h"
  88
  89 static String pragma_include;
  90
  91 static char *usage = "\
  92 Perl5 Options (available with -perl5)\n\
  93      -module name    - Set module name\n\
  94      -package name   - Set package prefix\n\
  95      -static         - Omit code related to dynamic loading.\n\
  96      -shadow         - Create shadow classes.\n\
  97      -compat         - Compatibility mode.\n\
  98      -alt-header file- Use an alternate header.\n\n";
  99
 100 static char *import_file = 0;
 101 static char *smodule = 0;
 102 static int   compat = 0;
 103
 104 // ---------------------------------------------------------------------
 105 // PERL5::parse_args(int argc, char *argv[])
 106 //
 107 // Parse command line options.
 108 // ---------------------------------------------------------------------
 109
 110 void
 111 PERL5::parse_args(int argc, char *argv[]) {
 112
 113   int i = 1;
 114
 115   export_all = 0;
 116   sprintf(LibDir,"%s", perl_path);
 117
 118   // Look for certain command line options
 119
 120   // Get options
 121   for (i = 1; i < argc; i++) {
 122       if (argv[i]) {
 123           if(strcmp(argv[i],"-package") == 0) {
 124             if (argv[i+1]) {
 125               package = new char[strlen(argv[i+1])+1];
 126               strcpy(package, argv[i+1]);
 127               mark_arg(i);
 128               mark_arg(i+1);
 129               i++;
 130             } else {
 131               arg_error();
 132             }
 133           } else if (strcmp(argv[i],"-module") == 0) {
 134             if (argv[i+1]) {
 135               module = new char[strlen(argv[i+1])+1];
 136               strcpy(module, argv[i+1]);
 137               cmodule = module;
 138               cmodule.replace(":","_");
 139               mark_arg(i);
 140               mark_arg(i+1);
 141               i++;
 142             } else {
 143               arg_error();
 144             }
 145           } else if (strcmp(argv[i],"-exportall") == 0) {
 146               export_all = 1;
 147               mark_arg(i);
 148           } else if (strcmp(argv[i],"-static") == 0) {
 149               is_static = 1;
 150               mark_arg(i);
 151           } else if (strcmp(argv[i],"-shadow") == 0) {
 152             blessed = 1;
 153             mark_arg(i);
 154           } else if (strcmp(argv[i],"-alt-header") == 0) {
 155             if (argv[i+1]) {
 156               alt_header = copy_string(argv[i+1]);
 157               mark_arg(i);
 158               mark_arg(i+1);
 159               i++;
 160             } else {
 161               arg_error();
 162             }
 163           } else if (strcmp(argv[i],"-compat") == 0) {
 164             compat = 1;
 165             mark_arg(i);
 166           } else if (strcmp(argv[i],"-help") == 0) {
 167             fputs(usage,stderr);
 168           }
 169       }
 170   }
 171   // Add a symbol for this module
 172
 173   add_symbol("SWIGPERL",0,0);
 174   add_symbol("SWIGPERL5",0,0);
 175
 176   // Set name of typemaps
 177
 178   typemap_lang = "perl5";
 179
 180 }
 181
 182 // ------------------------------------------------------------------
 183 // PERL5::parse()
 184 //
 185 // Parse an interface file
 186 // ------------------------------------------------------------------
 187
 188 void
 189 PERL5::parse() {
 190
 191
 192   printf("Generating wrappers for Perl 5\n");
 193
 194   // Print out PERL5 specific headers
 195
 196   headers();
 197
 198   // Run the parser
 199
 200   yyparse();
 201   fputs(vinit.get(),f_wrappers);
 202 }
 203
 204
 205 // ---------------------------------------------------------------------
 206 // PERL5::set_module(char *mod_name, char **mod_list)
 207 //
 208 // Sets the module name.
 209 // Does nothing if it's already set (so it can be overridden as a command
 210 // line option).
 211 //
 212 //----------------------------------------------------------------------
 213 static String modinit, modextern;
 214
 215 void PERL5::set_module(char *mod_name, char **mod_list) {
 216   int i;
 217   if (import_file) {
 218     if (!(strcmp(import_file,input_file+strlen(input_file)-strlen(import_file)))) {
 219       if (blessed) {
 220         fprintf(f_pm,"require %s;\n", mod_name);
 221       }
 222       delete [] import_file;
 223       import_file = 0;
 224     }
 225   }
 226
 227   if (module) return;
 228
 229   module = new char[strlen(mod_name)+1];
 230   strcpy(module,mod_name);
 231
 232   // if there was a mod_list specified, make this big hack
 233   if (mod_list) {
 234     modinit << "#define SWIGMODINIT ";
 235     modextern << "#ifdef __cplusplus\n"
 236               << "extern \"C\" {\n"
 237               << "#endif\n";
 238     i = 0;
 239     while(mod_list[i]) {
 240       modinit << "newXS(\"" << mod_list[i] << "::boot_" << mod_list[i] << "\", boot_" << mod_list[i] << ", file);\\\n";
 241       modextern << "extern void boot_" << mod_list[i] << "(CV *);\n";
 242       i++;
 243     }
 244     modextern << "#ifdef __cplusplus\n"
 245               << "}\n"
 246               << "#endif\n";
 247     modinit << "/* End of extern module initialization */\n";
 248   }
 249
 250   // Create a C module name and put it in 'cmodule'
 251
 252   cmodule = module;
 253   cmodule.replace(":","_");
 254 }
 255
 256 // ---------------------------------------------------------------------
 257 // PERL5::set_init(char *iname)
 258 //
 259 // Sets the initialization function name.
 260 // Does nothing if it's already set
 261 //
 262 //----------------------------------------------------------------------
 263
 264 void PERL5::set_init(char *iname) {
 265   set_module(iname,0);
 266 }
 267
 268 // ---------------------------------------------------------------------
 269 // PERL5::headers(void)
 270 //
 271 // Generate the appropriate header files for PERL5 interface.
 272 // ----------------------------------------------------------------------
 273
 274 void PERL5::headers(void)
 275 {
 276
 277   emit_banner(f_header);
 278
 279   if (!alt_header) {
 280     if (insert_file("headers.swg", f_header) == -1) {
 281       fprintf(stderr,"Perl5 : Fatal error. Unable to locate headers.swg. Possible installation problem.\n");
 282       SWIG_exit(1);
 283     }
 284   } else {
 285     if (insert_file(alt_header, f_header) == -1) {
 286       fprintf(stderr,"SWIG : Fatal error.  Unable to locate %s.\n",alt_header);
 287       SWIG_exit(1);
 288     }
 289   }
 290
 291   if (NoInclude) {
 292     fprintf(f_header,"#define SWIG_NOINCLUDE\n");
 293   }
 294
 295   // Get special SWIG related declarations
 296   if (insert_file("perl5.swg", f_header) == -1) {
 297     fprintf(stderr,"SWIG : Fatal error.  Unable to locate 'perl5.swg' in SWIG library.\n");
 298     SWIG_exit(1);
 299   }
 300
 301   // Get special SWIG related declarations
 302   if (insert_file("perl5mg.swg", f_header) == -1) {
 303     fprintf(stderr,"SWIG : Fatal error.  Unable to locate 'perl5mg.swg' in SWIG library.\n");
 304     SWIG_exit(1);
 305   }
 306
 307 }
 308
 309 // --------------------------------------------------------------------
 310 // PERL5::initialize()
 311 //
 312 // Output initialization code that registers functions with the
 313 // interface.
 314 // ---------------------------------------------------------------------
 315
 316 void PERL5::initialize()
 317 {
 318
 319   char filen[256];
 320
 321   if (!module){
 322     module = "swig";
 323     fprintf(stderr,"SWIG : *** Warning. No module name specified.\n");
 324   }
 325
 326   if (!package) {
 327     package = new char[strlen(module)+1];
 328     strcpy(package,module);
 329   }
 330
 331   // If we're in blessed mode, change the package name to "packagec"
 332
 333   if (blessed) {
 334     char *newpackage = new char[strlen(package)+2];
 335     sprintf(newpackage,"%sc",package);
 336     realpackage = package;
 337     package = newpackage;
 338   } else {
 339     realpackage = package;
 340   }
 341
 342   // Create a .pm file
 343   // Need to strip off any prefixes that might be found in
 344   // the module name
 345
 346   {
 347     char *m = module + strlen(module);
 348     while (m != module) {
 349       if (*m == ':') {
 350         m++;
 351         break;
 352       }
 353       m--;
 354     }
 355     sprintf(filen,"%s%s.pm", output_dir,m);
 356     if ((f_pm = fopen(filen,"w")) == 0) {
 357       fprintf(stderr,"Unable to open %s\n", filen);
 358       SWIG_exit(0);
 359     }
 360   }
 361   if (!blessed) {
 362     smodule = module;
 363   } else if (is_static) {
 364     smodule = new char[strlen(module)+2];
 365     strcpy(smodule,module);
 366     strcat(smodule,"c");
 367     cmodule << "c";
 368   } else {
 369     smodule = module;
 370   }
 371
 372   fprintf(f_header,"#define SWIG_init    boot_%s\n\n", cmodule.get());
 373   fprintf(f_header,"#define SWIG_name   \"%s::boot_%s\"\n", package, cmodule.get());
 374   fprintf(f_header,"#define SWIG_varinit \"%s::var_%s_init();\"\n", package, cmodule.get());
 375   fprintf(f_header,"#ifdef __cplusplus\n");
 376   fprintf(f_header,"extern \"C\"\n");
 377   fprintf(f_header,"#endif\n");
 378   fprintf(f_header,"#ifndef PERL_OBJECT\n");
 379   fprintf(f_header,"SWIGEXPORT(void) boot_%s(CV* cv);\n", cmodule.get());
 380   fprintf(f_header,"#else\n");
 381   fprintf(f_header,"SWIGEXPORT(void) boot_%s(CV *cv, CPerlObj *);\n",cmodule.get());
 382   fprintf(f_header,"#endif\n");
 383   fprintf(f_init,"#ifdef __cplusplus\n");
 384   fprintf(f_init,"extern \"C\"\n");
 385   fprintf(f_init,"#endif\n");
 386   fprintf(f_init,"XS(boot_%s) {\n", cmodule.get());
 387   fprintf(f_init,"\t dXSARGS;\n");
 388   fprintf(f_init,"\t char *file = __FILE__;\n");
 389   fprintf(f_init,"\t cv = cv; items = items;\n");
 390   fprintf(f_init,"\t newXS(\"%s::var_%s_init\", _wrap_perl5_%s_var_init, file);\n",package,cmodule.get(), cmodule.get());
 391   vinit << "XS(_wrap_perl5_" << cmodule << "_var_init) {\n"
 392         << tab4 << "dXSARGS;\n"
 393         << tab4 << "SV *sv;\n"
 394         << tab4 << "cv = cv; items = items;\n";
 395
 396   fprintf(f_pm,"# This file was automatically generated by SWIG\n");
 397   fprintf(f_pm,"package %s;\n",module);
 398   fprintf(f_pm,"require Exporter;\n");
 399   if (!is_static) {
 400     fprintf(f_pm,"require DynaLoader;\n");
 401     fprintf(f_pm,"@ISA = qw(Exporter DynaLoader);\n");
 402   } else {
 403     fprintf(f_pm,"@ISA = qw(Exporter);\n");
 404   }
 405
 406   // Start creating magic code
 407
 408
 409   magic << "#ifdef PERL_OBJECT\n"
 410         << "#define MAGIC_CLASS _wrap_" << module << "_var::\n"
 411         << "class _wrap_" << module << "_var : public CPerlObj {\n"
 412         << "public:\n"
 413         << "#else\n"
 414         << "#define MAGIC_CLASS\n"
 415         << "#endif\n"
 416         << "SWIGCLASS_STATIC int swig_magic_readonly(SV *sv, MAGIC *mg) {\n"
 417         << tab4 << "MAGIC_PPERL\n"
 418         << tab4 << "sv = sv; mg = mg;\n"
 419         << tab4 << "croak(\"Value is read-only.\");\n"
 420         << tab4 << "return 0;\n"
 421         << "}\n";  // Dump out external module declarations
 422
 423   /* Process additional initialization files here */
 424
 425   if (strlen(modinit.get()) > 0) {
 426     fprintf(f_header,"%s\n",modinit.get());
 427   }
 428   if (strlen(modextern.get()) > 0) {
 429     fprintf(f_header,"%s\n",modextern.get());
 430   }
 431 }
 432
 433 // ---------------------------------------------------------------------
 434 // PERL5::import(char *filename)
 435 //
 436 // Import directive
 437 // ---------------------------------------------------------------------
 438
 439 void PERL5::import(char *filename) {
 440   if (import_file) delete [] import_file;
 441   import_file = copy_string(filename);
 442 }
 443
 444
 445 // ---------------------------------------------------------------------
 446 // PERL5::close(void)
 447 //
 448 // Wrap things up.  Close initialization function.
 449 // ---------------------------------------------------------------------
 450
 451 void PERL5::close(void)
 452 {
 453   String base;
 454
 455   // Dump out variable wrappers
 456
 457   magic << "\n\n#ifdef PERL_OBJECT\n"
 458         << "};\n"
 459         << "#endif\n";
 460
 461   fprintf(f_header,"%s\n", magic.get());
 462
 463   emit_ptr_equivalence(f_init);
 464
 465   fprintf(f_init,"\t ST(0) = &PL_sv_yes;\n");
 466   fprintf(f_init,"\t XSRETURN(1);\n");
 467   fprintf(f_init,"}\n");
 468
 469   vinit << tab4 << "XSRETURN(1);\n"
 470         << "}\n";
 471
 472   fprintf(f_pm,"package %s;\n", package);
 473
 474   if (!is_static) {
 475     fprintf(f_pm,"bootstrap %s;\n", smodule);
 476   } else {
 477     fprintf(f_pm,"boot_%s();\n", smodule);
 478   }
 479   fprintf(f_pm,"var_%s_init();\n", cmodule.get());
 480   fprintf(f_pm,"%s",pragma_include.get());
 481   fprintf(f_pm,"package %s;\n", realpackage);
 482   fprintf(f_pm,"@EXPORT = qw(%s );\n",exported.get());
 483
 484   if (blessed) {
 485
 486     base << "\n# ---------- BASE METHODS -------------\n\n"
 487          << "package " << realpackage << ";\n\n";
 488
 489     // Write out the TIE method
 490
 491     base << "sub TIEHASH {\n"
 492          << tab4 << "my ($classname,$obj) = @_;\n"
 493          << tab4 << "return bless $obj, $classname;\n"
 494          << "}\n\n";
 495
 496     // Output a CLEAR method.   This is just a place-holder, but by providing it we
 497     // can make declarations such as
 498     //     %$u = ( x => 2, y=>3, z =>4 );
 499     //
 500     // Where x,y,z are the members of some C/C++ object.
 501
 502     base << "sub CLEAR { }\n\n";
 503
 504     // Output default firstkey/nextkey methods
 505
 506     base << "sub FIRSTKEY { }\n\n";
 507     base << "sub NEXTKEY { }\n\n";
 508
 509     // Output a 'this' method
 510
 511     base << "sub this {\n"
 512          << tab4 << "my $ptr = shift;\n"
 513          << tab4 << "return tied(%$ptr);\n"
 514          << "}\n\n";
 515
 516     fprintf(f_pm,"%s",base.get());
 517
 518     // Emit function stubs for stand-alone functions
 519
 520     fprintf(f_pm,"\n# ------- FUNCTION WRAPPERS --------\n\n");
 521     fprintf(f_pm,"package %s;\n\n",realpackage);
 522     fprintf(f_pm,"%s",func_stubs.get());
 523
 524
 525     // Emit package code for different classes
 526
 527     fprintf(f_pm,"%s",pm.get());
 528
 529     // Emit variable stubs
 530
 531     fprintf(f_pm,"\n# ------- VARIABLE STUBS --------\n\n");
 532     fprintf(f_pm,"package %s;\n\n",realpackage);
 533     fprintf(f_pm,"%s",var_stubs.get());
 534
 535   }
 536
 537   fprintf(f_pm,"1;\n");
 538   fclose(f_pm);
 539
 540   // Patch up documentation title
 541
 542   if ((doc_entry) && (module)) {
 543     doc_entry->cinfo << "Module  : " << module << ", "
 544          << "Package : " << realpackage;
 545   }
 546
 547 }
 548
 549 // ----------------------------------------------------------------------
 550 // char *PERL5::type_mangle(DataType *t)
 551 //
 552 // Mangles a datatype into a Perl5 name compatible with xsubpp type
 553 // T_PTROBJ.
 554 // ----------------------------------------------------------------------
 555
 556 char *
 557 PERL5::type_mangle(DataType *t) {
 558   static char result[128];
 559   int   i;
 560   char *r, *c;
 561
 562   if (blessed) {
 563
 564     // Check to see if we've blessed this datatype
 565
 566     if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
 567
 568       // This is a blessed class.  Return just the type-name
 569       strcpy(result,(char *) classes.lookup(t->name));
 570       return result;
 571     }
 572   }
 573
 574   r = result;
 575   c = t->name;
 576
 577   for ( c = t->name; *c; c++,r++) {
 578       *r = *c;
 579   }
 580   for (i = 0; i < (t->is_pointer-t->implicit_ptr); i++, r++) {
 581     strcpy(r,"Ptr");
 582     r+=2;
 583   }
 584   *r = 0;
 585   return result;
 586 }
 587
 588 // ----------------------------------------------------------------------
 589 // PERL5::get_pointer(char *iname, char *srcname, char *src, char *target,
 590 //                     DataType *t, String &f, char *ret)
 591 //
 592 // Emits code to get a pointer from a parameter and do type checking.
 593 // ----------------------------------------------------------------------
 594
 595 void PERL5::get_pointer(char *iname, char *srcname, char *src, char *dest,
 596                         DataType *t, String &f, char *ret) {
 597
 598   // Now get the pointer value from the string and save in dest
 599
 600   f << tab4 << "if (SWIG_GetPtr(" << src << ",(void **) &" << dest << ",";
 601
 602   // If we're passing a void pointer, we give the pointer conversion a NULL
 603   // pointer, otherwise pass in the expected type.
 604
 605   if (t->type == T_VOID) f << "(char *) 0 )) {\n";
 606   else
 607     f << "\"" << t->print_mangle() << "\")) {\n";
 608
 609   // This part handles the type checking according to three different
 610   // levels.   0 = no checking, 1 = warning message, 2 = strict.
 611
 612   switch(TypeStrict) {
 613   case 0: // No type checking
 614     f << tab4 << "}\n";
 615     break;
 616
 617   case 1: // Warning message only
 618
 619     // Change this part to how you want to handle a type-mismatch warning.
 620     // By default, it will just print to stderr.
 621
 622     f << tab8 << "fprintf(stderr,\"Warning : type mismatch in " << srcname
 623       << " of " << iname << ". Expected " << t->print_mangle()
 624       << ", received %s\\n\"," << src << ");\n"
 625       << tab4 << "}\n";
 626
 627     break;
 628   case 2: // Super strict mode.
 629
 630     // Change this part to return an error.
 631
 632     f << tab8 << "croak(\"Type error in " << srcname
 633            << " of " << iname << ". Expected " << t->print_mangle() << ".\");\n"
 634            << tab8 << ret << ";\n"
 635            << tab4 << "}\n";
 636
 637     break;
 638
 639   default :
 640     fprintf(stderr,"SWIG Error. Unknown strictness level\n");
 641     break;
 642   }
 643 }
 644
 645 // ----------------------------------------------------------------------
 646 // PERL5::create_command(char *cname, char *iname)
 647 //
 648 // Create a command and register it with the interpreter
 649 // ----------------------------------------------------------------------
 650
 651 void PERL5::create_command(char *cname, char *iname) {
 652   fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, name_wrapper(cname,""));
 653   if (export_all) {
 654     exported << iname << " ";
 655   }
 656 }
 657
 658 // ----------------------------------------------------------------------
 659 // PERL5::create_function(char *name, char *iname, DataType *d,
 660 //                             ParmList *l)
 661 //
 662 // Create a function declaration and register it with the interpreter.
 663 // ----------------------------------------------------------------------
 664
 665 void PERL5::create_function(char *name, char *iname, DataType *d, ParmList *l)
 666 {
 667   Parm *p;
 668   int   pcount,i,j;
 669   char  *wname;
 670   char *usage = 0;
 671   WrapperFunction f;
 672   char  source[256],target[256],temp[256], argnum[32];
 673   char  *tm;
 674   String cleanup,outarg,build;
 675   int    numopt = 0;
 676   int    need_save, num_saved = 0;             // Number of saved arguments.
 677   int    have_build = 0;
 678
 679   // Make a wrapper name for this
 680
 681   wname = name_wrapper(iname,"");
 682
 683   // Now write the wrapper function itself....this is pretty ugly
 684
 685   f.def << "XS(" << wname << ") {\n";
 686   f.code << tab4 << "cv = cv;\n";
 687
 688   pcount = emit_args(d, l, f);
 689   numopt = l->numopt();
 690
 691   f.add_local("int","argvi = 0");
 692
 693   // Check the number of arguments
 694
 695   usage = usage_func(iname,d,l);
 696   f.code << tab4 << "if ((items < " << (pcount-numopt) << ") || (items > " << l->numarg() << ")) \n"
 697          << tab8 << "croak(\"Usage: " << usage << "\");\n";
 698
 699   // Write code to extract parameters.
 700   // This section should be able to extract virtually any kind
 701   // parameter, represented as a string
 702
 703   i = 0;
 704   j = 0;
 705   p = l->get_first();
 706   while (p != 0) {
 707     // Produce string representation of source and target arguments
 708     sprintf(source,"ST(%d)",j);
 709     sprintf(target,"_arg%d",i);
 710     sprintf(argnum,"%d",j+1);
 711
 712     // Check to see if this argument is being ignored
 713
 714     if (!p->ignore) {
 715
 716       // If there are optional arguments, check for this
 717
 718       if (j>= (pcount-numopt))
 719         f.code << tab4 << "if (items > " << j << ") {\n";
 720
 721       // See if there is a type-map
 722       if ((tm = typemap_lookup("in","perl5",p->t,p->name,source,target,&f))) {
 723         f.code << tm << "\n";
 724         f.code.replace("$argnum",argnum);
 725         f.code.replace("$arg",source);
 726       } else {
 727
 728         if (!p->t->is_pointer) {
 729
 730           // Extract a parameter by "value"
 731
 732           switch(p->t->type) {
 733
 734             // Integers
 735
 736           case T_BOOL:
 737           case T_INT :
 738           case T_SHORT :
 739           case T_LONG :
 740           case T_SINT :
 741           case T_SSHORT:
 742           case T_SLONG:
 743           case T_SCHAR:
 744           case T_UINT:
 745           case T_USHORT:
 746           case T_ULONG:
 747           case T_UCHAR:
 748             f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
 749               << "SvIV(ST(" << j << "));\n";
 750             break;
 751           case T_CHAR :
 752
 753
 754
 755             f.code << tab4 << "_arg" << i << " = (char) *SvPV(ST(" << j << "),PL_na);\n";
 756             break;
 757
 758           // Doubles
 759
 760           case T_DOUBLE :
 761           case T_FLOAT :
 762             f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
 763               << " SvNV(ST(" << j << "));\n";
 764             break;
 765
 766           // Void.. Do nothing.
 767
 768           case T_VOID :
 769             break;
 770
 771             // User defined.   This is invalid here.   Note, user-defined types by
 772             // value are handled in the parser.
 773
 774           case T_USER:
 775
 776             // Unsupported data type
 777
 778           default :
 779             fprintf(stderr,"%s : Line %d. Unable to use type %s as a function argument.\n",input_file, line_number, p->t->print_type());
 780             break;
 781           }
 782         } else {
 783
 784           // Argument is a pointer type.   Special case is for char *
 785           // since that is usually a string.
 786
 787           if ((p->t->type == T_CHAR) && (p->t->is_pointer == 1)) {
 788             f.code << tab4 << "if (! SvOK((SV*) ST(" << j << "))) { "
 789                    << "_arg" << i << " = 0; }\n";
 790             f.code << tab4 << "else { _arg"
 791                    << i << " = (char *) SvPV(ST(" << j << "),PL_na); }\n";
 792           } else {
 793
 794             // Have a generic pointer type here.    Read it in as a swig
 795             // typed pointer.
 796
 797             sprintf(temp,"argument %d", i+1);
 798             get_pointer(iname,temp,source,target, p->t, f.code, "XSRETURN(1)");
 799           }
 800         }
 801       }
 802       // The source is going to be an array of saved values.
 803
 804       sprintf(temp,"_saved[%d]",num_saved);
 805       if (j>= (pcount-numopt))
 806         f.code << tab4 << "} \n";
 807       j++;
 808     } else {
 809       temp[0] = 0;
 810     }
 811     // Check to see if there is any sort of "build" typemap (highly complicated)
 812
 813     if ((tm = typemap_lookup("build","perl5",p->t,p->name,source,target))) {
 814       build << tm << "\n";
 815       have_build = 1;
 816     }
 817
 818     // Check if there is any constraint code
 819     if ((tm = typemap_lookup("check","perl5",p->t,p->name,source,target))) {
 820       f.code << tm << "\n";
 821       f.code.replace("$argnum",argnum);
 822     }
 823     need_save = 0;
 824
 825     if ((tm = typemap_lookup("freearg","perl5",p->t,p->name,target,temp))) {
 826       cleanup << tm << "\n";
 827       cleanup.replace("$argnum",argnum);
 828       cleanup.replace("$arg",temp);
 829       need_save = 1;
 830     }
 831     if ((tm = typemap_lookup("argout","perl5",p->t,p->name,target,"ST(argvi)"))) {
 832       String tempstr;
 833       tempstr = tm;
 834       tempstr.replace("$argnum",argnum);
 835       tempstr.replace("$arg",temp);
 836       outarg << tempstr << "\n";
 837       need_save = 1;
 838     }
 839     // If we needed a saved variable, we need to emit to emit some code for that
 840     // This only applies if the argument actually existed (not ignore)
 841     if ((need_save) && (!p->ignore)) {
 842       f.code << tab4 << temp << " = " << source << ";\n";
 843       num_saved++;
 844     }
 845     p = l->get_next();
 846     i++;
 847   }
 848
 849   // If there were any saved arguments, emit a local variable for them
 850
 851   if (num_saved) {
 852     sprintf(temp,"_saved[%d]",num_saved);
 853     f.add_local("SV *",temp);
 854   }
 855
 856   // If there was a "build" typemap, we need to go in and perform a serious hack
 857
 858   if (have_build) {
 859     char temp1[32];
 860     char temp2[256];
 861     l->sub_parmnames(build);            // Replace all parameter names
 862     j = 1;
 863     for (i = 0; i < l->nparms; i++) {
 864       p = l->get(i);
 865       if (strlen(p->name) > 0) {
 866         sprintf(temp1,"_in_%s", p->name);
 867       } else {
 868         sprintf(temp1,"_in_arg%d", i);
 869       }
 870       sprintf(temp2,"argv[%d]",j);
 871       build.replaceid(temp1,temp2);
 872       if (!p->ignore)
 873         j++;
 874     }
 875     f.code << build;
 876   }
 877
 878   // Now write code to make the function call
 879
 880   emit_func_call(name,d,l,f);
 881
 882   // See if there was a typemap
 883
 884   if ((tm = typemap_lookup("out","perl5",d,iname,"_result","ST(argvi)"))) {
 885     // Yep.  Use it instead of the default
 886     f.code << tm << "\n";
 887   } else if ((d->type != T_VOID) || (d->is_pointer)) {
 888     if (!d->is_pointer) {
 889
 890       // Function returns a "value"
 891       f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
 892       switch(d->type) {
 893       case T_INT: case T_BOOL: case T_SINT: case T_UINT:
 894       case T_SHORT: case T_SSHORT: case T_USHORT:
 895       case T_LONG : case T_SLONG : case T_ULONG:
 896       case T_SCHAR: case T_UCHAR :
 897         f.code << tab4 << "sv_setiv(ST(argvi++),(IV) _result);\n";
 898         break;
 899       case T_DOUBLE :
 900       case T_FLOAT :
 901         f.code << tab4 << "sv_setnv(ST(argvi++), (double) _result);\n";
 902         break;
 903       case T_CHAR :
 904         f.add_local("char", "_ctemp[2]");
 905         f.code << tab4 << "_ctemp[0] = _result;\n"
 906                << tab4 << "_ctemp[1] = 0;\n"
 907                << tab4 << "sv_setpv((SV*)ST(argvi++),_ctemp);\n";
 908         break;
 909
 910         // Return a complex type by value
 911
 912       case T_USER:
 913         d->is_pointer++;
 914         f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
 915                << "\", (void *) _result);\n";
 916         d->is_pointer--;
 917         break;
 918
 919       default :
 920         fprintf(stderr,"%s: Line %d. Unable to use return type %s in function %s.\n", input_file, line_number, d->print_type(), name);
 921         break;
 922       }
 923     } else {
 924
 925       // Is a pointer return type
 926       f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
 927       if ((d->type == T_CHAR) && (d->is_pointer == 1)) {
 928
 929         // Return a character string
 930         f.code << tab4 << "sv_setpv((SV*)ST(argvi++),(char *) _result);\n";
 931
 932       } else {
 933         // Is an ordinary pointer type.
 934         f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
 935                << "\", (void *) _result);\n";
 936       }
 937     }
 938   }
 939
 940   // If there were any output args, take care of them.
 941
 942   f.code << outarg;
 943
 944   // If there was any cleanup, do that.
 945
 946   f.code << cleanup;
 947
 948   if (NewObject) {
 949     if ((tm = typemap_lookup("newfree","perl5",d,iname,"_result",""))) {
 950       f.code << tm << "\n";
 951     }
 952   }
 953
 954   if ((tm = typemap_lookup("ret","perl5",d,iname,"_result",""))) {
 955       // Yep.  Use it instead of the default
 956       f.code << tm << "\n";
 957   }
 958
 959   // Wrap things up (in a manner of speaking)
 960
 961   f.code << tab4 << "XSRETURN(argvi);\n}\n";
 962
 963   // Add the dXSARGS last
 964
 965   f.add_local("dXSARGS","");
 966
 967   // Substitute the cleanup code
 968   f.code.replace("$cleanup",cleanup);
 969   f.code.replace("$name",iname);
 970
 971   // Dump this function out
 972
 973   f.print(f_wrappers);
 974
 975   // Create a first crack at a documentation entry
 976
 977   if (doc_entry) {
 978     static DocEntry *last_doc_entry = 0;
 979     doc_entry->usage << usage;
 980     if (last_doc_entry != doc_entry) {
 981       doc_entry->cinfo << "returns " << d->print_type();
 982       last_doc_entry = doc_entry;
 983     }
 984   }
 985
 986   // Now register the function
 987
 988   fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, wname);
 989
 990   if (export_all) {
 991     exported << iname << " ";
 992   }
 993
 994
 995   // --------------------------------------------------------------------
 996   // Create a stub for this function, provided it's not a member function
 997   //
 998   // Really we only need to create a stub if this function involves
 999   // complex datatypes.   If it does, we'll make a small wrapper to
1000   // process the arguments.   If it doesn't, we'll just make a symbol
1001   // table entry.
1002   // --------------------------------------------------------------------
1003
1004   if ((blessed) && (!member_func)) {
1005     int    need_stub = 0;
1006     String func;
1007
1008     // We'll make a stub since we may need it anyways
1009
1010     func << "sub " << iname << " {\n"
1011          << tab4 << "my @args = @_;\n";
1012
1013
1014     // Now we have to go through and patch up the argument list.  If any
1015     // arguments to our function correspond to other Perl objects, we
1016     // need to extract them from a tied-hash table object.
1017
1018     Parm *p = l->get_first();
1019     int i = 0;
1020     while(p) {
1021
1022       if (!p->ignore) {
1023         // Look up the datatype name here
1024
1025         if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
1026           if (i >= (pcount - numopt))
1027             func << tab4 << "if (scalar(@args) >= " << i << ") {\n" << tab4;
1028
1029           func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
1030
1031           if (i >= (pcount - numopt))
1032             func << tab4 << "}\n";
1033
1034           need_stub = 1;
1035         }
1036         i++;
1037       }
1038       p = l->get_next();
1039     }
1040
1041     func << tab4 << "my $result = " << package << "::" << iname << "(@args);\n";
1042
1043     // Now check to see what kind of return result was found.
1044     // If this function is returning a result by 'value', SWIG did an
1045     // implicit malloc/new.   We'll mark the object like it was created
1046     // in Perl so we can garbage collect it.
1047
1048     if ((classes.lookup(d->name)) && (d->is_pointer <=1)) {
1049
1050       func << tab4 << "return undef if (!defined($result));\n";
1051
1052       // If we're returning an object by value, put it's reference
1053       // into our local hash table
1054
1055       if ((d->is_pointer == 0) || ((d->is_pointer == 1) && NewObject)) {
1056         func << tab4 << "$" << (char *) classes.lookup(d->name) << "::OWNER{$result} = 1;\n";
1057       }
1058
1059       // We're returning a Perl "object" of some kind.  Turn it into
1060       // a tied hash
1061
1062       func << tab4 << "my %resulthash;\n"
1063         /*         << tab4 << "tie %resulthash, \"" << (char *) classes.lookup(d->name) << "\", $result;\n"
1064            << tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(d->name) << "\";\n"
1065         */
1066            << tab4 << "tie %resulthash, ref($result), $result;\n"
1067            << tab4 << "return bless \\%resulthash, ref($result);\n"
1068            << "}\n";
1069
1070       need_stub = 1;
1071     } else {
1072
1073       // Hmmm.  This doesn't appear to be anything I know about so just
1074       // return it unmolested.
1075
1076       func << tab4 <<"return $result;\n"
1077            << "}\n";
1078
1079     }
1080
1081     // Now check if we needed the stub.  If so, emit it, otherwise
1082     // Emit code to hack Perl's symbol table instead
1083
1084     if (need_stub) {
1085       func_stubs << func;
1086     } else {
1087       func_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
1088     }
1089   }
1090 }
1091
1092 // -----------------------------------------------------------------------
1093 // PERL5::link_variable(char *name, char *iname, DataType *d)
1094 //
1095 // Create a link to a C variable.
1096 // -----------------------------------------------------------------------
1097
1098 void PERL5::link_variable(char *name, char *iname, DataType *t)
1099 {
1100   char  set_name[256];
1101   char  val_name[256];
1102   WrapperFunction  getf, setf;
1103   char  *tm;
1104   sprintf(set_name,"_wrap_set_%s",iname);
1105   sprintf(val_name,"_wrap_val_%s",iname);
1106
1107   // Create a new scalar that we will attach magic to
1108
1109   vinit << tab4 << "sv = perl_get_sv(\"" << package << "::" << iname << "\",TRUE | 0x2);\n";
1110
1111   // Create a Perl function for setting the variable value
1112
1113   if (!(Status & STAT_READONLY)) {
1114     setf.def << "SWIGCLASS_STATIC int " << set_name << "(SV* sv, MAGIC *mg) {\n";
1115
1116     setf.code << tab4 << "MAGIC_PPERL\n";
1117     setf.code << tab4 << "mg = mg;\n";
1118
1119     /* Check for a few typemaps */
1120     if ((tm = typemap_lookup("varin","perl5",t,"","sv",name))) {
1121       setf.code << tm << "\n";
1122     } else if ((tm = typemap_lookup("in","perl5",t,"","sv",name))) {
1123       setf.code << tm << "\n";
1124     } else {
1125       if (!t->is_pointer) {
1126
1127         // Set the value to something
1128
1129         switch(t->type) {
1130         case T_INT : case T_BOOL: case T_SINT : case T_UINT:
1131         case T_SHORT : case T_SSHORT : case T_USHORT:
1132         case T_LONG : case T_SLONG : case T_ULONG:
1133         case T_UCHAR: case T_SCHAR:
1134           setf.code << tab4 << name << " = " << t->print_cast() << " SvIV(sv);\n";
1135           break;
1136         case T_DOUBLE :
1137         case T_FLOAT :
1138           setf.code << tab4 << name << " = " << t->print_cast() << " SvNV(sv);\n";
1139           break;
1140         case T_CHAR :
1141           setf.code << tab4 << name << " = (char) *SvPV(sv,PL_na);\n";
1142           break;
1143
1144         case T_USER:
1145
1146           // Add support for User defined type here
1147           // Get as a pointer value
1148
1149           t->is_pointer++;
1150           setf.add_local("void","*_temp");
1151           get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
1152           setf.code << tab4 << name << " = *(" << t->print_cast() << " _temp);\n";
1153           t->is_pointer--;
1154           break;
1155
1156         default :
1157           fprintf(stderr,"%s : Line %d.  Unable to link with datatype %s (ignored).\n", input_file, line_number, t->print_type());
1158           return;
1159         }
1160       } else {
1161         // Have some sort of pointer type here, Process it differently
1162         if ((t->type == T_CHAR) && (t->is_pointer == 1)) {
1163           setf.add_local("char","*_a");
1164           setf.code << tab4 << "_a = (char *) SvPV(sv,PL_na);\n";
1165
1166           if (CPlusPlus)
1167             setf.code << tab4 << "if (" << name << ") delete [] " << name << ";\n"
1168                       << tab4 << name << " = new char[strlen(_a)+1];\n";
1169           else
1170             setf.code << tab4 << "if (" << name << ") free(" << name << ");\n"
1171                       << tab4 << name << " = (char *) malloc(strlen(_a)+1);\n";
1172           setf.code << "strcpy(" << name << ",_a);\n";
1173         } else {
1174           // Set the value of a pointer
1175
1176           setf.add_local("void","*_temp");
1177           get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
1178           setf.code << tab4 << name << " = " << t->print_cast() << " _temp;\n";
1179         }
1180       }
1181     }
1182     setf.code << tab4 << "return 1;\n"
1183               << "}\n";
1184
1185     setf.code.replace("$name",iname);
1186     setf.print(magic);
1187
1188   }
1189
1190   // Now write a function to evaluate the variable
1191
1192   getf.def << "SWIGCLASS_STATIC int " << val_name << "(SV *sv, MAGIC *mg) {\n";
1193   getf.code << tab4 << "MAGIC_PPERL\n";
1194   getf.code << tab4 << "mg = mg;\n";
1195
1196   // Check for a typemap
1197
1198   if ((tm = typemap_lookup("varout","perl5",t,"",name, "sv"))) {
1199     getf.code << tm << "\n";
1200   } else  if ((tm = typemap_lookup("out","perl5",t,"",name,"sv"))) {
1201     setf.code << tm << "\n";
1202   } else {
1203     if (!t->is_pointer) {
1204       switch(t->type) {
1205       case T_INT : case T_BOOL: case T_SINT: case T_UINT:
1206       case T_SHORT : case T_SSHORT: case T_USHORT:
1207       case T_LONG : case T_SLONG : case T_ULONG:
1208       case T_UCHAR: case T_SCHAR:
1209         getf.code << tab4 << "sv_setiv(sv, (IV) " << name << ");\n";
1210         vinit << tab4 << "sv_setiv(sv,(IV)" << name << ");\n";
1211         break;
1212       case T_DOUBLE :
1213       case T_FLOAT :
1214         getf.code << tab4 << "sv_setnv(sv, (double) " << name << ");\n";
1215         vinit << tab4 << "sv_setnv(sv,(double)" << name << ");\n";
1216         break;
1217       case T_CHAR :
1218         getf.add_local("char","_ptemp[2]");
1219         getf.code << tab4 << "_ptemp[0] = " << name << ";\n"
1220                   << tab4 << "_ptemp[1] = 0;\n"
1221                   << tab4 << "sv_setpv((SV*) sv, _ptemp);\n";
1222         break;
1223       case T_USER:
1224         t->is_pointer++;
1225         getf.code << tab4 << "rsv = SvRV(sv);\n"
1226                   << tab4 << "sv_setiv(rsv,(IV) &" << name << ");\n";
1227
1228         // getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
1229         //  << "\", (void *) &" << name << ");\n";
1230
1231         getf.add_local("SV","*rsv");
1232         vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) &" << name << ");\n";
1233         t->is_pointer--;
1234
1235         break;
1236       default :
1237         break;
1238       }
1239     } else {
1240
1241       // Have some sort of arbitrary pointer type.  Return it as a string
1242
1243       if ((t->type == T_CHAR) && (t->is_pointer == 1))
1244         getf.code << tab4 << "sv_setpv((SV*) sv, " << name << ");\n";
1245       else {
1246         getf.code << tab4 << "rsv = SvRV(sv);\n"
1247                   << tab4 << "sv_setiv(rsv,(IV) " << name << ");\n";
1248         getf.add_local("SV","*rsv");
1249         vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) 1);\n";
1250
1251         //getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
1252         //        << "\", (void *) " << name << ");\n";
1253       }
1254     }
1255   }
1256   getf.code << tab4 << "return 1;\n"
1257             << "}\n";
1258
1259   getf.code.replace("$name",iname);
1260   getf.print(magic);
1261
1262   // Now add symbol to the PERL interpreter
1263   if (Status & STAT_READONLY) {
1264     vinit << tab4 << "swig_create_magic(sv,\"" << package << "::" << iname << "\",MAGIC_CAST MAGIC_CLASS swig_magic_readonly, MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
1265   } else {
1266     vinit << tab4 << "swig_create_magic(sv,\"" << package << "::" << iname << "\", MAGIC_CAST MAGIC_CLASS " << set_name << ", MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
1267   }
1268   // Add a documentation entry
1269
1270   if (doc_entry) {
1271     doc_entry->usage << usage_var(iname,t);
1272     doc_entry->cinfo << "Global : " << t->print_type() << " " << name;
1273   }
1274
1275   // If we're blessed, try to figure out what to do with the variable
1276   //     1.  If it's a Perl object of some sort, create a tied-hash
1277   //         around it.
1278   //     2.  Otherwise, just hack Perl's symbol table
1279
1280   if (blessed) {
1281     if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
1282       var_stubs << "\nmy %__" << iname << "_hash;\n"
1283                 << "tie %__" << iname << "_hash,\"" << (char *) classes.lookup(t->name) << "\", $"
1284                 << package << "::" << iname << ";\n"
1285                 << "$" << iname << "= \\%__" << iname << "_hash;\n"
1286                 << "bless $" << iname << ", " << (char *) classes.lookup(t->name) << ";\n";
1287     } else {
1288       var_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
1289     }
1290     if (export_all)
1291       exported << "$" << name << " ";
1292   }
1293 }
1294
1295 // -----------------------------------------------------------------------
1296 // PERL5::declare_const(char *name, char *iname, DataType *type, char *value)
1297 //
1298 // Makes a constant.  Really just creates a variable and creates a read-only
1299 // link to it.
1300 // ------------------------------------------------------------------------
1301
1302 // Functions used to create constants
1303
1304 static const char *setiv = "#ifndef PERL_OBJECT\
1305 \n#define swig_setiv(a,b) _swig_setiv(a,b)\
1306 \nstatic void _swig_setiv(char *name, long value) { \
1307 \n#else\
1308 \n#define swig_setiv(a,b) _swig_setiv(pPerl,a,b)\
1309 \nstatic void _swig_setiv(CPerlObj *pPerl, char *name, long value) { \
1310 \n#endif\
1311 \n     SV *sv; \
1312 \n     sv = perl_get_sv(name,TRUE | 0x2);\
1313 \n     sv_setiv(sv, (IV) value);\
1314 \n     SvREADONLY_on(sv);\
1315 \n}\n";
1316
1317 static const char *setnv = "#ifndef PERL_OBJECT\
1318 \n#define swig_setnv(a,b) _swig_setnv(a,b)\
1319 \nstatic void _swig_setnv(char *name, double value) { \
1320 \n#else\
1321 \n#define swig_setnv(a,b) _swig_setnv(pPerl,a,b)\
1322 \nstatic void _swig_setnv(CPerlObj *pPerl, char *name, double value) { \
1323 \n#endif\
1324 \n     SV *sv; \
1325 \n     sv = perl_get_sv(name,TRUE | 0x2);\
1326 \n     sv_setnv(sv, value);\
1327 \n     SvREADONLY_on(sv);\
1328 \n}\n";
1329
1330 static const char *setpv = "#ifndef PERL_OBJECT\
1331 \n#define swig_setpv(a,b) _swig_setpv(a,b)\
1332 \nstatic void _swig_setpv(char *name, char *value) { \
1333 \n#else\
1334 \n#define swig_setpv(a,b) _swig_setpv(pPerl,a,b)\
1335 \nstatic void _swig_setpv(CPerlObj *pPerl, char *name, char *value) { \
1336 \n#endif\
1337 \n     SV *sv; \
1338 \n     sv = perl_get_sv(name,TRUE | 0x2);\
1339 \n     sv_setpv(sv, value);\
1340 \n     SvREADONLY_on(sv);\
1341 \n}\n";
1342
1343 static const char *setrv = "#ifndef PERL_OBJECT\
1344 \n#define swig_setrv(a,b,c) _swig_setrv(a,b,c)\
1345 \nstatic void _swig_setrv(char *name, void *value, char *type) { \
1346 \n#else\
1347 \n#define swig_setrv(a,b,c) _swig_setrv(pPerl,a,b,c)\
1348 \nstatic void _swig_setrv(CPerlObj *pPerl, char *name, void *value, char *type) { \
1349 \n#endif\
1350 \n     SV *sv; \
1351 \n     sv = perl_get_sv(name,TRUE | 0x2);\
1352 \n     sv_setref_pv(sv, type, value);\
1353 \n     SvREADONLY_on(sv);\
1354 \n}\n";
1355
1356 void
1357 PERL5::declare_const(char *name, char *, DataType *type, char *value)
1358   {
1359
1360   char   *tm;
1361   static  int have_int_func = 0;
1362   static  int have_double_func = 0;
1363   static  int have_char_func = 0;
1364   static  int have_ref_func = 0;
1365
1366   if ((tm = typemap_lookup("const","perl5",type,name,value,name))) {
1367     fprintf(f_init,"%s\n",tm);
1368   } else {
1369     if ((type->type == T_USER) && (!type->is_pointer)) {
1370       fprintf(stderr,"%s : Line %d.  Unsupported constant value.\n", input_file, line_number);
1371       return;
1372     }
1373     // Generate a constant
1374     //    vinit << tab4 << "sv = perl_get_sv(\"" << package << "::" << name << "\",TRUE);\n";
1375     if (type->is_pointer == 0) {
1376       switch(type->type) {
1377       case T_INT:case T_SINT: case T_UINT: case T_BOOL:
1378       case T_SHORT: case T_SSHORT: case T_USHORT:
1379       case T_LONG: case T_SLONG: case T_ULONG:
1380       case T_SCHAR: case T_UCHAR:
1381         if (!have_int_func) {
1382           fprintf(f_header,"%s\n",setiv);
1383           have_int_func = 1;
1384         }
1385         vinit << tab4 << "swig_setiv(\"" << package << "::" << name << "\", (long) " << value << ");\n";
1386         break;
1387       case T_DOUBLE:
1388       case T_FLOAT:
1389         if (!have_double_func) {
1390           fprintf(f_header,"%s\n",setnv);
1391           have_double_func = 1;
1392         }
1393         vinit << tab4 << "swig_setnv(\"" << package << "::" << name << "\", (double) (" << value << "));\n";
1394         break;
1395       case T_CHAR :
1396         if (!have_char_func) {
1397           fprintf(f_header,"%s\n",setpv);
1398           have_char_func = 1;
1399         }
1400         vinit << tab4 << "swig_setpv(\"" << package << "::" << name << "\", \"" << value << "\");\n";
1401         break;
1402       default:
1403         fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
1404         break;
1405       }
1406     } else {
1407       if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
1408         if (!have_char_func) {
1409           fprintf(f_header,"%s\n",setpv);
1410           have_char_func = 1;
1411         }
1412         vinit << tab4 << "swig_setpv(\"" << package << "::" << name << "\", \"" << value << "\");\n";
1413       } else {
1414         // A user-defined type.  We're going to munge it into a string pointer value
1415         if (!have_ref_func) {
1416           fprintf(f_header,"%s\n",setrv);
1417           have_ref_func = 1;
1418         }
1419         vinit << tab4 << "swig_setrv(\"" << package << "::" << name << "\", (void *) " << value << ", \""
1420               << type->print_mangle() << "\");\n";
1421       }
1422     }
1423   }
1424
1425   // Patch up the documentation entry
1426
1427   if (doc_entry) {
1428     doc_entry->usage = "";
1429     doc_entry->usage << usage_const(name,type,value);
1430     doc_entry->cinfo = "";
1431     doc_entry->cinfo << "Constant: " << type->print_type();
1432   }
1433
1434   if (blessed) {
1435     if ((classes.lookup(type->name)) && (type->is_pointer <= 1)) {
1436       var_stubs << "\nmy %__" << name << "_hash;\n"
1437                 << "tie %__" << name << "_hash,\"" << (char *) classes.lookup(type->name) << "\", $"
1438                 << package << "::" << name << ";\n"
1439                 << "$" << name << "= \\%__" << name << "_hash;\n"
1440                 << "bless $" << name << ", " << (char *) classes.lookup(type->name) << ";\n";
1441     } else {
1442       var_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
1443     }
1444   }
1445   if (export_all)
1446     exported << "$" << name << " ";
1447 }
1448
1449 // ----------------------------------------------------------------------
1450 // PERL5::usage_var(char *iname, DataType *t)
1451 //
1452 // Produces a usage string for a Perl 5 variable.
1453 // ----------------------------------------------------------------------
1454
1455 char *PERL5::usage_var(char *iname, DataType *) {
1456
1457   static char temp[1024];
1458   char *c;
1459
1460   sprintf(temp,"$%s", iname);
1461   c = temp + strlen(temp);
1462   return temp;
1463 }
1464
1465 // ---------------------------------------------------------------------------
1466 // char *PERL5::usage_func(pkg, char *iname, DataType *t, ParmList *l)
1467 //
1468 // Produces a usage string for a function in Perl
1469 // ---------------------------------------------------------------------------
1470
1471 char *PERL5::usage_func(char *iname, DataType *, ParmList *l) {
1472
1473   static String temp;
1474   Parm  *p;
1475   int    i;
1476
1477   temp = "";
1478   temp << iname << "(";
1479
1480   /* Now go through and print parameters */
1481
1482   p = l->get_first();
1483   i = 0;
1484   while (p != 0) {
1485     if (!p->ignore) {
1486       /* If parameter has been named, use that.   Otherwise, just print a type  */
1487
1488       if ((p->t->type != T_VOID) || (p->t->is_pointer)) {
1489         if (strlen(p->name) > 0) {
1490           temp << p->name;
1491         } else {
1492           temp << p->t->print_type();
1493         }
1494       }
1495       i++;
1496       p = l->get_next();
1497       if (p)
1498         if (!p->ignore)
1499           temp << ",";
1500     } else {
1501       p = l->get_next();
1502       if (p)
1503         if ((i>0) && (!p->ignore))
1504           temp << ",";
1505     }
1506   }
1507   temp << ");";
1508   return temp.get();
1509 }
1510
1511 // ----------------------------------------------------------------------
1512 // PERL5::usage_const(char *iname, DataType *type, char *value)
1513 //
1514 // Produces a usage string for a Perl 5 constant
1515 // ----------------------------------------------------------------------
1516
1517 char *PERL5::usage_const(char *iname, DataType *, char *value) {
1518
1519   static char temp[1024];
1520   if (value) {
1521     sprintf(temp,"$%s = %s", iname, value);
1522   } else {
1523     sprintf(temp,"$%s", iname);
1524   }
1525   return temp;
1526 }
1527
1528 // -----------------------------------------------------------------------
1529 // PERL5::add_native(char *name, char *funcname)
1530 //
1531 // Add a native module name to Perl5.
1532 // -----------------------------------------------------------------------
1533
1534 void PERL5::add_native(char *name, char *funcname) {
1535   fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package,name, funcname);
1536   if (export_all)
1537     exported << name << " ";
1538   if (blessed) {
1539     func_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
1540   }
1541 }
1542
1543 /****************************************************************************
1544  ***                      OBJECT-ORIENTED FEATURES
1545  ****************************************************************************
1546  *** These extensions provide a more object-oriented interface to C++
1547  *** classes and structures.    The code here is based on extensions
1548  *** provided by David Fletcher and Gary Holt.
1549  ***
1550  *** I have generalized these extensions to make them more general purpose
1551  *** and to resolve object-ownership problems.
1552  ***
1553  *** The approach here is very similar to the Python module :
1554  ***       1.   All of the original methods are placed into a single
1555  ***            package like before except that a 'c' is appended to the
1556  ***            package name.
1557  ***
1558  ***       2.   All methods and function calls are wrapped with a new
1559  ***            perl function.   While possibly inefficient this allows
1560  ***            us to catch complex function arguments (which are hard to
1561  ***            track otherwise).
1562  ***
1563  ***       3.   Classes are represented as tied-hashes in a manner similar
1564  ***            to Gary Holt's extension.   This allows us to access
1565  ***            member data.
1566  ***
1567  ***       4.   Stand-alone (global) C functions are modified to take
1568  ***            tied hashes as arguments for complex datatypes (if
1569  ***            appropriate).
1570  ***
1571  ***       5.   Global variables involving a class/struct is encapsulated
1572  ***            in a tied hash.
1573  ***
1574  ***       6.   Object ownership is maintained by having a hash table
1575  ***            within in each package called "this".  It is unlikely
1576  ***            that C++ program will use this so it's a somewhat
1577  ***            safe variable name.
1578  ***
1579  ****************************************************************************/
1580
1581 static int class_renamed = 0;
1582 static String fullclassname;
1583
1584 // --------------------------------------------------------------------------
1585 // PERL5::cpp_open_class(char *classname, char *rname, int strip)
1586 //
1587 // Opens a new C++ class or structure.   Basically, this just records
1588 // the class name and clears a few variables.
1589 // --------------------------------------------------------------------------
1590
1591 void PERL5::cpp_open_class(char *classname, char *rname, char *ctype, int strip) {
1592
1593   char temp[256];
1594   extern void typeeq_addtypedef(char *, char *);
1595
1596   // Register this with the default class handler
1597
1598   this->Language::cpp_open_class(classname, rname, ctype, strip);
1599
1600   if (blessed) {
1601     have_constructor = 0;
1602     have_destructor = 0;
1603     have_data_members = 0;
1604
1605     // If the class is being renamed to something else, use the renaming
1606
1607     if (rname) {
1608       class_name = copy_string(rname);
1609       class_renamed = 1;
1610       // Now things get even more hideous.   Need to register an equivalence
1611       // between the renamed name and the new name. Yuck!
1612       //      printf("%s %s\n", classname, rname);
1613         typeeq_addtypedef(classname,rname);
1614         typeeq_addtypedef(rname,classname);
1615      /*
1616       fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",classname,rname);
1617       fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",rname,classname);
1618       */
1619     } else {
1620       class_name = copy_string(classname);
1621       class_renamed = 0;
1622     }
1623
1624     // A highly experimental feature.  This is the fully qualified
1625     // name of the Perl class
1626
1627     if (!compat) {
1628       fullclassname = realpackage;
1629       fullclassname << "::" << class_name;
1630     } else {
1631       fullclassname = class_name;
1632     }
1633
1634     fullclassname = class_name;
1635
1636     real_classname = copy_string(classname);
1637     if (base_class) delete base_class;
1638     base_class =  0;
1639     class_type = copy_string(ctype);
1640     pcode = new String();
1641     blessedmembers = new String();
1642     member_keys = new String();
1643
1644     // Add some symbols to the hash tables
1645
1646     //    classes.add(real_classname,copy_string(class_name));   /* Map original classname to class */
1647     classes.add(real_classname,copy_string(fullclassname));   /* Map original classname to class */
1648
1649     // Add full name of datatype to the hash table just in case the user uses it
1650
1651     sprintf(temp,"%s %s", class_type, fullclassname.get());
1652     //    classes.add(temp,copy_string(class_name));             /* Map full classname to classs    */
1653   }
1654 }
1655
1656 // -------------------------------------------------------------------------------
1657 // PERL5::cpp_close_class()
1658 //
1659 // These functions close a class definition.
1660 //
1661 // This also sets up the hash table of classes we've seen go by.
1662 // -------------------------------------------------------------------------------
1663
1664 void PERL5::cpp_close_class() {
1665
1666   // We need to check to make sure we got constructors, and other
1667   // stuff here.
1668
1669   if (blessed) {
1670     pm << "\n############# Class : " << fullclassname << " ##############\n";
1671     pm << "\npackage " << fullclassname << ";\n";
1672
1673     // If we are inheriting from a base class, set that up
1674
1675     if (strcmp(class_name,realpackage))
1676       pm << "@ISA = qw( " << realpackage;
1677     else
1678       pm << "@ISA = qw( ";
1679
1680     if (base_class) {
1681       pm << " " << *base_class;
1682     }
1683     pm << " );\n";
1684
1685     // Dump out a hash table containing the pointers that we own
1686
1687     pm << "%OWNER = ();\n";
1688     if (have_data_members) {
1689       pm << "%BLESSEDMEMBERS = (\n"
1690          << blessedmembers->get()
1691            << ");\n\n";
1692     }
1693     if (have_data_members || have_destructor)
1694       pm << "%ITERATORS = ();\n";
1695
1696
1697     // Dump out the package methods
1698
1699     pm << *pcode;
1700     delete pcode;
1701
1702     // Output methods for managing ownership
1703
1704     pm << "sub DISOWN {\n"
1705        << tab4 << "my $self = shift;\n"
1706        << tab4 << "my $ptr = tied(%$self);\n"
1707        << tab4 << "delete $OWNER{$ptr};\n"
1708        << tab4 << "};\n\n"
1709        << "sub ACQUIRE {\n"
1710        << tab4 << "my $self = shift;\n"
1711        << tab4 << "my $ptr = tied(%$self);\n"
1712        << tab4 << "$OWNER{$ptr} = 1;\n"
1713        << tab4 << "};\n\n";
1714
1715     // Only output the following methods if a class has member data
1716
1717     if (have_data_members) {
1718
1719       // Output a FETCH method.  This is actually common to all classes
1720       pm << "sub FETCH {\n"
1721          << tab4 << "my ($self,$field) = @_;\n"
1722          << tab4 << "my $member_func = \"" << package << "::" << name_get(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
1723          << tab4 << "my $val = &$member_func($self);\n"
1724          << tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
1725          << tab8 << "return undef if (!defined($val));\n"
1726          << tab8 << "my %retval;\n"
1727          << tab8 << "tie %retval,$BLESSEDMEMBERS{$field},$val;\n"
1728          << tab8 << "return bless \\%retval, $BLESSEDMEMBERS{$field};\n"
1729          << tab4 << "}\n"
1730          << tab4 << "return $val;\n"
1731          << "}\n\n";
1732
1733       // Output a STORE method.   This is also common to all classes (might move to base class)
1734
1735       pm << "sub STORE {\n"
1736          << tab4 << "my ($self,$field,$newval) = @_;\n"
1737          << tab4 << "my $member_func = \"" << package << "::" << name_set(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
1738          << tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
1739          << tab8 << "&$member_func($self,tied(%{$newval}));\n"
1740          << tab4 << "} else {\n"
1741          << tab8 << "&$member_func($self,$newval);\n"
1742          << tab4 << "}\n"
1743          << "}\n\n";
1744
1745       // Output a FIRSTKEY method.   This is to allow iteration over a structure's keys.
1746
1747       pm << "sub FIRSTKEY {\n"
1748          << tab4 << "my $self = shift;\n"
1749          << tab4 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
1750          << tab4 << "my $first = shift @{$ITERATORS{$self}};\n"
1751          << tab4 << "return $first;\n"
1752          << "}\n\n";
1753
1754       // Output a NEXTKEY method.   This is the iterator so that each and keys works
1755
1756       pm << "sub NEXTKEY {\n"
1757          << tab4 << "my $self = shift;\n"
1758          << tab4 << "$nelem = scalar @{$ITERATORS{$self}};\n"
1759          << tab4 << "if ($nelem > 0) {\n"
1760          << tab8 << "my $member = shift @{$ITERATORS{$self}};\n"
1761          << tab8 << "return $member;\n"
1762          << tab4 << "} else {\n"
1763          << tab8 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
1764          << tab8 << "return ();\n"
1765          << tab4 << "}\n"
1766          << "}\n\n";
1767     }
1768   }
1769 }
1770
1771 // --------------------------------------------------------------------------
1772 // PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l)
1773 //
1774 // Handles a C++ member function.    This basically does the same thing as
1775 // the non-C++ version, but we set up a few status variables that affect
1776 // the function generation function.
1777 //
1778 // --------------------------------------------------------------------------
1779
1780 void PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l) {
1781
1782   String  func;
1783   char    *realname;
1784   Parm    *p;
1785   int      i;
1786   String  cname = "perl5:";
1787   int      pcount, numopt;
1788
1789   // First emit normal member function
1790
1791   member_func = 1;
1792   this->Language::cpp_member_func(name,iname,t,l);
1793   member_func = 0;
1794
1795   if (!blessed) return;
1796
1797   // Now emit a Perl wrapper function around our member function, we might need
1798   // to patch up some arguments along the way
1799
1800   if (!iname)
1801     realname = name;
1802   else
1803     realname = iname;
1804
1805   cname << class_name << "::" << realname;
1806   if (add_symbol(cname.get(),0,0)) {
1807     return;    // Forget it, we saw this function already
1808   }
1809
1810   func << "sub " << realname << " {\n"
1811        << tab4 << "my @args = @_;\n"
1812        << tab4 << "$args[0] = tied(%{$args[0]});\n";
1813
1814   // Now we have to go through and patch up the argument list.  If any
1815   // arguments to our function correspond to other Perl objects, we
1816   // need to extract them from a tied-hash table object.
1817
1818   p = l->get_first();
1819   pcount = l->nparms;
1820   numopt = l->numopt();
1821   i = 1;
1822   while(p) {
1823     if (!p->ignore) {
1824
1825       // Look up the datatype name here
1826       if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
1827         // Yep.   This smells alot like an object, patch up the arguments
1828
1829         if (i >= (pcount - numopt))
1830           func << tab4 << "if (scalar(@args) >= " << i << ") {\n";
1831
1832         func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
1833
1834         if (i >= (pcount - numopt))
1835           func << tab4 << "}\n";
1836       }
1837       i++;
1838     }
1839     p = l->get_next();
1840   }
1841
1842   // Okay.  We've made argument adjustments, now call into the package
1843
1844   func << tab4 << "my $result = " << package << "::" << name_member(realname,class_name)
1845        << "(@args);\n";
1846
1847   // Now check to see what kind of return result was found.
1848   // If this function is returning a result by 'value', SWIG did an
1849   // implicit malloc/new.   We'll mark the object like it was created
1850   // in Perl so we can garbage collect it.
1851
1852   if ((classes.lookup(t->name)) && (t->is_pointer <=1)) {
1853
1854     func << tab4 << "return undef if (!defined($result));\n";
1855
1856     // If we're returning an object by value, put it's reference
1857     // into our local hash table
1858
1859     if ((t->is_pointer == 0) || ((t->is_pointer == 1) && NewObject)) {
1860       func << tab4 << "$" << (char *) classes.lookup(t->name) << "::OWNER{$result} = 1;\n";
1861     }
1862
1863     // We're returning a Perl "object" of some kind.  Turn it into
1864     // a tied hash
1865
1866     func << tab4 << "my %resulthash;\n"
1867       /*         << tab4 << "tie %resulthash, \"" << (char *) classes.lookup(t->name) << "\", $result;\n"
1868                  << tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(t->name) << "\";\n" */
1869          << tab4 << "tie %resulthash, ref($result), $result;\n"
1870          << tab4 << "return bless \\%resulthash, ref($result);\n"
1871
1872          << "}\n";
1873
1874   } else {
1875
1876     // Hmmm.  This doesn't appear to be anything I know about so just
1877     // return it unmolested.
1878
1879     func << tab4 <<"return $result;\n"
1880          << "}\n";
1881
1882   }
1883
1884   // Append our function to the pcode segment
1885
1886   *pcode << func;
1887
1888   // Create a new kind of documentation entry for the shadow class
1889
1890   if (doc_entry) {
1891     doc_entry->usage = "";            // Blow away whatever was there before
1892     doc_entry->usage << usage_func(realname,t,l);
1893   }
1894 }
1895
1896 // --------------------------------------------------------------------------------
1897 // PERL5::cpp_variable(char *name, char *iname, DataType *t)
1898 //
1899 // Adds an instance member.   This is a little hairy because data members are
1900 // really added with a tied-hash table that is attached to the object.
1901 //
1902 // On the low level, we will emit a pair of get/set functions to retrieve
1903 // values just like before.    These will then be encapsulated in a FETCH/STORE
1904 // method associated with the tied-hash.
1905 //
1906 // In the event that a member is an object that we have already wrapped, then
1907 // we need to retrieve the data a tied-hash as opposed to what SWIG normally
1908 // returns.   To determine this, we build an internal hash called 'BLESSEDMEMBERS'
1909 // that contains the names and types of tied data members.  If a member name
1910 // is in the list, we tie it, otherwise, we just return the normal SWIG value.
1911 // --------------------------------------------------------------------------------
1912
1913 void PERL5::cpp_variable(char *name, char *iname, DataType *t) {
1914
1915   char *realname;
1916   String cname = "perl5:";
1917
1918   // Emit a pair of get/set functions for the variable
1919
1920   member_func = 1;
1921   this->Language::cpp_variable(name, iname, t);
1922   member_func = 0;
1923
1924   if (iname) realname = iname;
1925   else realname = name;
1926
1927   if (blessed) {
1928     cname << class_name << "::" << realname;
1929     if (add_symbol(cname.get(),0,0)) {
1930       return;    // Forget it, we saw this already
1931     }
1932
1933     // Store name of key for future reference
1934
1935     *member_keys << "'" << realname << "', ";
1936
1937     // Now we need to generate a little Perl code for this
1938
1939     if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
1940
1941       // This is a Perl object that we have already seen.  Add an
1942       // entry to the members list
1943
1944       *blessedmembers << tab4 << realname << " => '" << (char *) classes.lookup(t->name) << "',\n";
1945
1946      }
1947
1948     // Patch up the documentation entry
1949
1950     if (doc_entry) {
1951       doc_entry->usage = "";
1952       doc_entry->usage << "$this->{" << realname << "}";
1953     }
1954   }
1955   have_data_members++;
1956 }
1957
1958
1959 // -----------------------------------------------------------------------------
1960 // void PERL5::cpp_constructor(char *name, char *iname, ParmList *l)
1961 //
1962 // Emits a blessed constructor for our class.    In addition to our construct
1963 // we manage a Perl hash table containing all of the pointers created by
1964 // the constructor.   This prevents us from accidentally trying to free
1965 // something that wasn't necessarily allocated by malloc or new
1966 // -----------------------------------------------------------------------------
1967
1968 void PERL5::cpp_constructor(char *name, char *iname, ParmList *l) {
1969   Parm *p;
1970   int   i;
1971   char  *realname;
1972   String cname="perl5:constructor:";
1973
1974   // Emit an old-style constructor for this class
1975
1976   member_func = 1;
1977   this->Language::cpp_constructor(name, iname, l);
1978
1979   if (blessed) {
1980
1981     if (iname)
1982       realname = iname;
1983     else {
1984       if (class_renamed) realname = class_name;
1985       else realname = class_name;
1986     }
1987
1988     cname << class_name << "::" << realname;
1989     if (add_symbol(cname.get(),0,0)) {
1990       return;    // Forget it, we saw this already
1991     }
1992     if ((strcmp(realname,class_name) == 0) || ((!iname) && (ObjCClass)) ){
1993
1994       // Emit a blessed constructor
1995
1996       *pcode << "sub new {\n";
1997
1998     } else {
1999
2000       // Constructor doesn't match classname so we'll just use the normal name
2001
2002       *pcode << "sub " << name_construct(realname) << " () {\n";
2003
2004     }
2005
2006     *pcode << tab4 << "my $self = shift;\n"
2007            << tab4 << "my @args = @_;\n";
2008
2009     // We are going to need to patch up arguments here if necessary
2010     // Now we have to go through and patch up the argument list.  If any
2011     // arguments to our function correspond to other Perl objects, we
2012     // need to extract them from a tied-hash table object.
2013
2014     p = l->get_first();
2015     i = 0;
2016     while(p) {
2017
2018       // Look up the datatype name here
2019
2020       if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
2021
2022         // Yep.   This smells alot like an object, patch up the arguments
2023         *pcode << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
2024       }
2025       p = l->get_next();
2026       i++;
2027     }
2028
2029     *pcode << tab4 << "$self = " << package << "::" << name_construct(realname) << "(@args);\n"
2030            << tab4 << "return undef if (!defined($self));\n"
2031            << tab4 << "bless $self, \"" << fullclassname << "\";\n"
2032            << tab4 << "$OWNER{$self} = 1;\n"
2033            << tab4 << "my %retval;\n"
2034            << tab4 << "tie %retval, \"" << fullclassname << "\", $self;\n"
2035            << tab4 << "return bless \\%retval,\"" << fullclassname << "\";\n"
2036            << "}\n\n";
2037     have_constructor = 1;
2038
2039     // Patch up the documentation entry
2040
2041     if (doc_entry) {
2042       doc_entry->usage = "";
2043       doc_entry->usage << usage_func("new",0,l);
2044     }
2045   }
2046   member_func = 0;
2047 }
2048
2049
2050 // ------------------------------------------------------------------------------
2051 // void PERL5::cpp_destructor(char *name, char *newname)
2052 //
2053 // Creates a destructor for a blessed object
2054 // ------------------------------------------------------------------------------
2055
2056 void PERL5::cpp_destructor(char *name, char *newname) {
2057
2058   char *realname;
2059   member_func = 1;
2060   this->Language::cpp_destructor(name, newname);
2061
2062   if (blessed) {
2063     if (newname) realname = newname;
2064     else {
2065       if (class_renamed) realname = class_name;
2066       else realname = name;
2067     }
2068
2069     // Emit a destructor for this object
2070
2071     *pcode << "sub DESTROY {\n"
2072            << tab4 << "my $self = tied(%{$_[0]});\n"
2073            << tab4 << "delete $ITERATORS{$self};\n"
2074            << tab4 << "if (exists $OWNER{$self}) {\n"
2075            << tab8 <<  package << "::" << name_destroy(realname) << "($self);\n"
2076            << tab8 << "delete $OWNER{$self};\n"
2077            << tab4 << "}\n}\n\n";
2078
2079     have_destructor = 1;
2080
2081     if (doc_entry) {
2082       doc_entry->usage = "DESTROY";
2083       doc_entry->cinfo = "Destructor";
2084     }
2085   }
2086   member_func = 0;
2087 }
2088 // -----------------------------------------------------------------------------
2089 // void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l)
2090 //
2091 // Emits a wrapper for a static class function.   Basically, we just call the
2092 // appropriate method in the module package.
2093 // ------------------------------------------------------------------------------
2094 void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l) {
2095   this->Language::cpp_static_func(name,iname,t,l);
2096   char *realname;
2097   if (iname) realname = name;
2098   else realname = iname;
2099
2100   if (blessed) {
2101     *pcode << "*" << realname << " = *" << realpackage << "::" << name_member(realname,class_name) << ";\n";
2102   }
2103 }
2104
2105 // ------------------------------------------------------------------------------
2106 // void PERL5::cpp_inherit(char **baseclass, int mode)
2107 //
2108 // This sets the Perl5 baseclass (if possible).
2109 // ------------------------------------------------------------------------------
2110
2111 void PERL5::cpp_inherit(char **baseclass, int) {
2112
2113   char *bc;
2114   int  i = 0, have_first = 0;
2115   if (!blessed) {
2116     this->Language::cpp_inherit(baseclass);
2117     return;
2118   }
2119
2120   // Inherit variables and constants from base classes, but not
2121   // functions (since Perl can handle that okay).
2122
2123   this->Language::cpp_inherit(baseclass, INHERIT_CONST | INHERIT_VAR);
2124
2125   // Now tell the Perl5 module that we're inheriting from base classes
2126
2127   base_class = new String;
2128   while (baseclass[i]) {
2129     // See if this is a class we know about
2130     bc = (char *) classes.lookup(baseclass[i]);
2131     if (bc) {
2132       if (have_first) *base_class << " ";
2133       *base_class << bc;
2134       have_first = 1;
2135     }
2136     i++;
2137   }
2138   if (!have_first) {
2139     delete base_class;
2140     base_class = 0;
2141   }
2142 }
2143
2144 // --------------------------------------------------------------------------------
2145 // PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value)
2146 //
2147 // Add access to a C++ constant.  We can really just do this by hacking
2148 // the symbol table
2149 // --------------------------------------------------------------------------------
2150
2151 void PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value) {
2152   char *realname;
2153   int   oldblessed = blessed;
2154   String cname;
2155
2156   // Create a normal constant
2157   blessed = 0;
2158   this->Language::cpp_declare_const(name, iname, type, value);
2159   blessed = oldblessed;
2160
2161   if (blessed) {
2162     if (!iname)
2163       realname = name;
2164     else
2165       realname = iname;
2166
2167     cname << class_name << "::" << realname;
2168     if (add_symbol(cname.get(),0,0)) {
2169       return;    // Forget it, we saw this already
2170     }
2171
2172     // Create a symbol table entry for it
2173     *pcode << "*" << realname << " = *" << package << "::" << name_member(realname,class_name) << ";\n";
2174
2175     // Fix up the documentation entry
2176
2177     if (doc_entry) {
2178       doc_entry->usage = "";
2179       doc_entry->usage << realname;
2180       if (value) {
2181         doc_entry->usage << " = " << value;
2182       }
2183     }
2184   }
2185 }
2186
2187 // -----------------------------------------------------------------------
2188 // PERL5::cpp_class_decl(char *name, char *rename, char *type)
2189 //
2190 // Treatment of an empty class definition.    Used to handle
2191 // shadow classes across modules.
2192 // -----------------------------------------------------------------------
2193
2194 void PERL5::cpp_class_decl(char *name, char *rename, char *type) {
2195     char temp[256];
2196     if (blessed) {
2197         classes.add(name,copy_string(rename));
2198         // Add full name of datatype to the hash table
2199         if (strlen(type) > 0) {
2200           sprintf(temp,"%s %s", type, name);
2201           classes.add(temp,copy_string(rename));
2202         }
2203     }
2204 }
2205
2206 // --------------------------------------------------------------------------------
2207 // PERL5::add_typedef(DataType *t, char *name)
2208 //
2209 // This is called whenever a typedef is encountered.   When shadow classes are
2210 // used, this function lets us discovered hidden uses of a class.  For example :
2211 //
2212 //     struct FooBar {
2213 //            ...
2214 //     }
2215 //
2216 // typedef FooBar *FooBarPtr;
2217 //
2218 // --------------------------------------------------------------------------------
2219
2220 void PERL5::add_typedef(DataType *t, char *name) {
2221
2222   if (!blessed) return;
2223
2224   // First check to see if there aren't too many pointers
2225
2226   if (t->is_pointer > 1) return;
2227
2228   if (classes.lookup(name)) return;      // Already added
2229
2230   // Now look up the datatype in our shadow class hash table
2231
2232   if (classes.lookup(t->name)) {
2233
2234     // Yep.   This datatype is in the hash
2235
2236     // Put this types 'new' name into the hash
2237
2238     classes.add(name,copy_string((char *) classes.lookup(t->name)));
2239   }
2240 }
2241
2242
2243 // --------------------------------------------------------------------------------
2244 // PERL5::pragma(char *, char *, char *)
2245 //
2246 // Pragma directive.
2247 //
2248 // %pragma(perl5) code="String"              # Includes a string in the .pm file
2249 // %pragma(perl5) include="file.pl"          # Includes a file in the .pm file
2250 //
2251 // --------------------------------------------------------------------------------
2252
2253 void PERL5::pragma(char *lang, char *code, char *value) {
2254   if (strcmp(lang,"perl5") == 0) {
2255     if (strcmp(code,"code") == 0) {
2256       // Dump the value string into the .pm file
2257       if (value) {
2258         pragma_include << value << "\n";
2259       }
2260     } else if (strcmp(code,"include") == 0) {
2261       // Include a file into the .pm file
2262       if (value) {
2263         if (get_file(value,pragma_include) == -1) {
2264           fprintf(stderr,"%s : Line %d. Unable to locate file %s\n", input_file, line_number,value);
2265         }
2266       }
2267     } else {
2268       fprintf(stderr,"%s : Line %d. Unrecognized pragma.\n", input_file,line_number);
2269     }
2270   }
2271 }