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