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 14char cvsroot_perl5_cxx[] = "$Id: perl5.cxx 11397 2009-07-15 07:43:16Z olly $"; 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 -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 33static int compat = 0; 34 35static int no_pmfile = 0; 36 37static int export_all = 0; 38 39/* 40 * pmfile 41 * set by the -pm flag, overrides the name of the .pm file 42 */ 43static 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 */ 51static 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 */ 61static 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 */ 68static 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 */ 75static String *dest_package = 0; 76 77static String *command_tab = 0; 78static String *constant_tab = 0; 79static String *variable_tab = 0; 80 81static File *f_begin = 0; 82static File *f_runtime = 0; 83static File *f_header = 0; 84static File *f_wrappers = 0; 85static File *f_init = 0; 86static File *f_pm = 0; 87static String *pm; /* Package initialization code */ 88static String *magic; /* Magic variable wrappers */ 89 90static int staticoption = 0; 91 92// controlling verbose output 93static int verbose = 0; 94 95/* The following variables are used to manage Perl5 classes */ 96 97static int blessed = 1; /* Enable object oriented features */ 98static int do_constants = 0; /* Constant wrapping */ 99static List *classlist = 0; /* List of classes */ 100static int have_constructor = 0; 101static int have_destructor = 0; 102static int have_data_members = 0; 103static String *class_name = 0; /* Name of the class (what Perl thinks it is) */ 104static String *real_classname = 0; /* Real name of C/C++ class */ 105static String *fullclassname = 0; 106 107static String *pcode = 0; /* Perl code associated with each class */ 108 /* static String *blessedmembers = 0; *//* Member data associated with each class */ 109static int member_func = 0; /* Set to 1 when wrapping a member function */ 110static String *func_stubs = 0; /* Function stubs */ 111static String *const_stubs = 0; /* Constant stubs */ 112static int num_consts = 0; /* Number of constants */ 113static String *var_stubs = 0; /* Variable stubs */ 114static String *exported = 0; /* Exported symbols */ 115static String *pragma_include = 0; 116static String *additional_perl_code = 0; /* Additional Perl code from %perlcode %{ ... %} */ 117static Hash *operators = 0; 118static int have_operators = 0; 119 120class PERL5:public Language { 121public: 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 1763static Language *new_swig_perl5() { 1764 return new PERL5(); 1765} 1766extern "C" Language *swig_perl5(void) { 1767 return new_swig_perl5(); 1768} 1769