Source/Modules/perl5.cxx

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