PageRenderTime 137ms CodeModel.GetById 29ms app.highlight 95ms RepoModel.GetById 2ms app.codeStats 0ms

/trunk/Source/Modules/perl5.cxx

#
C++ | 1769 lines | 1236 code | 252 blank | 281 comment | 343 complexity | 7f59f4904151c9d776700a11da856e8d MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1/* ----------------------------------------------------------------------------
   2 * This file is part of SWIG, which is licensed as a whole under version 3 
   3 * (or any later version) of the GNU General Public License. Some additional
   4 * terms also apply to certain portions of SWIG. The full details of the SWIG
   5 * license and copyrights can be found in the LICENSE and COPYRIGHT files
   6 * included with the SWIG source code as distributed by the SWIG developers
   7 * and at http://www.swig.org/legal.html.
   8 *
   9 * perl5.cxx
  10 *
  11 * Perl5 language module for SWIG.
  12 * ------------------------------------------------------------------------- */
  13
  14char cvsroot_perl5_cxx[] = "$Id: perl5.cxx 12830 2011-10-30 21:51:50Z wsfulton $";
  15
  16#include "swigmod.h"
  17#include "cparse.h"
  18static int treduce = SWIG_cparse_template_reduce(0);
  19
  20#include <ctype.h>
  21
  22static const char *usage = (char *) "\
  23Perl5 Options (available with -perl5)\n\
  24     -compat         - Compatibility mode\n\
  25     -const          - Wrap constants as constants and not variables (implies -proxy)\n\
  26     -cppcast        - Enable C++ casting operators\n\
  27     -nocppcast      - Disable C++ casting operators, useful for generating bugs\n\
  28     -nopm           - Do not generate the .pm file\n\
  29     -noproxy        - Don't create proxy classes\n\
  30     -proxy          - Create proxy classes\n\
  31     -static         - Omit code related to dynamic loading\n\
  32\n";
  33
  34static int compat = 0;
  35
  36static int no_pmfile = 0;
  37
  38static int export_all = 0;
  39
  40/*
  41 * pmfile
  42 *   set by the -pm flag, overrides the name of the .pm file
  43 */
  44static String *pmfile = 0;
  45
  46/*
  47 * module
  48 *   set by the %module directive, e.g. "Xerces". It will determine
  49 *   the name of the .pm file, and the dynamic library, and the name
  50 *   used by any module wanting to %import the module.
  51 */
  52static String *module = 0;
  53
  54/*
  55 * namespace_module
  56 *   the fully namespace qualified name of the module. It will be used
  57 *   to set the package namespace in the .pm file, as well as the name
  58 *   of the initialization methods in the glue library. This will be
  59 *   the same as module, above, unless the %module directive is given
  60 *   the 'package' option, e.g. %module(package="Foo::Bar") "baz"
  61 */
  62static String       *namespace_module = 0;
  63
  64/*
  65 * cmodule
  66 *   the namespace of the internal glue code, set to the value of
  67 *   module with a 'c' appended
  68 */
  69static String *cmodule = 0;
  70
  71/*
  72 * dest_package
  73 *   an optional namespace to put all classes into. Specified by using
  74 *   the %module(package="Foo::Bar") "baz" syntax
  75 */
  76static String       *dest_package = 0;
  77
  78static String *command_tab = 0;
  79static String *constant_tab = 0;
  80static String *variable_tab = 0;
  81
  82static File *f_begin = 0;
  83static File *f_runtime = 0;
  84static File *f_header = 0;
  85static File *f_wrappers = 0;
  86static File *f_init = 0;
  87static File *f_pm = 0;
  88static String *pm;		/* Package initialization code */
  89static String *magic;		/* Magic variable wrappers     */
  90
  91static int staticoption = 0;
  92
  93// controlling verbose output
  94static int          verbose = 0;
  95
  96/* The following variables are used to manage Perl5 classes */
  97
  98static int blessed = 1;		/* Enable object oriented features */
  99static int do_constants = 0;	/* Constant wrapping */
 100static List *classlist = 0;	/* List of classes */
 101static int have_constructor = 0;
 102static int have_destructor = 0;
 103static int have_data_members = 0;
 104static String *class_name = 0;	/* Name of the class (what Perl thinks it is) */
 105static String *real_classname = 0;	/* Real name of C/C++ class */
 106static String *fullclassname = 0;
 107
 108static String *pcode = 0;	/* Perl code associated with each class */
 109						  /* static  String   *blessedmembers = 0;     *//* Member data associated with each class */
 110static int member_func = 0;	/* Set to 1 when wrapping a member function */
 111static String *func_stubs = 0;	/* Function stubs */
 112static String *const_stubs = 0;	/* Constant stubs */
 113static int num_consts = 0;	/* Number of constants */
 114static String *var_stubs = 0;	/* Variable stubs */
 115static String *exported = 0;	/* Exported symbols */
 116static String *pragma_include = 0;
 117static String *additional_perl_code = 0;	/* Additional Perl code from %perlcode %{ ... %} */
 118static Hash *operators = 0;
 119static int have_operators = 0;
 120
 121class PERL5:public Language {
 122public:
 123
 124  PERL5():Language () {
 125    Clear(argc_template_string);
 126    Printv(argc_template_string, "items", NIL);
 127    Clear(argv_template_string);
 128    Printv(argv_template_string, "ST(%d)", NIL);
 129  }
 130
 131  /* Test to see if a type corresponds to something wrapped with a shadow class */
 132  Node *is_shadow(SwigType *t) {
 133    Node *n;
 134    n = classLookup(t);
 135    /*  Printf(stdout,"'%s' --> '%x'\n", t, n); */
 136    if (n) {
 137      if (!Getattr(n, "perl5:proxy")) {
 138	setclassname(n);
 139      }
 140      return Getattr(n, "perl5:proxy");
 141    }
 142    return 0;
 143  }
 144
 145  /* ------------------------------------------------------------
 146   * main()
 147   * ------------------------------------------------------------ */
 148
 149  virtual void main(int argc, char *argv[]) {
 150    int i = 1;
 151    int cppcast = 1;
 152
 153    SWIG_library_directory("perl5");
 154
 155    for (i = 1; i < argc; i++) {
 156      if (argv[i]) {
 157	if (strcmp(argv[i], "-package") == 0) {
 158	  Printv(stderr,
 159		 "*** -package is no longer supported\n*** use the directive '%module A::B::C' in your interface file instead\n*** see the Perl section in the manual for details.\n", NIL);
 160	  SWIG_exit(EXIT_FAILURE);
 161	} else if (strcmp(argv[i], "-interface") == 0) {
 162	  Printv(stderr,
 163		 "*** -interface is no longer supported\n*** use the directive '%module A::B::C' in your interface file instead\n*** see the Perl section in the manual for details.\n", NIL);
 164	  SWIG_exit(EXIT_FAILURE);
 165	} else if (strcmp(argv[i], "-exportall") == 0) {
 166	  export_all = 1;
 167	  Swig_mark_arg(i);
 168	} else if (strcmp(argv[i], "-static") == 0) {
 169	  staticoption = 1;
 170	  Swig_mark_arg(i);
 171	} else if ((strcmp(argv[i], "-shadow") == 0) || ((strcmp(argv[i], "-proxy") == 0))) {
 172	  blessed = 1;
 173	  Swig_mark_arg(i);
 174	} else if ((strcmp(argv[i], "-noproxy") == 0)) {
 175	  blessed = 0;
 176	  Swig_mark_arg(i);
 177	} else if (strcmp(argv[i], "-const") == 0) {
 178	  do_constants = 1;
 179	  blessed = 1;
 180	  Swig_mark_arg(i);
 181	} else if (strcmp(argv[i], "-nopm") == 0) {
 182	  no_pmfile = 1;
 183	  Swig_mark_arg(i);
 184	} else if (strcmp(argv[i], "-pm") == 0) {
 185	  Swig_mark_arg(i);
 186	  i++;
 187	  pmfile = NewString(argv[i]);
 188	  Swig_mark_arg(i);
 189	} else if (strcmp(argv[i],"-v") == 0) {
 190	    Swig_mark_arg(i);
 191	    verbose++;
 192	} else if (strcmp(argv[i], "-cppcast") == 0) {
 193	  cppcast = 1;
 194	  Swig_mark_arg(i);
 195	} else if (strcmp(argv[i], "-nocppcast") == 0) {
 196	  cppcast = 0;
 197	  Swig_mark_arg(i);
 198	} else if (strcmp(argv[i], "-compat") == 0) {
 199	  compat = 1;
 200	  Swig_mark_arg(i);
 201	} else if (strcmp(argv[i], "-help") == 0) {
 202	  fputs(usage, stdout);
 203	}
 204      }
 205    }
 206
 207    if (cppcast) {
 208      Preprocessor_define((DOH *) "SWIG_CPLUSPLUS_CAST", 0);
 209    }
 210
 211    Preprocessor_define("SWIGPERL 1", 0);
 212    // SWIGPERL5 is deprecated, and no longer documented.
 213    Preprocessor_define("SWIGPERL5 1", 0);
 214    SWIG_typemap_lang("perl5");
 215    SWIG_config_file("perl5.swg");
 216    allow_overloading();
 217  }
 218
 219  /* ------------------------------------------------------------
 220   * top()
 221   * ------------------------------------------------------------ */
 222
 223  virtual int top(Node *n) {
 224
 225    /* Initialize all of the output files */
 226    String *outfile = Getattr(n, "outfile");
 227
 228    f_begin = NewFile(outfile, "w", SWIG_output_files());
 229    if (!f_begin) {
 230      FileErrorDisplay(outfile);
 231      SWIG_exit(EXIT_FAILURE);
 232    }
 233    f_runtime = NewString("");
 234    f_init = NewString("");
 235    f_header = NewString("");
 236    f_wrappers = NewString("");
 237
 238    /* Register file targets with the SWIG file handler */
 239    Swig_register_filebyname("header", f_header);
 240    Swig_register_filebyname("wrapper", f_wrappers);
 241    Swig_register_filebyname("begin", f_begin);
 242    Swig_register_filebyname("runtime", f_runtime);
 243    Swig_register_filebyname("init", f_init);
 244
 245    classlist = NewList();
 246
 247    pm = NewString("");
 248    func_stubs = NewString("");
 249    var_stubs = NewString("");
 250    const_stubs = NewString("");
 251    exported = NewString("");
 252    magic = NewString("");
 253    pragma_include = NewString("");
 254    additional_perl_code = NewString("");
 255
 256    command_tab = NewString("static swig_command_info swig_commands[] = {\n");
 257    constant_tab = NewString("static swig_constant_info swig_constants[] = {\n");
 258    variable_tab = NewString("static swig_variable_info swig_variables[] = {\n");
 259
 260    Swig_banner(f_begin);
 261
 262    Printf(f_runtime, "\n");
 263    Printf(f_runtime, "#define SWIGPERL\n");
 264    Printf(f_runtime, "#define SWIG_CASTRANK_MODE\n");
 265    Printf(f_runtime, "\n");
 266
 267    // Is the imported module in another package?  (IOW, does it use the
 268    // %module(package="name") option and it's different than the package
 269    // of this module.)
 270    Node *mod = Getattr(n, "module");
 271    Node *options = Getattr(mod, "options");
 272    module = Copy(Getattr(n,"name"));
 273
 274    if (verbose > 0) {
 275      fprintf(stdout, "top: using module: %s\n", Char(module));
 276    }
 277
 278    dest_package = options ? Getattr(options, "package") : 0;
 279    if (dest_package) {
 280      namespace_module = Copy(dest_package);
 281      if (verbose > 0) {
 282	fprintf(stdout, "top: Found package: %s\n",Char(dest_package));
 283      }
 284    } else {
 285      namespace_module = Copy(module);
 286      if (verbose > 0) {
 287	fprintf(stdout, "top: No package found\n");
 288      }
 289    }
 290    String *underscore_module = Copy(module);
 291    Replaceall(underscore_module,":","_");
 292
 293    if (verbose > 0) {
 294      fprintf(stdout, "top: using namespace_module: %s\n", Char(namespace_module));
 295    }
 296
 297    /* If we're in blessed mode, change the package name to "packagec" */
 298
 299    if (blessed) {
 300      cmodule = NewStringf("%sc",namespace_module);
 301    } else {
 302      cmodule = NewString(namespace_module);
 303    }
 304
 305    /* Create a .pm file
 306     * Need to strip off any prefixes that might be found in
 307     * the module name */
 308
 309    if (no_pmfile) {
 310      f_pm = NewString(0);
 311    } else {
 312      if (!pmfile) {
 313	char *m = Char(module) + Len(module);
 314	while (m != Char(module)) {
 315	  if (*m == ':') {
 316	    m++;
 317	    break;
 318	  }
 319	  m--;
 320	}
 321	pmfile = NewStringf("%s.pm", m);
 322      }
 323      String *filen = NewStringf("%s%s", SWIG_output_directory(), pmfile);
 324      if ((f_pm = NewFile(filen, "w", SWIG_output_files())) == 0) {
 325	FileErrorDisplay(filen);
 326	SWIG_exit(EXIT_FAILURE);
 327      }
 328      Delete(filen);
 329      filen = NULL;
 330      Swig_register_filebyname("pm", f_pm);
 331      Swig_register_filebyname("perl", f_pm);
 332    }
 333    {
 334      String *boot_name = NewStringf("boot_%s", underscore_module);
 335      Printf(f_header,"#define SWIG_init    %s\n\n", boot_name);
 336      Printf(f_header,"#define SWIG_name   \"%s::%s\"\n", cmodule, boot_name);
 337      Printf(f_header,"#define SWIG_prefix \"%s::\"\n", cmodule);
 338      Delete(boot_name);
 339    }
 340
 341    Swig_banner_target_lang(f_pm, "#");
 342    Printf(f_pm, "\n");
 343
 344    Printf(f_pm, "package %s;\n", module);
 345
 346    /* 
 347     * If the package option has been given we are placing our
 348     *   symbols into some other packages namespace, so we do not
 349     *   mess with @ISA or require for that package
 350     */
 351    if (dest_package) {
 352      Printf(f_pm,"use base qw(DynaLoader);\n");
 353    } else {
 354      Printf(f_pm,"use base qw(Exporter);\n");
 355      if (!staticoption) {
 356	Printf(f_pm,"use base qw(DynaLoader);\n");
 357      }
 358    }
 359
 360    /* Start creating magic code */
 361
 362    Printv(magic,
 363           "#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n",
 364	   "#ifdef PERL_OBJECT\n",
 365	   "#define MAGIC_CLASS _wrap_", underscore_module, "_var::\n",
 366	   "class _wrap_", underscore_module, "_var : public CPerlObj {\n",
 367	   "public:\n",
 368	   "#else\n",
 369	   "#define MAGIC_CLASS\n",
 370	   "#endif\n",
 371	   "SWIGCLASS_STATIC int swig_magic_readonly(pTHX_ SV *SWIGUNUSEDPARM(sv), MAGIC *SWIGUNUSEDPARM(mg)) {\n",
 372	   tab4, "MAGIC_PPERL\n", tab4, "croak(\"Value is read-only.\");\n", tab4, "return 0;\n", "}\n", NIL);
 373
 374    Printf(f_wrappers, "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
 375
 376    /* emit wrappers */
 377    Language::top(n);
 378
 379    String *base = NewString("");
 380
 381    /* Dump out variable wrappers */
 382
 383    Printv(magic, "\n\n#ifdef PERL_OBJECT\n", "};\n", "#endif\n", NIL);
 384    Printv(magic, "\n#ifdef __cplusplus\n}\n#endif\n", NIL);
 385
 386    Printf(f_header, "%s\n", magic);
 387
 388    String *type_table = NewString("");
 389
 390    /* Patch the type table to reflect the names used by shadow classes */
 391    if (blessed) {
 392      Iterator cls;
 393      for (cls = First(classlist); cls.item; cls = Next(cls)) {
 394	String *pname = Getattr(cls.item, "perl5:proxy");
 395	if (pname) {
 396	  SwigType *type = Getattr(cls.item, "classtypeobj");
 397	  if (!type)
 398	    continue;		/* If unnamed class, no type will be found */
 399	  type = Copy(type);
 400
 401	  SwigType_add_pointer(type);
 402	  String *mangled = SwigType_manglestr(type);
 403	  SwigType_remember_mangleddata(mangled, NewStringf("\"%s\"", pname));
 404	  Delete(type);
 405	  Delete(mangled);
 406	}
 407      }
 408    }
 409    SwigType_emit_type_table(f_runtime, type_table);
 410
 411    Printf(f_wrappers, "%s", type_table);
 412    Delete(type_table);
 413
 414    Printf(constant_tab, "{0,0,0,0,0,0}\n};\n");
 415    Printv(f_wrappers, constant_tab, NIL);
 416
 417    Printf(f_wrappers, "#ifdef __cplusplus\n}\n#endif\n");
 418
 419    Printf(f_init, "\t ST(0) = &PL_sv_yes;\n");
 420    Printf(f_init, "\t XSRETURN(1);\n");
 421    Printf(f_init, "}\n");
 422
 423    /* Finish off tables */
 424    Printf(variable_tab, "{0,0,0,0}\n};\n");
 425    Printv(f_wrappers, variable_tab, NIL);
 426
 427    Printf(command_tab, "{0,0}\n};\n");
 428    Printv(f_wrappers, command_tab, NIL);
 429
 430
 431    Printf(f_pm, "package %s;\n", cmodule);
 432
 433    if (!staticoption) {
 434      Printf(f_pm,"bootstrap %s;\n", module);
 435    } else {
 436      Printf(f_pm,"package %s;\n", cmodule);
 437      Printf(f_pm,"boot_%s();\n", underscore_module);
 438    }
 439
 440    Printf(f_pm, "package %s;\n", module);
 441    /* 
 442     * If the package option has been given we are placing our
 443     *   symbols into some other packages namespace, so we do not
 444     *   mess with @EXPORT
 445     */
 446    if (!dest_package) {
 447      Printf(f_pm,"@EXPORT = qw(%s);\n", exported);
 448    }
 449
 450    Printf(f_pm, "%s", pragma_include);
 451
 452    if (blessed) {
 453
 454      /*
 455       * These methods will be duplicated if package 
 456       *   has been specified, so we do not output them
 457       */
 458      if (!dest_package) {
 459	Printv(base, "\n# ---------- BASE METHODS -------------\n\n", "package ", namespace_module, ";\n\n", NIL);
 460
 461	/* Write out the TIE method */
 462
 463	Printv(base, "sub TIEHASH {\n", tab4, "my ($classname,$obj) = @_;\n", tab4, "return bless $obj, $classname;\n", "}\n\n", NIL);
 464
 465	/* Output a CLEAR method.   This is just a place-holder, but by providing it we
 466	 * can make declarations such as
 467	 *     %$u = ( x => 2, y=>3, z =>4 );
 468	 *
 469	 * Where x,y,z are the members of some C/C++ object. */
 470
 471	Printf(base, "sub CLEAR { }\n\n");
 472
 473	/* Output default firstkey/nextkey methods */
 474
 475	Printf(base, "sub FIRSTKEY { }\n\n");
 476	Printf(base, "sub NEXTKEY { }\n\n");
 477
 478	/* Output a FETCH method.  This is actually common to all classes */
 479	Printv(base,
 480	       "sub FETCH {\n",
 481	       tab4, "my ($self,$field) = @_;\n", tab4, "my $member_func = \"swig_${field}_get\";\n", tab4, "$self->$member_func();\n", "}\n\n", NIL);
 482
 483	/* Output a STORE method.   This is also common to all classes (might move to base class) */
 484
 485	Printv(base,
 486	       "sub STORE {\n",
 487	       tab4, "my ($self,$field,$newval) = @_;\n",
 488	       tab4, "my $member_func = \"swig_${field}_set\";\n", tab4, "$self->$member_func($newval);\n", "}\n\n", NIL);
 489
 490	/* Output a 'this' method */
 491
 492	Printv(base, "sub this {\n", tab4, "my $ptr = shift;\n", tab4, "return tied(%$ptr);\n", "}\n\n", NIL);
 493
 494	Printf(f_pm, "%s", base);
 495      }
 496
 497      /* Emit function stubs for stand-alone functions */
 498      Printf(f_pm, "\n# ------- FUNCTION WRAPPERS --------\n\n");
 499      Printf(f_pm, "package %s;\n\n", namespace_module);
 500      Printf(f_pm, "%s", func_stubs);
 501
 502      /* Emit package code for different classes */
 503      Printf(f_pm, "%s", pm);
 504
 505      if (num_consts > 0) {
 506	/* Emit constant stubs */
 507	Printf(f_pm, "\n# ------- CONSTANT STUBS -------\n\n");
 508	Printf(f_pm, "package %s;\n\n", namespace_module);
 509	Printf(f_pm, "%s", const_stubs);
 510      }
 511
 512      /* Emit variable stubs */
 513
 514      Printf(f_pm, "\n# ------- VARIABLE STUBS --------\n\n");
 515      Printf(f_pm, "package %s;\n\n", namespace_module);
 516      Printf(f_pm, "%s", var_stubs);
 517    }
 518
 519    /* Add additional Perl code at the end */
 520    Printf(f_pm, "%s", additional_perl_code);
 521
 522    Printf(f_pm, "1;\n");
 523    Close(f_pm);
 524    Delete(f_pm);
 525    Delete(base);
 526    Delete(dest_package);
 527    Delete(underscore_module);
 528
 529    /* Close all of the files */
 530    Dump(f_runtime, f_begin);
 531    Dump(f_header, f_begin);
 532    Dump(f_wrappers, f_begin);
 533    Wrapper_pretty_print(f_init, f_begin);
 534    Delete(f_header);
 535    Delete(f_wrappers);
 536    Delete(f_init);
 537    Close(f_begin);
 538    Delete(f_runtime);
 539    Delete(f_begin);
 540    return SWIG_OK;
 541  }
 542
 543  /* ------------------------------------------------------------
 544   * importDirective(Node *n)
 545   * ------------------------------------------------------------ */
 546
 547  virtual int importDirective(Node *n) {
 548    if (blessed) {
 549      String *modname = Getattr(n, "module");
 550      if (modname) {
 551	Printf(f_pm, "require %s;\n", modname);
 552      }
 553    }
 554    return Language::importDirective(n);
 555  }
 556
 557  /* ------------------------------------------------------------
 558   * functionWrapper()
 559   * ------------------------------------------------------------ */
 560
 561  virtual int functionWrapper(Node *n) {
 562    String *name = Getattr(n, "name");
 563    String *iname = Getattr(n, "sym:name");
 564    SwigType *d = Getattr(n, "type");
 565    ParmList *l = Getattr(n, "parms");
 566    String *overname = 0;
 567
 568    Parm *p;
 569    int i;
 570    Wrapper *f;
 571    char source[256], temp[256];
 572    String *tm;
 573    String *cleanup, *outarg;
 574    int num_saved = 0;
 575    int num_arguments, num_required;
 576    int varargs = 0;
 577
 578    if (Getattr(n, "sym:overloaded")) {
 579      overname = Getattr(n, "sym:overname");
 580    } else {
 581      if (!addSymbol(iname, n))
 582	return SWIG_ERROR;
 583    }
 584
 585    f = NewWrapper();
 586    cleanup = NewString("");
 587    outarg = NewString("");
 588
 589    String *wname = Swig_name_wrapper(iname);
 590    if (overname) {
 591      Append(wname, overname);
 592    }
 593    Setattr(n, "wrap:name", wname);
 594    Printv(f->def, "XS(", wname, ") {\n", "{\n",	/* scope to destroy C++ objects before croaking */
 595	   NIL);
 596
 597    emit_parameter_variables(l, f);
 598    emit_attach_parmmaps(l, f);
 599    Setattr(n, "wrap:parms", l);
 600
 601    num_arguments = emit_num_arguments(l);
 602    num_required = emit_num_required(l);
 603    varargs = emit_isvarargs(l);
 604
 605    Wrapper_add_local(f, "argvi", "int argvi = 0");
 606
 607    /* Check the number of arguments */
 608    if (!varargs) {
 609      Printf(f->code, "    if ((items < %d) || (items > %d)) {\n", num_required, num_arguments);
 610    } else {
 611      Printf(f->code, "    if (items < %d) {\n", num_required);
 612    }
 613    Printf(f->code, "        SWIG_croak(\"Usage: %s\");\n", usage_func(Char(iname), d, l));
 614    Printf(f->code, "}\n");
 615
 616    /* Write code to extract parameters. */
 617    i = 0;
 618    for (i = 0, p = l; i < num_arguments; i++) {
 619
 620      /* Skip ignored arguments */
 621
 622      while (checkAttribute(p, "tmap:in:numinputs", "0")) {
 623	p = Getattr(p, "tmap:in:next");
 624      }
 625
 626      SwigType *pt = Getattr(p, "type");
 627
 628      /* Produce string representation of source and target arguments */
 629      sprintf(source, "ST(%d)", i);
 630      String *target = Getattr(p, "lname");
 631
 632      if (i >= num_required) {
 633	Printf(f->code, "    if (items > %d) {\n", i);
 634      }
 635      if ((tm = Getattr(p, "tmap:in"))) {
 636	Replaceall(tm, "$target", target);
 637	Replaceall(tm, "$source", source);
 638	Replaceall(tm, "$input", source);
 639	Setattr(p, "emit:input", source);	/* Save input location */
 640
 641	if (Getattr(p, "wrap:disown") || (Getattr(p, "tmap:in:disown"))) {
 642	  Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN");
 643	} else {
 644	  Replaceall(tm, "$disown", "0");
 645	}
 646
 647	Printf(f->code, "%s\n", tm);
 648	p = Getattr(p, "tmap:in:next");
 649      } else {
 650	Swig_warning(WARN_TYPEMAP_IN_UNDEF, input_file, line_number, "Unable to use type %s as a function argument.\n", SwigType_str(pt, 0));
 651	p = nextSibling(p);
 652      }
 653      if (i >= num_required) {
 654	Printf(f->code, "    }\n");
 655      }
 656    }
 657
 658    if (varargs) {
 659      if (p && (tm = Getattr(p, "tmap:in"))) {
 660	sprintf(source, "ST(%d)", i);
 661	Replaceall(tm, "$input", source);
 662	Setattr(p, "emit:input", source);
 663	Printf(f->code, "if (items >= %d) {\n", i);
 664	Printv(f->code, tm, "\n", NIL);
 665	Printf(f->code, "}\n");
 666      }
 667    }
 668
 669    /* Insert constraint checking code */
 670    for (p = l; p;) {
 671      if ((tm = Getattr(p, "tmap:check"))) {
 672	Replaceall(tm, "$target", Getattr(p, "lname"));
 673	Printv(f->code, tm, "\n", NIL);
 674	p = Getattr(p, "tmap:check:next");
 675      } else {
 676	p = nextSibling(p);
 677      }
 678    }
 679
 680    /* Insert cleanup code */
 681    for (i = 0, p = l; p; i++) {
 682      if ((tm = Getattr(p, "tmap:freearg"))) {
 683	Replaceall(tm, "$source", Getattr(p, "lname"));
 684	Replaceall(tm, "$arg", Getattr(p, "emit:input"));
 685	Replaceall(tm, "$input", Getattr(p, "emit:input"));
 686	Printv(cleanup, tm, "\n", NIL);
 687	p = Getattr(p, "tmap:freearg:next");
 688      } else {
 689	p = nextSibling(p);
 690      }
 691    }
 692
 693    /* Insert argument output code */
 694    num_saved = 0;
 695    for (i = 0, p = l; p; i++) {
 696      if ((tm = Getattr(p, "tmap:argout"))) {
 697	SwigType *t = Getattr(p, "type");
 698	Replaceall(tm, "$source", Getattr(p, "lname"));
 699	Replaceall(tm, "$target", "ST(argvi)");
 700	Replaceall(tm, "$result", "ST(argvi)");
 701	if (is_shadow(t)) {
 702	  Replaceall(tm, "$shadow", "SWIG_SHADOW");
 703	} else {
 704	  Replaceall(tm, "$shadow", "0");
 705	}
 706
 707	String *in = Getattr(p, "emit:input");
 708	if (in) {
 709	  sprintf(temp, "_saved[%d]", num_saved);
 710	  Replaceall(tm, "$arg", temp);
 711	  Replaceall(tm, "$input", temp);
 712	  Printf(f->code, "_saved[%d] = %s;\n", num_saved, in);
 713	  num_saved++;
 714	}
 715	Printv(outarg, tm, "\n", NIL);
 716	p = Getattr(p, "tmap:argout:next");
 717      } else {
 718	p = nextSibling(p);
 719      }
 720    }
 721
 722    /* If there were any saved arguments, emit a local variable for them */
 723    if (num_saved) {
 724      sprintf(temp, "_saved[%d]", num_saved);
 725      Wrapper_add_localv(f, "_saved", "SV *", temp, NIL);
 726    }
 727
 728    /* Now write code to make the function call */
 729
 730    Swig_director_emit_dynamic_cast(n, f);
 731    String *actioncode = emit_action(n);
 732
 733    if ((tm = Swig_typemap_lookup_out("out", n, Swig_cresult_name(), f, actioncode))) {
 734      SwigType *t = Getattr(n, "type");
 735      Replaceall(tm, "$source", Swig_cresult_name());
 736      Replaceall(tm, "$target", "ST(argvi)");
 737      Replaceall(tm, "$result", "ST(argvi)");
 738      if (is_shadow(t)) {
 739	Replaceall(tm, "$shadow", "SWIG_SHADOW");
 740      } else {
 741	Replaceall(tm, "$shadow", "0");
 742      }
 743      if (GetFlag(n, "feature:new")) {
 744	Replaceall(tm, "$owner", "SWIG_OWNER");
 745      } else {
 746	Replaceall(tm, "$owner", "0");
 747      }
 748      Printf(f->code, "%s\n", tm);
 749    } else {
 750      Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number, "Unable to use return type %s in function %s.\n", SwigType_str(d, 0), name);
 751    }
 752    emit_return_variable(n, d, f);
 753
 754    /* If there were any output args, take care of them. */
 755
 756    Printv(f->code, outarg, NIL);
 757
 758    /* If there was any cleanup, do that. */
 759
 760    Printv(f->code, cleanup, NIL);
 761
 762    if (GetFlag(n, "feature:new")) {
 763      if ((tm = Swig_typemap_lookup("newfree", n, Swig_cresult_name(), 0))) {
 764	Replaceall(tm, "$source", Swig_cresult_name());
 765	Printf(f->code, "%s\n", tm);
 766      }
 767    }
 768
 769    if ((tm = Swig_typemap_lookup("ret", n, Swig_cresult_name(), 0))) {
 770      Replaceall(tm, "$source", Swig_cresult_name());
 771      Printf(f->code, "%s\n", tm);
 772    }
 773
 774    Printv(f->code, "XSRETURN(argvi);\n", "fail:\n", cleanup, "SWIG_croak_null();\n" "}\n" "}\n", NIL);
 775
 776    /* Add the dXSARGS last */
 777
 778    Wrapper_add_local(f, "dXSARGS", "dXSARGS");
 779
 780    /* Substitute the cleanup code */
 781    Replaceall(f->code, "$cleanup", cleanup);
 782    Replaceall(f->code, "$symname", iname);
 783
 784    /* Dump the wrapper function */
 785
 786    Wrapper_print(f, f_wrappers);
 787
 788    /* Now register the function */
 789
 790    if (!Getattr(n, "sym:overloaded")) {
 791      Printf(command_tab, "{\"%s::%s\", %s},\n", cmodule, iname, wname);
 792    } else if (!Getattr(n, "sym:nextSibling")) {
 793      /* Generate overloaded dispatch function */
 794      int maxargs;
 795      String *dispatch = Swig_overload_dispatch_cast(n, "PUSHMARK(MARK); SWIG_CALLXS(%s); return;", &maxargs);
 796
 797      /* Generate a dispatch wrapper for all overloaded functions */
 798
 799      Wrapper *df = NewWrapper();
 800      String *dname = Swig_name_wrapper(iname);
 801
 802      Printv(df->def, "XS(", dname, ") {\n", NIL);
 803
 804      Wrapper_add_local(df, "dXSARGS", "dXSARGS");
 805      Printv(df->code, dispatch, "\n", NIL);
 806      Printf(df->code, "croak(\"No matching function for overloaded '%s'\");\n", iname);
 807      Printf(df->code, "XSRETURN(0);\n");
 808      Printv(df->code, "}\n", NIL);
 809      Wrapper_print(df, f_wrappers);
 810      Printf(command_tab, "{\"%s::%s\", %s},\n", cmodule, iname, dname);
 811      DelWrapper(df);
 812      Delete(dispatch);
 813      Delete(dname);
 814    }
 815    if (!Getattr(n, "sym:nextSibling")) {
 816      if (export_all) {
 817	Printf(exported, "%s ", iname);
 818      }
 819
 820      /* --------------------------------------------------------------------
 821       * Create a stub for this function, provided it's not a member function
 822       * -------------------------------------------------------------------- */
 823
 824      if ((blessed) && (!member_func)) {
 825	Printv(func_stubs, "*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
 826      }
 827
 828    }
 829    Delete(cleanup);
 830    Delete(outarg);
 831    DelWrapper(f);
 832    return SWIG_OK;
 833  }
 834
 835  /* ------------------------------------------------------------
 836   * variableWrapper()
 837   * ------------------------------------------------------------ */
 838  virtual int variableWrapper(Node *n) {
 839    String *name = Getattr(n, "name");
 840    String *iname = Getattr(n, "sym:name");
 841    SwigType *t = Getattr(n, "type");
 842    Wrapper *getf, *setf;
 843    String *tm;
 844    String *getname = Swig_name_get(NSPACE_TODO, iname);
 845    String *setname = Swig_name_set(NSPACE_TODO, iname);
 846
 847    String *get_name = Swig_name_wrapper(getname);
 848    String *set_name = Swig_name_wrapper(setname);
 849
 850    if (!addSymbol(iname, n))
 851      return SWIG_ERROR;
 852
 853    getf = NewWrapper();
 854    setf = NewWrapper();
 855
 856    /* Create a Perl function for setting the variable value */
 857
 858    if (!GetFlag(n, "feature:immutable")) {
 859      Setattr(n, "wrap:name", set_name);
 860      Printf(setf->def, "SWIGCLASS_STATIC int %s(pTHX_ SV* sv, MAGIC * SWIGUNUSEDPARM(mg)) {\n", set_name);
 861      Printv(setf->code, tab4, "MAGIC_PPERL\n", NIL);
 862
 863      /* Check for a few typemaps */
 864      tm = Swig_typemap_lookup("varin", n, name, 0);
 865      if (tm) {
 866	Replaceall(tm, "$source", "sv");
 867	Replaceall(tm, "$target", name);
 868	Replaceall(tm, "$input", "sv");
 869	/* Printf(setf->code,"%s\n", tm); */
 870	emit_action_code(n, setf->code, tm);
 871      } else {
 872	Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number, "Unable to set variable of type %s.\n", SwigType_str(t, 0));
 873	return SWIG_NOWRAP;
 874      }
 875      Printf(setf->code, "fail:\n");
 876      Printf(setf->code, "    return 1;\n}\n");
 877      Replaceall(setf->code, "$symname", iname);
 878      Wrapper_print(setf, magic);
 879    }
 880
 881    /* Now write a function to evaluate the variable */
 882    Setattr(n, "wrap:name", get_name);
 883    int addfail = 0;
 884    Printf(getf->def, "SWIGCLASS_STATIC int %s(pTHX_ SV *sv, MAGIC *SWIGUNUSEDPARM(mg)) {\n", get_name);
 885    Printv(getf->code, tab4, "MAGIC_PPERL\n", NIL);
 886
 887    if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
 888      Replaceall(tm, "$target", "sv");
 889      Replaceall(tm, "$result", "sv");
 890      Replaceall(tm, "$source", name);
 891      if (is_shadow(t)) {
 892	Replaceall(tm, "$shadow", "SWIG_SHADOW");
 893      } else {
 894	Replaceall(tm, "$shadow", "0");
 895      }
 896      /* Printf(getf->code,"%s\n", tm); */
 897      addfail = emit_action_code(n, getf->code, tm);
 898    } else {
 899      Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number, "Unable to read variable of type %s\n", SwigType_str(t, 0));
 900      DelWrapper(setf);
 901      DelWrapper(getf);
 902      return SWIG_NOWRAP;
 903    }
 904    Printf(getf->code, "    return 1;\n");
 905    if (addfail) {
 906      Append(getf->code, "fail:\n");
 907      Append(getf->code, "  return 0;\n");
 908    }
 909    Append(getf->code, "}\n");
 910
 911
 912    Replaceall(getf->code, "$symname", iname);
 913    Wrapper_print(getf, magic);
 914
 915    String *tt = Getattr(n, "tmap:varout:type");
 916    if (tt) {
 917      String *tm = NewStringf("&SWIGTYPE%s", SwigType_manglestr(t));
 918      if (Replaceall(tt, "$1_descriptor", tm)) {
 919	SwigType_remember(t);
 920      }
 921      Delete(tm);
 922      SwigType *st = Copy(t);
 923      SwigType_add_pointer(st);
 924      tm = NewStringf("&SWIGTYPE%s", SwigType_manglestr(st));
 925      if (Replaceall(tt, "$&1_descriptor", tm)) {
 926	SwigType_remember(st);
 927      }
 928      Delete(tm);
 929      Delete(st);
 930    } else {
 931      tt = (String *) "0";
 932    }
 933    /* Now add symbol to the PERL interpreter */
 934    if (GetFlag(n, "feature:immutable")) {
 935      Printv(variable_tab, tab4, "{ \"", cmodule, "::", iname, "\", MAGIC_CLASS swig_magic_readonly, MAGIC_CLASS ", get_name, ",", tt, " },\n", NIL);
 936
 937    } else {
 938      Printv(variable_tab, tab4, "{ \"", cmodule, "::", iname, "\", MAGIC_CLASS ", set_name, ", MAGIC_CLASS ", get_name, ",", tt, " },\n", NIL);
 939    }
 940
 941    /* If we're blessed, try to figure out what to do with the variable
 942       1.  If it's a Perl object of some sort, create a tied-hash
 943       around it.
 944       2.  Otherwise, just hack Perl's symbol table */
 945
 946    if (blessed) {
 947      if (is_shadow(t)) {
 948	Printv(var_stubs,
 949	       "\nmy %__", iname, "_hash;\n",
 950	       "tie %__", iname, "_hash,\"", is_shadow(t), "\", $",
 951	       cmodule, "::", iname, ";\n", "$", iname, "= \\%__", iname, "_hash;\n", "bless $", iname, ", ", is_shadow(t), ";\n", NIL);
 952      } else {
 953	Printv(var_stubs, "*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
 954      }
 955    }
 956    if (export_all)
 957      Printf(exported, "$%s ", iname);
 958
 959    DelWrapper(setf);
 960    DelWrapper(getf);
 961    Delete(getname);
 962    Delete(setname);
 963    Delete(set_name);
 964    Delete(get_name);
 965    return SWIG_OK;
 966  }
 967
 968  /* ------------------------------------------------------------
 969   * constantWrapper()
 970   * ------------------------------------------------------------ */
 971
 972  virtual int constantWrapper(Node *n) {
 973    String *name = Getattr(n, "name");
 974    String *iname = Getattr(n, "sym:name");
 975    SwigType *type = Getattr(n, "type");
 976    String *rawval = Getattr(n, "rawval");
 977    String *value = rawval ? rawval : Getattr(n, "value");
 978    String *tm;
 979
 980    if (!addSymbol(iname, n))
 981      return SWIG_ERROR;
 982
 983    /* Special hook for member pointer */
 984    if (SwigType_type(type) == T_MPOINTER) {
 985      String *wname = Swig_name_wrapper(iname);
 986      Printf(f_wrappers, "static %s = %s;\n", SwigType_str(type, wname), value);
 987      value = Char(wname);
 988    }
 989
 990    if ((tm = Swig_typemap_lookup("consttab", n, name, 0))) {
 991      Replaceall(tm, "$source", value);
 992      Replaceall(tm, "$target", name);
 993      Replaceall(tm, "$value", value);
 994      if (is_shadow(type)) {
 995	Replaceall(tm, "$shadow", "SWIG_SHADOW");
 996      } else {
 997	Replaceall(tm, "$shadow", "0");
 998      }
 999      Printf(constant_tab, "%s,\n", tm);
1000    } else if ((tm = Swig_typemap_lookup("constcode", n, name, 0))) {
1001      Replaceall(tm, "$source", value);
1002      Replaceall(tm, "$target", name);
1003      Replaceall(tm, "$value", value);
1004      if (is_shadow(type)) {
1005	Replaceall(tm, "$shadow", "SWIG_SHADOW");
1006      } else {
1007	Replaceall(tm, "$shadow", "0");
1008      }
1009      Printf(f_init, "%s\n", tm);
1010    } else {
1011      Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number, "Unsupported constant value.\n");
1012      return SWIG_NOWRAP;
1013    }
1014
1015    if (blessed) {
1016      if (is_shadow(type)) {
1017	Printv(var_stubs,
1018	       "\nmy %__", iname, "_hash;\n",
1019	       "tie %__", iname, "_hash,\"", is_shadow(type), "\", $",
1020	       cmodule, "::", iname, ";\n", "$", iname, "= \\%__", iname, "_hash;\n", "bless $", iname, ", ", is_shadow(type), ";\n", NIL);
1021      } else if (do_constants) {
1022	Printv(const_stubs, "sub ", name, " () { $", cmodule, "::", name, " }\n", NIL);
1023	num_consts++;
1024      } else {
1025	Printv(var_stubs, "*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
1026      }
1027    }
1028    if (export_all) {
1029      if (do_constants && !is_shadow(type)) {
1030	Printf(exported, "%s ", name);
1031      } else {
1032	Printf(exported, "$%s ", iname);
1033      }
1034    }
1035    return SWIG_OK;
1036  }
1037
1038  /* ------------------------------------------------------------
1039   * usage_func()
1040   * ------------------------------------------------------------ */
1041  char *usage_func(char *iname, SwigType *, ParmList *l) {
1042    static String *temp = 0;
1043    Parm *p;
1044    int i;
1045
1046    if (!temp)
1047      temp = NewString("");
1048    Clear(temp);
1049    Printf(temp, "%s(", iname);
1050
1051    /* Now go through and print parameters */
1052    p = l;
1053    i = 0;
1054    while (p != 0) {
1055      SwigType *pt = Getattr(p, "type");
1056      String *pn = Getattr(p, "name");
1057      if (!checkAttribute(p,"tmap:in:numinputs","0")) {
1058	/* If parameter has been named, use that.   Otherwise, just print a type  */
1059	if (SwigType_type(pt) != T_VOID) {
1060	  if (Len(pn) > 0) {
1061	    Printf(temp, "%s", pn);
1062	  } else {
1063	    Printf(temp, "%s", SwigType_str(pt, 0));
1064	  }
1065	}
1066	i++;
1067	p = nextSibling(p);
1068	if (p)
1069	  if (!checkAttribute(p,"tmap:in:numinputs","0"))
1070	    Putc(',', temp);
1071      } else {
1072	p = nextSibling(p);
1073	if (p)
1074	  if ((i > 0) && (!checkAttribute(p,"tmap:in:numinputs","0")))
1075	    Putc(',', temp);
1076      }
1077    }
1078    Printf(temp, ");");
1079    return Char(temp);
1080  }
1081
1082  /* ------------------------------------------------------------
1083   * nativeWrapper()
1084   * ------------------------------------------------------------ */
1085
1086  virtual int nativeWrapper(Node *n) {
1087    String *name = Getattr(n, "sym:name");
1088    String *funcname = Getattr(n, "wrap:name");
1089
1090    if (!addSymbol(funcname, n))
1091      return SWIG_ERROR;
1092
1093    Printf(command_tab, "{\"%s::%s\", %s},\n", cmodule, name, funcname);
1094    if (export_all)
1095      Printf(exported, "%s ", name);
1096    if (blessed) {
1097      Printv(func_stubs, "*", name, " = *", cmodule, "::", name, ";\n", NIL);
1098    }
1099    return SWIG_OK;
1100  }
1101
1102/* ----------------------------------------------------------------------------
1103 *                      OBJECT-ORIENTED FEATURES
1104 *
1105 * These extensions provide a more object-oriented interface to C++
1106 * classes and structures.    The code here is based on extensions
1107 * provided by David Fletcher and Gary Holt.
1108 *
1109 * I have generalized these extensions to make them more general purpose
1110 * and to resolve object-ownership problems.
1111 *
1112 * The approach here is very similar to the Python module :
1113 *       1.   All of the original methods are placed into a single
1114 *            package like before except that a 'c' is appended to the
1115 *            package name.
1116 *
1117 *       2.   All methods and function calls are wrapped with a new
1118 *            perl function.   While possibly inefficient this allows
1119 *            us to catch complex function arguments (which are hard to
1120 *            track otherwise).
1121 *
1122 *       3.   Classes are represented as tied-hashes in a manner similar
1123 *            to Gary Holt's extension.   This allows us to access
1124 *            member data.
1125 *
1126 *       4.   Stand-alone (global) C functions are modified to take
1127 *            tied hashes as arguments for complex datatypes (if
1128 *            appropriate).
1129 *
1130 *       5.   Global variables involving a class/struct is encapsulated
1131 *            in a tied hash.
1132 *
1133 * ------------------------------------------------------------------------- */
1134
1135
1136  void setclassname(Node *n) {
1137    String *symname = Getattr(n, "sym:name");
1138    String *fullname;
1139    String *actualpackage;
1140    Node *clsmodule = Getattr(n, "module");
1141
1142    if (!clsmodule) {
1143      /* imported module does not define a module name.   Oh well */
1144      return;
1145    }
1146
1147    /* Do some work on the class name */
1148    if (verbose > 0) {
1149      String *modulename = Getattr(clsmodule, "name");
1150      fprintf(stdout, "setclassname: Found sym:name: %s\n", Char(symname));
1151      fprintf(stdout, "setclassname: Found module: %s\n", Char(modulename));
1152      fprintf(stdout, "setclassname: No package found\n");
1153    }
1154
1155    if (dest_package) {
1156      fullname = NewStringf("%s::%s", namespace_module, symname);
1157    } else {
1158      actualpackage = Getattr(clsmodule,"name");
1159
1160      if (verbose > 0) {
1161	fprintf(stdout, "setclassname: Found actualpackage: %s\n", Char(actualpackage));
1162      }
1163      if ((!compat) && (!Strchr(symname,':'))) {
1164	fullname = NewStringf("%s::%s",actualpackage,symname);
1165      } else {
1166	fullname = NewString(symname);
1167      }
1168    }
1169    if (verbose > 0) {
1170      fprintf(stdout, "setclassname: setting proxy: %s\n", Char(fullname));
1171    }
1172    Setattr(n, "perl5:proxy", fullname);
1173  }
1174
1175  /* ------------------------------------------------------------
1176   * classDeclaration()
1177   * ------------------------------------------------------------ */
1178  virtual int classDeclaration(Node *n) {
1179    /* Do some work on the class name */
1180    if (!Getattr(n, "feature:onlychildren")) {
1181      if (blessed) {
1182	setclassname(n);
1183	Append(classlist, n);
1184      }
1185    }
1186
1187    return Language::classDeclaration(n);
1188  }
1189
1190  /* ------------------------------------------------------------
1191   * classHandler()
1192   * ------------------------------------------------------------ */
1193
1194  virtual int classHandler(Node *n) {
1195
1196    if (blessed) {
1197      have_constructor = 0;
1198      have_operators = 0;
1199      have_destructor = 0;
1200      have_data_members = 0;
1201      operators = NewHash();
1202
1203      class_name = Getattr(n, "sym:name");
1204
1205      if (!addSymbol(class_name, n))
1206	return SWIG_ERROR;
1207
1208      /* Use the fully qualified name of the Perl class */
1209      if (!compat) {
1210	fullclassname = NewStringf("%s::%s", namespace_module, class_name);
1211      } else {
1212	fullclassname = NewString(class_name);
1213      }
1214      real_classname = Getattr(n, "name");
1215      pcode = NewString("");
1216      // blessedmembers = NewString("");
1217    }
1218
1219    /* Emit all of the members */
1220    Language::classHandler(n);
1221
1222
1223    /* Finish the rest of the class */
1224    if (blessed) {
1225      /* Generate a client-data entry */
1226      SwigType *ct = NewStringf("p.%s", real_classname);
1227      Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", SwigType_manglestr(ct), ", (void*) \"", fullclassname, "\");\n", NIL);
1228      SwigType_remember(ct);
1229      Delete(ct);
1230
1231      Printv(pm, "\n############# Class : ", fullclassname, " ##############\n", "\npackage ", fullclassname, ";\n", NIL);
1232
1233      if (have_operators) {
1234	Printf(pm, "use overload\n");
1235	Iterator ki;
1236	for (ki = First(operators); ki.key; ki = Next(ki)) {
1237	  char *name = Char(ki.key);
1238	  //        fprintf(stderr,"found name: <%s>\n", name);
1239	  if (strstr(name, "__eq__")) {
1240	    Printv(pm, tab4, "\"==\" => sub { $_[0]->__eq__($_[1])},\n",NIL);
1241	  } else if (strstr(name, "__ne__")) {
1242	    Printv(pm, tab4, "\"!=\" => sub { $_[0]->__ne__($_[1])},\n",NIL);
1243	    // there are no tests for this in operator_overload_runme.pl
1244	    // it is likely to be broken
1245	    //	  } else if (strstr(name, "__assign__")) {
1246	    //	    Printv(pm, tab4, "\"=\" => sub { $_[0]->__assign__($_[1])},\n",NIL);
1247	  } else if (strstr(name, "__str__")) {
1248	    Printv(pm, tab4, "'\"\"' => sub { $_[0]->__str__()},\n",NIL);
1249	  } else if (strstr(name, "__plusplus__")) {
1250	    Printv(pm, tab4, "\"++\" => sub { $_[0]->__plusplus__()},\n",NIL);
1251	  } else if (strstr(name, "__minmin__")) {
1252	    Printv(pm, tab4, "\"--\" => sub { $_[0]->__minmin__()},\n",NIL);
1253	  } else if (strstr(name, "__add__")) {
1254	    Printv(pm, tab4, "\"+\" => sub { $_[0]->__add__($_[1])},\n",NIL);
1255	  } else if (strstr(name, "__sub__")) {
1256	    Printv(pm, tab4, "\"-\" => sub {  if( not $_[2] ) { $_[0]->__sub__($_[1]) }\n",NIL);
1257	    Printv(pm, tab8, "elsif( $_[0]->can('__rsub__') ) { $_[0]->__rsub__($_[1]) }\n",NIL);
1258	    Printv(pm, tab8, "else { die(\"reverse subtraction not supported\") }\n",NIL);
1259	    Printv(pm, tab8, "},\n",NIL);
1260	  } else if (strstr(name, "__mul__")) {
1261	    Printv(pm, tab4, "\"*\" => sub { $_[0]->__mul__($_[1])},\n",NIL);
1262	  } else if (strstr(name, "__div__")) {
1263	    Printv(pm, tab4, "\"/\" => sub { $_[0]->__div__($_[1])},\n",NIL);
1264	  } else if (strstr(name, "__mod__")) {
1265	    Printv(pm, tab4, "\"%\" => sub { $_[0]->__mod__($_[1])},\n",NIL);
1266	    // there are no tests for this in operator_overload_runme.pl
1267	    // it is likely to be broken
1268	    //	  } else if (strstr(name, "__and__")) {
1269	    //	    Printv(pm, tab4, "\"&\" => sub { $_[0]->__and__($_[1])},\n",NIL);
1270
1271	    // there are no tests for this in operator_overload_runme.pl
1272	    // it is likely to be broken
1273	    //	  } else if (strstr(name, "__or__")) {
1274	    //	    Printv(pm, tab4, "\"|\" => sub { $_[0]->__or__($_[1])},\n",NIL);
1275	  } else if (strstr(name, "__gt__")) {
1276	    Printv(pm, tab4, "\">\" => sub { $_[0]->__gt__($_[1])},\n",NIL);
1277          } else if (strstr(name, "__ge__")) {
1278            Printv(pm, tab4, "\">=\" => sub { $_[0]->__ge__($_[1])},\n",NIL);
1279	  } else if (strstr(name, "__not__")) {
1280	    Printv(pm, tab4, "\"!\" => sub { $_[0]->__not__()},\n",NIL);
1281	  } else if (strstr(name, "__lt__")) {
1282	    Printv(pm, tab4, "\"<\" => sub { $_[0]->__lt__($_[1])},\n",NIL);
1283          } else if (strstr(name, "__le__")) {
1284            Printv(pm, tab4, "\"<=\" => sub { $_[0]->__le__($_[1])},\n",NIL);
1285	  } else if (strstr(name, "__pluseq__")) {
1286	    Printv(pm, tab4, "\"+=\" => sub { $_[0]->__pluseq__($_[1])},\n",NIL);
1287	  } else if (strstr(name, "__mineq__")) {
1288	    Printv(pm, tab4, "\"-=\" => sub { $_[0]->__mineq__($_[1])},\n",NIL);
1289	  } else if (strstr(name, "__neg__")) {
1290	    Printv(pm, tab4, "\"neg\" => sub { $_[0]->__neg__()},\n",NIL);
1291	  } else {
1292	    fprintf(stderr,"Unknown operator: %s\n", name);
1293	  }
1294	}
1295	Printv(pm, tab4,
1296               "\"=\" => sub { my $class = ref($_[0]); $class->new($_[0]) },\n", NIL);
1297	Printv(pm, tab4, "\"fallback\" => 1;\n", NIL);
1298      }
1299      // make use strict happy
1300      Printv(pm, "use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);\n", NIL);
1301
1302      /* If we are inheriting from a base class, set that up */
1303
1304      Printv(pm, "@ISA = qw(", NIL);
1305
1306      /* Handle inheritance */
1307      List *baselist = Getattr(n, "bases");
1308      if (baselist && Len(baselist)) {
1309	Iterator b;
1310	b = First(baselist);
1311	while (b.item) {
1312	  String *bname = Getattr(b.item, "perl5:proxy");
1313	  if (!bname) {
1314	    b = Next(b);
1315	    continue;
1316	  }
1317	  Printv(pm, " ", bname, NIL);
1318	  b = Next(b);
1319	}
1320      }
1321
1322      /* Module comes last */
1323      if (!compat || Cmp(namespace_module, fullclassname)) {
1324	Printv(pm, " ", namespace_module, NIL);
1325      }
1326
1327      Printf(pm, " );\n");
1328
1329      /* Dump out a hash table containing the pointers that we own */
1330      Printf(pm, "%%OWNER = ();\n");
1331      if (have_data_members || have_destructor)
1332	Printf(pm, "%%ITERATORS = ();\n");
1333
1334      /* Dump out the package methods */
1335
1336      Printv(pm, pcode, NIL);
1337      Delete(pcode);
1338
1339      /* Output methods for managing ownership */
1340
1341      Printv(pm,
1342	     "sub DISOWN {\n",
1343	     tab4, "my $self = shift;\n",
1344	     tab4, "my $ptr = tied(%$self);\n",
1345	     tab4, "delete $OWNER{$ptr};\n",
1346	     "}\n\n", "sub ACQUIRE {\n", tab4, "my $self = shift;\n", tab4, "my $ptr = tied(%$self);\n", tab4, "$OWNER{$ptr} = 1;\n", "}\n\n", NIL);
1347
1348      /* Only output the following methods if a class has member data */
1349
1350      Delete(operators);
1351      operators = 0;
1352    }
1353    return SWIG_OK;
1354  }
1355
1356  /* ------------------------------------------------------------
1357   * memberfunctionHandler()
1358   * ------------------------------------------------------------ */
1359
1360  virtual int memberfunctionHandler(Node *n) {
1361    String *symname = Getattr(n, "sym:name");
1362
1363    member_func = 1;
1364    Language::memberfunctionHandler(n);
1365    member_func = 0;
1366
1367    if ((blessed) && (!Getattr(n, "sym:nextSibling"))) {
1368
1369      if (Strstr(symname, "__eq__")) {
1370	DohSetInt(operators, "__eq__", 1);
1371	have_operators = 1;
1372      } else if (Strstr(symname, "__ne__")) {
1373	DohSetInt(operators, "__ne__", 1);
1374	have_operators = 1;
1375      } else if (Strstr(symname, "__assign__")) {
1376	DohSetInt(operators, "__assign__", 1);
1377	have_operators = 1;
1378      } else if (Strstr(symname, "__str__")) {
1379	DohSetInt(operators, "__str__", 1);
1380	have_operators = 1;
1381      } else if (Strstr(symname, "__add__")) {
1382	DohSetInt(operators, "__add__", 1);
1383	have_operators = 1;
1384      } else if (Strstr(symname, "__sub__")) {
1385	DohSetInt(operators, "__sub__", 1);
1386	have_operators = 1;
1387      } else if (Strstr(symname, "__mul__")) {
1388	DohSetInt(operators, "__mul__", 1);
1389	have_operators = 1;
1390      } else if (Strstr(symname, "__div__")) {
1391	DohSetInt(operators, "__div__", 1);
1392	have_operators = 1;
1393      } else if (Strstr(symname, "__mod__")) {
1394	DohSetInt(operators, "__mod__", 1);
1395	have_operators = 1;
1396      } else if (Strstr(symname, "__and__")) {
1397	DohSetInt(operators, "__and__", 1);
1398	have_operators = 1;
1399      } else if (Strstr(symname, "__or__")) {
1400	DohSetInt(operators, "__or__", 1);
1401	have_operators = 1;
1402      } else if (Strstr(symname, "__not__")) {
1403	DohSetInt(operators, "__not__", 1);
1404	have_operators = 1;
1405      } else if (Strstr(symname, "__gt__")) {
1406	DohSetInt(operators, "__gt__", 1);
1407	have_operators = 1;
1408      } else if (Strstr(symname, "__ge__")) {
1409	DohSetInt(operators, "__ge__", 1);
1410	have_operators = 1;
1411      } else if (Strstr(symname, "__lt__")) {
1412	DohSetInt(operators, "__lt__", 1);
1413	have_operators = 1;
1414      } else if (Strstr(symname, "__le__")) {
1415	DohSetInt(operators, "__le__", 1);
1416	have_operators = 1;
1417      } else if (Strstr(symname, "__neg__")) {
1418	DohSetInt(operators, "__neg__", 1);
1419	have_operators = 1;
1420      } else if (Strstr(symname, "__plusplus__")) {
1421	DohSetInt(operators, "__plusplus__", 1);
1422	have_operators = 1;
1423      } else if (Strstr(symname, "__minmin__")) {
1424	DohSetInt(operators, "__minmin__", 1);
1425	have_operators = 1;
1426      } else if (Strstr(symname, "__mineq__")) {
1427	DohSetInt(operators, "__mineq__", 1);
1428	have_operators = 1;
1429      } else if (Strstr(symname, "__pluseq__")) {
1430	DohSetInt(operators, "__pluseq__", 1);
1431	have_operators = 1;
1432      }
1433
1434      if (Getattr(n, "feature:shadow")) {
1435	String *plcode = perlcode(Getattr(n, "feature:shadow"), 0);
1436	String *plaction = NewStringf("%s::%s", cmodule, Swig_name_member(NSPACE_TODO, class_name, symname));
1437	Replaceall(plcode, "$action", plaction);
1438	Delete(plaction);
1439	Printv(pcode, plcode, NIL);
1440      } else {
1441	Printv(pcode, "*", symname, " = *", cmodule, "::", Swig_name_member(NSPACE_TODO, class_name, symname), ";\n", NIL);
1442      }
1443    }
1444    return SWIG_OK;
1445  }
1446
1447  /* ------------------------------------------------------------
1448   * membervariableHandler()
1449   *
1450   * Adds an instance member.
1451   * ----------------------------------------------------------------------------- */
1452
1453  virtual int membervariableHandler(Node *n) {
1454
1455    String *symname = Getattr(n, "sym:name");
1456    /* SwigType *t  = Getattr(n,"type"); */
1457
1458    /* Emit a pair of get/set functions for the variable */
1459
1460    member_func = 1;
1461    Language::membervariableHandler(n);
1462    member_func = 0;
1463
1464    if (blessed) {
1465
1466      Printv(pcode, "*swig_", symname, "_get = *", cmodule, "::", Swig_name_get(NSPACE_TODO, Swig_name_member(NSPACE_TODO, class_name, symname)), ";\n", NIL);
1467      Printv(pcode, "*swig_", symname, "_set = *", cmodule, "::", Swig_name_set(NSPACE_TODO, Swig_name_member(NSPACE_TODO, class_name, symname)), ";\n", NIL);
1468
1469      /* Now we need to generate a little Perl code for this */
1470
1471      /* if (is_shadow(t)) {
1472
1473       *//* This is a Perl object that we have already seen.  Add an
1474         entry to the members list *//*
1475         Printv(blessedmembers,
1476         tab4, symname, " => '", is_shadow(t), "',\n",
1477         NIL);
1478
1479         }
1480       */
1481    }
1482    have_data_members++;
1483    return SWIG_OK;
1484  }
1485
1486  /* ------------------------------------------------------------
1487   * constructorDeclaration()
1488   *
1489   * Emits a blessed constructor for our class.    In addition to our construct
1490   * we manage a Perl hash table containing all of the pointers created by
1491   * the constructor.   This prevents us from accidentally trying to free
1492   * something that wasn't necessarily allocated by malloc or new
1493   * ------------------------------------------------------------ */
1494
1495  virtual int constructorHandler(Node *n) {
1496
1497    String *symname = Getattr(n, "sym:name");
1498
1499    member_func = 1;
1500    Language::constructorHandler(n);
1501
1502    if ((blessed) && (!Getattr(n, "sym:nextSibling"))) {
1503      if (Getattr(n, "feature:shadow")) {
1504	String *plcode = perlcode(Getattr(n, "feature:shadow"), 0);
1505	String *plaction = NewStringf("%s::%s", module, Swig_name_member(NSPACE_TODO, class_name, symname));
1506	Replaceall(plcode, "$action", plaction);
1507	Delete(plaction);
1508	Printv(pcode, plcode, NIL);
1509      } else {
1510	if ((Cmp(symname, class_name) == 0)) {
1511	  /* Emit a blessed constructor  */
1512	  Printf(pcode, "sub new {\n");
1513	} else {
1514	  /* Constructor doesn't match classname so we'll just use the normal name  */
1515	  Printv(pcode, "sub ", Swig_name_construct(NSPACE_TODO, symname), " {\n", NIL);
1516	}
1517
1518	Printv(pcode,
1519	       tab4, "my $pkg = shift;\n",
1520	       tab4, "my $self = ", cmodule, "::", Swig_name_construct(NSPACE_TODO, symname), "(@_);\n", tab4, "bless $self, $pkg if defined($self);\n", "}\n\n", NIL);
1521
1522	have_constructor = 1;
1523      }
1524    }
1525    member_func = 0;
1526    return SWIG_OK;
1527  }
1528
1529  /* ------------------------------------------------------------ 
1530   * destructorHandler()
1531   * ------------------------------------------------------------ */
1532
1533  virtual int destructorHandler(Node *n) {
1534    String *symname = Getattr(n, "sym:name");
1535    member_func = 1;
1536    Language::destructorHandler(n);
1537    if (blessed) {
1538      if (Getattr(n, "feature:shadow")) {
1539	String *plcode = perlcode(Getattr(n, "feature:shadow"), 0);
1540	String *plaction = NewStringf("%s::%s", module, Swig_name_member(NSPACE_TODO, class_name, symname));
1541	Replaceall(plcode, "$action", plaction);
1542	Delete(plaction);
1543	Printv(pcode, plcode

Large files files are truncated, but you can click here to view the full file