1 /* -*- mode: c++; c-basic-offset: 2; indent-tabs-mode: nil; -*-
2 * vim:expandtab:shiftwidth=2:tabstop=8:smarttab:
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.
11 * Perl5 language module for SWIG.
12 * ------------------------------------------------------------------------- */
14 char cvsroot_perl5_cxx[] = "$Id: perl5.cxx 11397 2009-07-15 07:43:16Z olly $";
18 static int treduce = SWIG_cparse_template_reduce(0);
22 static const char *usage = (char *) "\
23 Perl5 Options (available with -perl5)\n\
24 -static - Omit code related to dynamic loading\n\
25 -nopm - Do not generate the .pm file\n\
26 -proxy - Create proxy classes\n\
27 -noproxy - Don't create proxy classes\n\
28 -const - Wrap constants as constants and not variables (implies -proxy)\n\
29 -nocppcast - Disable C++ casting operators, useful for generating bugs\n\
30 -cppcast - Enable C++ casting operators\n\
31 -compat - Compatibility mode\n\n";
33 static int compat = 0;
35 static int no_pmfile = 0;
37 static int export_all = 0;
41 * set by the -pm flag, overrides the name of the .pm file
43 static String *pmfile = 0;
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.
51 static String *module = 0;
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"
61 static String *namespace_module = 0;
65 * the namespace of the internal glue code, set to the value of
66 * module with a 'c' appended
68 static String *cmodule = 0;
72 * an optional namespace to put all classes into. Specified by using
73 * the %module(package="Foo::Bar") "baz" syntax
75 static String *dest_package = 0;
77 static String *command_tab = 0;
78 static String *constant_tab = 0;
79 static String *variable_tab = 0;
81 static File *f_begin = 0;
82 static File *f_runtime = 0;
83 static File *f_header = 0;
84 static File *f_wrappers = 0;
85 static File *f_init = 0;
86 static File *f_pm = 0;
87 static String *pm; /* Package initialization code */
88 static String *magic; /* Magic variable wrappers */
90 static int staticoption = 0;
92 // controlling verbose output
93 static int verbose = 0;
95 /* The following variables are used to manage Perl5 classes */
97 static int blessed = 1; /* Enable object oriented features */
98 static int do_constants = 0; /* Constant wrapping */
99 static List *classlist = 0; /* List of classes */
100 static int have_constructor = 0;
101 static int have_destructor = 0;
102 static int have_data_members = 0;
103 static String *class_name = 0; /* Name of the class (what Perl thinks it is) */
104 static String *real_classname = 0; /* Real name of C/C++ class */
105 static String *fullclassname = 0;
107 static String *pcode = 0; /* Perl code associated with each class */
108 /* static String *blessedmembers = 0; *//* Member data associated with each class */
109 static int member_func = 0; /* Set to 1 when wrapping a member function */
110 static String *func_stubs = 0; /* Function stubs */
111 static String *const_stubs = 0; /* Constant stubs */
112 static int num_consts = 0; /* Number of constants */
113 static String *var_stubs = 0; /* Variable stubs */
114 static String *exported = 0; /* Exported symbols */
115 static String *pragma_include = 0;
116 static String *additional_perl_code = 0; /* Additional Perl code from %perlcode %{ ... %} */
117 static Hash *operators = 0;
118 static int have_operators = 0;
120 class PERL5:public Language {
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);
130 /* Test to see if a type corresponds to something wrapped with a shadow class */
131 Node *is_shadow(SwigType *t) {
134 /* Printf(stdout,"'%s' --> '%x'\n", t, n); */
136 if (!Getattr(n, "perl5:proxy")) {
139 return Getattr(n, "perl5:proxy");
144 /* ------------------------------------------------------------
146 * ------------------------------------------------------------ */
148 virtual void main(int argc, char *argv[]) {
152 SWIG_library_directory("perl5");
154 for (i = 1; i < argc; i++) {
156 if (strcmp(argv[i], "-package") == 0) {
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) {
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) {
167 } else if (strcmp(argv[i], "-static") == 0) {
170 } else if ((strcmp(argv[i], "-shadow") == 0) || ((strcmp(argv[i], "-proxy") == 0))) {
173 } else if ((strcmp(argv[i], "-noproxy") == 0)) {
176 } else if (strcmp(argv[i], "-const") == 0) {
180 } else if (strcmp(argv[i], "-nopm") == 0) {
183 } else if (strcmp(argv[i], "-pm") == 0) {
186 pmfile = NewString(argv[i]);
188 } else if (strcmp(argv[i],"-v") == 0) {
191 } else if (strcmp(argv[i], "-cppcast") == 0) {
194 } else if (strcmp(argv[i], "-nocppcast") == 0) {
197 } else if (strcmp(argv[i], "-compat") == 0) {
200 } else if (strcmp(argv[i], "-help") == 0) {
201 fputs(usage, stdout);
207 Preprocessor_define((DOH *) "SWIG_CPLUSPLUS_CAST", 0);
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");
218 /* ------------------------------------------------------------
220 * ------------------------------------------------------------ */
222 virtual int top(Node *n) {
224 /* Initialize all of the output files */
225 String *outfile = Getattr(n, "outfile");
227 f_begin = NewFile(outfile, "w", SWIG_output_files());
229 FileErrorDisplay(outfile);
230 SWIG_exit(EXIT_FAILURE);
232 f_runtime = NewString("");
233 f_init = NewString("");
234 f_header = NewString("");
235 f_wrappers = NewString("");
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);
244 classlist = NewList();
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("");
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");
259 Swig_banner(f_begin);
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");
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
269 Node *mod = Getattr(n, "module");
270 Node *options = Getattr(mod, "options");
271 module = Copy(Getattr(n,"name"));
274 fprintf(stdout, "top: using module: %s\n", Char(module));
277 dest_package = options ? Getattr(options, "package") : 0;
279 namespace_module = Copy(dest_package);
281 fprintf(stdout, "top: Found package: %s\n",Char(dest_package));
284 namespace_module = Copy(module);
286 fprintf(stdout, "top: No package found\n");
289 String *underscore_module = Copy(module);
290 Replaceall(underscore_module,":","_");
293 fprintf(stdout, "top: using namespace_module: %s\n", Char(namespace_module));
296 /* If we're in blessed mode, change the package name to "packagec" */
299 cmodule = NewStringf("%sc",namespace_module);
301 cmodule = NewString(namespace_module);
305 * Need to strip off any prefixes that might be found in
311 if (pmfile == NULL) {
312 char *m = Char(module) + Len(module);
313 while (m != Char(module)) {
320 pmfile = NewStringf("%s.pm", m);
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);
329 Swig_register_filebyname("pm", f_pm);
330 Swig_register_filebyname("perl", f_pm);
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);
340 Swig_banner_target_lang(f_pm, "#");
343 Printf(f_pm, "package %s;\n", module);
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
351 Printf(f_pm,"use base qw(DynaLoader);\n");
353 Printf(f_pm,"use base qw(Exporter);\n");
355 Printf(f_pm,"use base qw(DynaLoader);\n");
359 /* Start creating magic code */
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",
368 "#define MAGIC_CLASS\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);
373 Printf(f_wrappers, "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
378 String *base = NewString("");
380 /* Dump out variable wrappers */
382 Printv(magic, "\n\n#ifdef PERL_OBJECT\n", "};\n", "#endif\n", NIL);
383 Printv(magic, "\n#ifdef __cplusplus\n}\n#endif\n", NIL);
385 Printf(f_header, "%s\n", magic);
387 String *type_table = NewString("");
389 /* Patch the type table to reflect the names used by shadow classes */
392 for (cls = First(classlist); cls.item; cls = Next(cls)) {
393 String *pname = Getattr(cls.item, "perl5:proxy");
395 SwigType *type = Getattr(cls.item, "classtypeobj");
397 continue; /* If unnamed class, no type will be found */
400 SwigType_add_pointer(type);
401 String *mangled = SwigType_manglestr(type);
402 SwigType_remember_mangleddata(mangled, NewStringf("\"%s\"", pname));
408 SwigType_emit_type_table(f_runtime, type_table);
410 Printf(f_wrappers, "%s", type_table);
413 Printf(constant_tab, "{0,0,0,0,0,0}\n};\n");
414 Printv(f_wrappers, constant_tab, NIL);
416 Printf(f_wrappers, "#ifdef __cplusplus\n}\n#endif\n");
418 Printf(f_init, "\t ST(0) = &PL_sv_yes;\n");
419 Printf(f_init, "\t XSRETURN(1);\n");
420 Printf(f_init, "}\n");
422 /* Finish off tables */
423 Printf(variable_tab, "{0,0,0,0}\n};\n");
424 Printv(f_wrappers, variable_tab, NIL);
426 Printf(command_tab, "{0,0}\n};\n");
427 Printv(f_wrappers, command_tab, NIL);
430 Printf(f_pm, "package %s;\n", cmodule);
433 Printf(f_pm,"bootstrap %s;\n", module);
435 Printf(f_pm,"package %s;\n", cmodule);
436 Printf(f_pm,"boot_%s();\n", underscore_module);
439 Printf(f_pm, "package %s;\n", module);
441 * If the package option has been given we are placing our
442 * symbols into some other packages namespace, so we do not
446 Printf(f_pm,"@EXPORT = qw(%s);\n", exported);
449 Printf(f_pm, "%s", pragma_include);
454 * These methods will be duplicated if package
455 * has been specified, so we do not output them
458 Printv(base, "\n# ---------- BASE METHODS -------------\n\n", "package ", namespace_module, ";\n\n", NIL);
460 /* Write out the TIE method */
462 Printv(base, "sub TIEHASH {\n", tab4, "my ($classname,$obj) = @_;\n", tab4, "return bless $obj, $classname;\n", "}\n\n", NIL);
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 );
468 * Where x,y,z are the members of some C/C++ object. */
470 Printf(base, "sub CLEAR { }\n\n");
472 /* Output default firstkey/nextkey methods */
474 Printf(base, "sub FIRSTKEY { }\n\n");
475 Printf(base, "sub NEXTKEY { }\n\n");
477 /* Output a FETCH method. This is actually common to all classes */
480 tab4, "my ($self,$field) = @_;\n", tab4, "my $member_func = \"swig_${field}_get\";\n", tab4, "$self->$member_func();\n", "}\n\n", NIL);
482 /* Output a STORE method. This is also common to all classes (might move to base class) */
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);
489 /* Output a 'this' method */
491 Printv(base, "sub this {\n", tab4, "my $ptr = shift;\n", tab4, "return tied(%$ptr);\n", "}\n\n", NIL);
493 Printf(f_pm, "%s", base);
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);
501 /* Emit package code for different classes */
502 Printf(f_pm, "%s", pm);
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);
511 /* Emit variable stubs */
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);
518 /* Add additional Perl code at the end */
519 Printf(f_pm, "%s", additional_perl_code);
521 Printf(f_pm, "1;\n");
525 Delete(dest_package);
526 Delete(underscore_module);
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);
542 /* ------------------------------------------------------------
543 * importDirective(Node *n)
544 * ------------------------------------------------------------ */
546 virtual int importDirective(Node *n) {
548 String *modname = Getattr(n, "module");
550 Printf(f_pm, "require %s;\n", modname);
553 return Language::importDirective(n);
556 /* ------------------------------------------------------------
558 * ------------------------------------------------------------ */
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;
570 char source[256], temp[256];
572 String *cleanup, *outarg;
574 int num_arguments, num_required;
577 if (Getattr(n, "sym:overloaded")) {
578 overname = Getattr(n, "sym:overname");
580 if (!addSymbol(iname, n))
585 cleanup = NewString("");
586 outarg = NewString("");
588 String *wname = Swig_name_wrapper(iname);
590 Append(wname, overname);
592 Setattr(n, "wrap:name", wname);
593 Printv(f->def, "XS(", wname, ") {\n", "{\n", /* scope to destroy C++ objects before croaking */
596 emit_parameter_variables(l, f);
597 emit_attach_parmmaps(l, f);
598 Setattr(n, "wrap:parms", l);
600 num_arguments = emit_num_arguments(l);
601 num_required = emit_num_required(l);
602 varargs = emit_isvarargs(l);
604 Wrapper_add_local(f, "argvi", "int argvi = 0");
606 /* Check the number of arguments */
608 Printf(f->code, " if ((items < %d) || (items > %d)) {\n", num_required, num_arguments);
610 Printf(f->code, " if (items < %d) {\n", num_required);
612 Printf(f->code, " SWIG_croak(\"Usage: %s\");\n", usage_func(Char(iname), d, l));
613 Printf(f->code, "}\n");
615 /* Write code to extract parameters. */
617 for (i = 0, p = l; i < num_arguments; i++) {
619 /* Skip ignored arguments */
621 while (checkAttribute(p, "tmap:in:numinputs", "0")) {
622 p = Getattr(p, "tmap:in:next");
625 SwigType *pt = Getattr(p, "type");
627 /* Produce string representation of source and target arguments */
628 sprintf(source, "ST(%d)", i);
629 String *target = Getattr(p, "lname");
631 if (i >= num_required) {
632 Printf(f->code, " if (items > %d) {\n", i);
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 */
640 if (Getattr(p, "wrap:disown") || (Getattr(p, "tmap:in:disown"))) {
641 Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN");
643 Replaceall(tm, "$disown", "0");
646 Printf(f->code, "%s\n", tm);
647 p = Getattr(p, "tmap:in:next");
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));
652 if (i >= num_required) {
653 Printf(f->code, " }\n");
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");
668 /* Insert constraint checking code */
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");
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");
692 /* Insert argument output code */
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)");
701 Replaceall(tm, "$shadow", "SWIG_SHADOW");
703 Replaceall(tm, "$shadow", "0");
706 String *in = Getattr(p, "emit:input");
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);
714 Printv(outarg, tm, "\n", NIL);
715 p = Getattr(p, "tmap:argout:next");
721 /* If there were any saved arguments, emit a local variable for them */
723 sprintf(temp, "_saved[%d]", num_saved);
724 Wrapper_add_localv(f, "_saved", "SV *", temp, NIL);
727 /* Now write code to make the function call */
729 Swig_director_emit_dynamic_cast(n, f);
730 String *actioncode = emit_action(n);
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)");
738 Replaceall(tm, "$shadow", "SWIG_SHADOW");
740 Replaceall(tm, "$shadow", "0");
742 if (GetFlag(n, "feature:new")) {
743 Replaceall(tm, "$owner", "SWIG_OWNER");
745 Replaceall(tm, "$owner", "0");
747 Printf(f->code, "%s\n", tm);
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);
751 emit_return_variable(n, d, f);
753 /* If there were any output args, take care of them. */
755 Printv(f->code, outarg, NIL);
757 /* If there was any cleanup, do that. */
759 Printv(f->code, cleanup, NIL);
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);
768 if ((tm = Swig_typemap_lookup("ret", n, "result", 0))) {
769 Replaceall(tm, "$source", "result");
770 Printf(f->code, "%s\n", tm);
773 Printv(f->code, "XSRETURN(argvi);\n", "fail:\n", cleanup, "SWIG_croak_null();\n" "}\n" "}\n", NIL);
775 /* Add the dXSARGS last */
777 Wrapper_add_local(f, "dXSARGS", "dXSARGS");
779 /* Substitute the cleanup code */
780 Replaceall(f->code, "$cleanup", cleanup);
781 Replaceall(f->code, "$symname", iname);
783 /* Dump the wrapper function */
785 Wrapper_print(f, f_wrappers);
787 /* Now register the function */
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 */
794 String *dispatch = Swig_overload_dispatch_cast(n, "++PL_markstack_ptr; SWIG_CALLXS(%s); return;", &maxargs);
796 /* Generate a dispatch wrapper for all overloaded functions */
798 Wrapper *df = NewWrapper();
799 String *dname = Swig_name_wrapper(iname);
801 Printv(df->def, "XS(", dname, ") {\n", NIL);
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);
814 if (!Getattr(n, "sym:nextSibling")) {
816 Printf(exported, "%s ", iname);
819 /* --------------------------------------------------------------------
820 * Create a stub for this function, provided it's not a member function
821 * -------------------------------------------------------------------- */
823 if ((blessed) && (!member_func)) {
824 Printv(func_stubs, "*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
834 /* ------------------------------------------------------------
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;
843 String *getname = Swig_name_get(iname);
844 String *setname = Swig_name_set(iname);
846 String *get_name = Swig_name_wrapper(getname);
847 String *set_name = Swig_name_wrapper(setname);
849 if (!addSymbol(iname, n))
855 /* Create a Perl function for setting the variable value */
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);
862 /* Check for a few typemaps */
863 tm = Swig_typemap_lookup("varin", n, name, 0);
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);
871 Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number, "Unable to set variable of type %s.\n", SwigType_str(t, 0));
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);
880 /* Now write a function to evaluate the variable */
881 Setattr(n, "wrap:name", get_name);
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);
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);
891 Replaceall(tm, "$shadow", "SWIG_SHADOW");
893 Replaceall(tm, "$shadow", "0");
895 /* Printf(getf->code,"%s\n", tm); */
896 addfail = emit_action_code(n, getf->code, tm);
898 Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number, "Unable to read variable of type %s\n", SwigType_str(t, 0));
903 Printf(getf->code, " return 1;\n");
905 Append(getf->code, "fail:\n");
906 Append(getf->code, " return 0;\n");
908 Append(getf->code, "}\n");
911 Replaceall(getf->code, "$symname", iname);
912 Wrapper_print(getf, magic);
914 String *tt = Getattr(n, "tmap:varout:type");
916 String *tm = NewStringf("&SWIGTYPE%s", SwigType_manglestr(t));
917 if (Replaceall(tt, "$1_descriptor", tm)) {
918 SwigType_remember(t);
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);
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);
937 Printv(variable_tab, tab4, "{ \"", cmodule, "::", iname, "\", MAGIC_CLASS ", set_name, ", MAGIC_CLASS ", get_name, ",", tt, " },\n", NIL);
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
943 2. Otherwise, just hack Perl's symbol table */
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);
952 Printv(var_stubs, "*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
956 Printf(exported, "$%s ", iname);
967 /* ------------------------------------------------------------
969 * ------------------------------------------------------------ */
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");
979 if (!addSymbol(iname, n))
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);
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");
996 Replaceall(tm, "$shadow", "0");
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");
1006 Replaceall(tm, "$shadow", "0");
1008 Printf(f_init, "%s\n", tm);
1010 Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number, "Unsupported constant value.\n");
1015 if (is_shadow(type)) {
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);
1024 Printv(var_stubs, "*", iname, " = *", cmodule, "::", iname, ";\n", NIL);
1028 if (do_constants && !is_shadow(type)) {
1029 Printf(exported, "%s ", name);
1031 Printf(exported, "$%s ", iname);
1037 /* ------------------------------------------------------------
1039 * ------------------------------------------------------------ */
1040 char *usage_func(char *iname, SwigType *, ParmList *l) {
1041 static String *temp = 0;
1046 temp = NewString("");
1048 Printf(temp, "%s(", iname);
1050 /* Now go through and print parameters */
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) {
1060 Printf(temp, "%s", pn);
1062 Printf(temp, "%s", SwigType_str(pt, 0));
1068 if (!checkAttribute(p,"tmap:in:numinputs","0"))
1073 if ((i > 0) && (!checkAttribute(p,"tmap:in:numinputs","0")))
1081 /* ------------------------------------------------------------
1083 * ------------------------------------------------------------ */
1085 virtual int nativeWrapper(Node *n) {
1086 String *name = Getattr(n, "sym:name");
1087 String *funcname = Getattr(n, "wrap:name");
1089 if (!addSymbol(funcname, n))
1092 Printf(command_tab, "{\"%s::%s\", %s},\n", cmodule, name, funcname);
1094 Printf(exported, "%s ", name);
1096 Printv(func_stubs, "*", name, " = *", cmodule, "::", name, ";\n", NIL);
1101 /* ----------------------------------------------------------------------------
1102 * OBJECT-ORIENTED FEATURES
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.
1108 * I have generalized these extensions to make them more general purpose
1109 * and to resolve object-ownership problems.
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
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
1121 * 3. Classes are represented as tied-hashes in a manner similar
1122 * to Gary Holt's extension. This allows us to access
1125 * 4. Stand-alone (global) C functions are modified to take
1126 * tied hashes as arguments for complex datatypes (if
1129 * 5. Global variables involving a class/struct is encapsulated
1132 * ------------------------------------------------------------------------- */
1135 void setclassname(Node *n) {
1136 String *symname = Getattr(n, "sym:name");
1138 String *actualpackage;
1139 Node *clsmodule = Getattr(n, "module");
1142 /* imported module does not define a module name. Oh well */
1146 /* Do some work on the class name */
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");
1155 fullname = NewStringf("%s::%s", namespace_module, symname);
1157 actualpackage = Getattr(clsmodule,"name");
1160 fprintf(stdout, "setclassname: Found actualpackage: %s\n", Char(actualpackage));
1162 if ((!compat) && (!Strchr(symname,':'))) {
1163 fullname = NewStringf("%s::%s",actualpackage,symname);
1165 fullname = NewString(symname);
1169 fprintf(stdout, "setclassname: setting proxy: %s\n", Char(fullname));
1171 Setattr(n, "perl5:proxy", fullname);
1174 /* ------------------------------------------------------------
1175 * classDeclaration()
1176 * ------------------------------------------------------------ */
1177 virtual int classDeclaration(Node *n) {
1178 /* Do some work on the class name */
1179 if (!Getattr(n, "feature:onlychildren")) {
1182 Append(classlist, n);
1186 return Language::classDeclaration(n);
1189 /* ------------------------------------------------------------
1191 * ------------------------------------------------------------ */
1193 virtual int classHandler(Node *n) {
1196 have_constructor = 0;
1198 have_destructor = 0;
1199 have_data_members = 0;
1200 operators = NewHash();
1202 class_name = Getattr(n, "sym:name");
1204 if (!addSymbol(class_name, n))
1207 /* Use the fully qualified name of the Perl class */
1209 fullclassname = NewStringf("%s::%s", namespace_module, class_name);
1211 fullclassname = NewString(class_name);
1213 real_classname = Getattr(n, "name");
1214 pcode = NewString("");
1215 // blessedmembers = NewString("");
1218 /* Emit all of the members */
1219 Language::classHandler(n);
1222 /* Finish the rest of the class */
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);
1230 Printv(pm, "\n############# Class : ", fullclassname, " ##############\n", "\npackage ", fullclassname, ";\n", NIL);
1232 if (have_operators) {
1233 Printf(pm, "use overload\n");
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);
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);
1291 fprintf(stderr,"Unknown operator: %s\n", name);
1295 "\"=\" => sub { my $class = ref($_[0]); $class->new($_[0]) },\n", NIL);
1296 Printv(pm, tab4, "\"fallback\" => 1;\n", NIL);
1298 // make use strict happy
1299 Printv(pm, "use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);\n", NIL);
1301 /* If we are inheriting from a base class, set that up */
1303 Printv(pm, "@ISA = qw(", NIL);
1305 /* Handle inheritance */
1306 List *baselist = Getattr(n, "bases");
1307 if (baselist && Len(baselist)) {
1309 b = First(baselist);
1311 String *bname = Getattr(b.item, "perl5:proxy");
1316 Printv(pm, " ", bname, NIL);
1321 /* Module comes last */
1322 if (!compat || Cmp(namespace_module, fullclassname)) {
1323 Printv(pm, " ", namespace_module, NIL);
1326 Printf(pm, " );\n");
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");
1333 /* Dump out the package methods */
1335 Printv(pm, pcode, NIL);
1338 /* Output methods for managing ownership */
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);
1347 /* Only output the following methods if a class has member data */
1355 /* ------------------------------------------------------------
1356 * memberfunctionHandler()
1357 * ------------------------------------------------------------ */
1359 virtual int memberfunctionHandler(Node *n) {
1360 String *symname = Getattr(n, "sym:name");
1363 Language::memberfunctionHandler(n);
1366 if ((blessed) && (!Getattr(n, "sym:nextSibling"))) {
1368 if (Strstr(symname, "__eq__")) {
1369 DohSetInt(operators, "__eq__", 1);
1371 } else if (Strstr(symname, "__ne__")) {
1372 DohSetInt(operators, "__ne__", 1);
1374 } else if (Strstr(symname, "__assign__")) {
1375 DohSetInt(operators, "__assign__", 1);
1377 } else if (Strstr(symname, "__str__")) {
1378 DohSetInt(operators, "__str__", 1);
1380 } else if (Strstr(symname, "__add__")) {
1381 DohSetInt(operators, "__add__", 1);
1383 } else if (Strstr(symname, "__sub__")) {
1384 DohSetInt(operators, "__sub__", 1);
1386 } else if (Strstr(symname, "__mul__")) {
1387 DohSetInt(operators, "__mul__", 1);
1389 } else if (Strstr(symname, "__div__")) {
1390 DohSetInt(operators, "__div__", 1);
1392 } else if (Strstr(symname, "__mod__")) {
1393 DohSetInt(operators, "__mod__", 1);
1395 } else if (Strstr(symname, "__and__")) {
1396 DohSetInt(operators, "__and__", 1);
1398 } else if (Strstr(symname, "__or__")) {
1399 DohSetInt(operators, "__or__", 1);
1401 } else if (Strstr(symname, "__not__")) {
1402 DohSetInt(operators, "__not__", 1);
1404 } else if (Strstr(symname, "__gt__")) {
1405 DohSetInt(operators, "__gt__", 1);
1407 } else if (Strstr(symname, "__ge__")) {
1408 DohSetInt(operators, "__ge__", 1);
1410 } else if (Strstr(symname, "__lt__")) {
1411 DohSetInt(operators, "__lt__", 1);
1413 } else if (Strstr(symname, "__le__")) {
1414 DohSetInt(operators, "__le__", 1);
1416 } else if (Strstr(symname, "__neg__")) {
1417 DohSetInt(operators, "__neg__", 1);
1419 } else if (Strstr(symname, "__plusplus__")) {
1420 DohSetInt(operators, "__plusplus__", 1);
1422 } else if (Strstr(symname, "__minmin__")) {
1423 DohSetInt(operators, "__minmin__", 1);
1425 } else if (Strstr(symname, "__mineq__")) {
1426 DohSetInt(operators, "__mineq__", 1);
1428 } else if (Strstr(symname, "__pluseq__")) {
1429 DohSetInt(operators, "__pluseq__", 1);
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);
1438 Printv(pcode, plcode, NIL);
1440 Printv(pcode, "*", symname, " = *", cmodule, "::", Swig_name_member(class_name, symname), ";\n", NIL);
1446 /* ------------------------------------------------------------
1447 * membervariableHandler()
1449 * Adds an instance member.
1450 * ----------------------------------------------------------------------------- */
1452 virtual int membervariableHandler(Node *n) {
1454 String *symname = Getattr(n, "sym:name");
1455 /* SwigType *t = Getattr(n,"type"); */
1457 /* Emit a pair of get/set functions for the variable */
1460 Language::membervariableHandler(n);
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);
1468 /* Now we need to generate a little Perl code for this */
1470 /* if (is_shadow(t)) {
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",
1481 have_data_members++;
1485 /* ------------------------------------------------------------
1486 * constructorDeclaration()
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 * ------------------------------------------------------------ */
1494 virtual int constructorHandler(Node *n) {
1496 String *symname = Getattr(n, "sym:name");
1499 Language::constructorHandler(n);
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);
1507 Printv(pcode, plcode, NIL);
1509 if ((Cmp(symname, class_name) == 0)) {
1510 /* Emit a blessed constructor */
1511 Printf(pcode, "sub new {\n");
1513 /* Constructor doesn't match classname so we'll just use the normal name */
1514 Printv(pcode, "sub ", Swig_name_construct(symname), " {\n", NIL);
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);
1521 have_constructor = 1;
1528 /* ------------------------------------------------------------
1529 * destructorHandler()
1530 * ------------------------------------------------------------ */
1532 virtual int destructorHandler(Node *n) {
1533 String *symname = Getattr(n, "sym:name");
1535 Language::destructorHandler(n);
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);
1542 Printv(pcode, plcode, NIL);
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;
1559 /* ------------------------------------------------------------
1560 * staticmemberfunctionHandler()
1561 * ------------------------------------------------------------ */
1563 virtual int staticmemberfunctionHandler(Node *n) {
1565 Language::staticmemberfunctionHandler(n);
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);
1574 /* ------------------------------------------------------------
1575 * staticmembervariableHandler()
1576 * ------------------------------------------------------------ */
1578 virtual int staticmembervariableHandler(Node *n) {
1579 Language::staticmembervariableHandler(n);
1581 String *symname = Getattr(n, "sym:name");
1582 Printv(pcode, "*", symname, " = *", cmodule, "::", Swig_name_member(class_name, symname), ";\n", NIL);
1587 /* ------------------------------------------------------------
1588 * memberconstantHandler()
1589 * ------------------------------------------------------------ */
1591 virtual int memberconstantHandler(Node *n) {
1592 String *symname = Getattr(n, "sym:name");
1593 int oldblessed = blessed;
1595 /* Create a normal constant */
1597 Language::memberconstantHandler(n);
1598 blessed = oldblessed;
1601 Printv(pcode, "*", symname, " = *", cmodule, "::", Swig_name_member(class_name, symname), ";\n", NIL);
1606 /* ------------------------------------------------------------
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 * ------------------------------------------------------------ */
1615 virtual int pragmaDirective(Node *n) {
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 */
1627 Printf(pragma_include, "%s\n", value);
1629 } else if (Strcmp(code, "include") == 0) {
1630 /* Include a file into the .pm file */
1632 FILE *f = Swig_include_open(value);
1634 Printf(stderr, "%s : Line %d. Unable to locate file %s\n", input_file, line_number, value);
1637 while (fgets(buffer, 4095, f)) {
1638 Printf(pragma_include, "%s", buffer);
1644 Printf(stderr, "%s : Line %d. Unrecognized pragma.\n", input_file, line_number);
1648 return Language::pragmaDirective(n);
1651 /* ------------------------------------------------------------
1652 * perlcode() - Output perlcode code into the shadow file
1653 * ------------------------------------------------------------ */
1655 String *perlcode(String *code, const String *indent) {
1656 String *out = NewString("");
1662 temp = NewString(code);
1667 Delitem(temp, DOH_END);
1670 /* Split the input text into lines */
1671 List *clist = DohSplitLines(temp);
1676 /* Get the initial indentation */
1678 for (si = First(clist); si.item; si = Next(si)) {
1688 if (*c && !isspace(*c))
1697 if (Len(s) > initial) {
1700 Printv(out, indent, c, "\n", NIL);
1702 Printv(out, "\n", NIL);
1710 /* ------------------------------------------------------------
1713 * Hook for %insert directive.
1714 * ------------------------------------------------------------ */
1716 virtual int insertDirective(Node *n) {
1717 String *code = Getattr(n, "code");
1718 String *section = Getattr(n, "section");
1720 if ((!ImportMode) && (Cmp(section, "perl") == 0)) {
1721 Printv(additional_perl_code, code, NIL);
1723 Language::insertDirective(n);
1728 String *runtimeCode() {
1729 String *s = NewString("");
1730 String *shead = Swig_include_sys("perlhead.swg");
1732 Printf(stderr, "*** Unable to open 'perlhead.swg'\n");
1737 String *serrors = Swig_include_sys("perlerrors.swg");
1739 Printf(stderr, "*** Unable to open 'perlerrors.swg'\n");
1744 String *srun = Swig_include_sys("perlrun.swg");
1746 Printf(stderr, "*** Unable to open 'perlrun.swg'\n");
1754 String *defaultExternalRuntimeFilename() {
1755 return NewString("swigperlrun.h");
1759 /* -----------------------------------------------------------------------------
1760 * swig_perl5() - Instantiate module
1761 * ----------------------------------------------------------------------------- */
1763 static Language *new_swig_perl5() {
1766 extern "C" Language *swig_perl5(void) {
1767 return new_swig_perl5();