]> git.saurik.com Git - wxWidgets.git/blame - wxPython/wxSWIG/Modules/perl5.cxx
projects / wxWidgets.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Use nicer (swiss) font for default
[wxWidgets.git] / wxPython / wxSWIG / Modules / perl5.cxx
CommitLineData
c90f71dd
RD		 1/*******************************************************************************
2 * Simplified Wrapper and Interface Generator (SWIG)
3 *
4 * Author : David Beazley
5 *
6 * Department of Computer Science
7 * University of Chicago
8 * 1100 E 58th Street
9 * Chicago, IL 60637
10 * beazley@cs.uchicago.edu
11 *
12 * Please read the file LICENSE for the copyright and terms by which SWIG
13 * can be used and distributed.
14 *******************************************************************************/
15
16/***********************************************************************
17 * $Header$
18 *
19 * perl5.c
20 *
21 * Definitions for adding functions to Perl 5
22 *
23 * How to extend perl5 (note : this is totally different in Perl 4) :
24 *
25 * 1. Variable linkage
26 *
27 * Must declare two functions :
28 *
29 * _var_set(SV *sv, MAGIC *mg);
30 * _var_get(SV *sv, MAGIC *mg);
31 *
32 * These functions must set/get the values of a variable using
33 * Perl5 internals.
34 *
35 * To add these to Perl5 (which isn't entirely clear), need to
36 * do the following :
37 *
38 * SV *sv;
39 * MAGIC *m;
40 * sv = perl_get_sv("varname",TRUE);
41 * sv_magic(sv,sv, 'U', "varname", strlen("varname));
42 * m = mg_find(sv, 'U');
43 * m->mg_virtual = (MGVTBL *) malloc(sizeof(MGVTBL));
44 * m->mg_virtual.svt_get = _var_set;
45 * m->mg_virtual.svt_set = _var_get;
46 * m->mg_virtual.svt_len = 0;
47 * m->mg_virtual.svt_free = 0;
48 * m->mg_virtual.svt_clear = 0;
49 *
50 *
51 * 2. Function extension
52 *
53 * Functions are declared as :
54 * XS(_wrap_func) {
55 * dXSARGS;
56 * if (items != parmcount) {
57 * croak("Usage :");
58 * }
59 * ... get arguments ...
60 *
61 * ... call function ...
62 * ... set return value in ST(0)
63 * XSRETURN(1);
64 * }
65 * To extract function arguments, use the following :
66 * _arg = (int) SvIV(ST(0))
67 * _arg = (double) SvNV(ST(0))
68 * _arg = (char *) SvPV(ST(0),na);
69 *
70 * For return values, use :
71 * ST(0) = sv_newmortal();
72 * sv_setiv(ST(0), (IV) RETVAL); // Integers
73 * sv_setnv(ST(0), (double) RETVAL); // Doubles
74 * sv_setpv((SV*) ST(0), RETVAL); // Strings
75 *
76 * New functions are added using
77 * newXS("name", _wrap_func, file)
78 *
79 *
80 * 3. Compilation.
81 *
82 * Code should be compiled into an object file for dynamic
83 * loading into Perl.
84 ***********************************************************************/
85
86#include "swig.h"
87#include "perl5.h"
88
89static String pragma_include;
90
91static char *usage = "\
92Perl5 Options (available with -perl5)\n\
93 -module name - Set module name\n\
94 -package name - Set package prefix\n\
95 -static - Omit code related to dynamic loading.\n\
96 -shadow - Create shadow classes.\n\
97 -compat - Compatibility mode.\n\
98 -alt-header file- Use an alternate header.\n\n";
99
100static char *import_file = 0;
101static char *smodule = 0;
102static int compat = 0;
103
104// ---------------------------------------------------------------------
105// PERL5::parse_args(int argc, char *argv[])
106//
107// Parse command line options.
108// ---------------------------------------------------------------------
109
110void
111PERL5::parse_args(int argc, char *argv[]) {
112
113 int i = 1;
114
115 export_all = 0;
116 sprintf(LibDir,"%s", perl_path);
117
118 // Look for certain command line options
119
120 // Get options
121 for (i = 1; i < argc; i++) {
122 if (argv[i]) {
123 if(strcmp(argv[i],"-package") == 0) {
124 if (argv[i+1]) {
125 package = new char[strlen(argv[i+1])+1];
126 strcpy(package, argv[i+1]);
127 mark_arg(i);
128 mark_arg(i+1);
129 i++;
130 } else {
131 arg_error();
132 }
133 } else if (strcmp(argv[i],"-module") == 0) {
134 if (argv[i+1]) {
135 module = new char[strlen(argv[i+1])+1];
136 strcpy(module, argv[i+1]);
137 cmodule = module;
138 cmodule.replace(":","_");
139 mark_arg(i);
140 mark_arg(i+1);
141 i++;
142 } else {
143 arg_error();
144 }
145 } else if (strcmp(argv[i],"-exportall") == 0) {
146 export_all = 1;
147 mark_arg(i);
148 } else if (strcmp(argv[i],"-static") == 0) {
149 is_static = 1;
150 mark_arg(i);
151 } else if (strcmp(argv[i],"-shadow") == 0) {
152 blessed = 1;
153 mark_arg(i);
154 } else if (strcmp(argv[i],"-alt-header") == 0) {
155 if (argv[i+1]) {
156 alt_header = copy_string(argv[i+1]);
157 mark_arg(i);
158 mark_arg(i+1);
159 i++;
160 } else {
161 arg_error();
162 }
163 } else if (strcmp(argv[i],"-compat") == 0) {
164 compat = 1;
165 mark_arg(i);
166 } else if (strcmp(argv[i],"-help") == 0) {
167 fputs(usage,stderr);
168 }
169 }
170 }
171 // Add a symbol for this module
172
173 add_symbol("SWIGPERL",0,0);
174 add_symbol("SWIGPERL5",0,0);
175
176 // Set name of typemaps
177
178 typemap_lang = "perl5";
179
180}
181
182// ------------------------------------------------------------------
183// PERL5::parse()
184//
185// Parse an interface file
186// ------------------------------------------------------------------
187
188void
189PERL5::parse() {
190
191
192 printf("Generating wrappers for Perl 5\n");
193
194 // Print out PERL5 specific headers
195
196 headers();
197
198 // Run the parser
199
200 yyparse();
201 fputs(vinit.get(),f_wrappers);
202}
203
204
205// ---------------------------------------------------------------------
206// PERL5::set_module(char *mod_name, char **mod_list)
207//
208// Sets the module name.
209// Does nothing if it's already set (so it can be overridden as a command
210// line option).
211//
212//----------------------------------------------------------------------
213static String modinit, modextern;
214
215void PERL5::set_module(char *mod_name, char **mod_list) {
216 int i;
217 if (import_file) {
218 if (!(strcmp(import_file,input_file+strlen(input_file)-strlen(import_file)))) {
219 if (blessed) {
220 fprintf(f_pm,"require %s;\n", mod_name);
221 }
222 delete [] import_file;
223 import_file = 0;
224 }
225 }
226
227 if (module) return;
228
229 module = new char[strlen(mod_name)+1];
230 strcpy(module,mod_name);
231
232 // if there was a mod_list specified, make this big hack
233 if (mod_list) {
234 modinit << "#define SWIGMODINIT ";
235 modextern << "#ifdef __cplusplus\n"
236 << "extern \"C\" {\n"
237 << "#endif\n";
238 i = 0;
239 while(mod_list[i]) {
240 modinit << "newXS(\"" << mod_list[i] << "::boot_" << mod_list[i] << "\", boot_" << mod_list[i] << ", file);\\\n";
241 modextern << "extern void boot_" << mod_list[i] << "(CV *);\n";
242 i++;
243 }
244 modextern << "#ifdef __cplusplus\n"
245 << "}\n"
246 << "#endif\n";
247 modinit << "/* End of extern module initialization */\n";
248 }
249
250 // Create a C module name and put it in 'cmodule'
251
252 cmodule = module;
253 cmodule.replace(":","_");
254}
255
256// ---------------------------------------------------------------------
257// PERL5::set_init(char *iname)
258//
259// Sets the initialization function name.
260// Does nothing if it's already set
261//
262//----------------------------------------------------------------------
263
264void PERL5::set_init(char *iname) {
265 set_module(iname,0);
266}
267
268// ---------------------------------------------------------------------
269// PERL5::headers(void)
270//
271// Generate the appropriate header files for PERL5 interface.
272// ----------------------------------------------------------------------
273
274void PERL5::headers(void)
275{
276
277 emit_banner(f_header);
278
279 if (!alt_header) {
280 if (insert_file("headers.swg", f_header) == -1) {
281 fprintf(stderr,"Perl5 : Fatal error. Unable to locate headers.swg. Possible installation problem.\n");
282 SWIG_exit(1);
283 }
284 } else {
285 if (insert_file(alt_header, f_header) == -1) {
286 fprintf(stderr,"SWIG : Fatal error. Unable to locate %s.\n",alt_header);
287 SWIG_exit(1);
288 }
289 }
290
291 if (NoInclude) {
292 fprintf(f_header,"#define SWIG_NOINCLUDE\n");
293 }
294
295 // Get special SWIG related declarations
296 if (insert_file("perl5.swg", f_header) == -1) {
297 fprintf(stderr,"SWIG : Fatal error. Unable to locate 'perl5.swg' in SWIG library.\n");
298 SWIG_exit(1);
299 }
300
301 // Get special SWIG related declarations
302 if (insert_file("perl5mg.swg", f_header) == -1) {
303 fprintf(stderr,"SWIG : Fatal error. Unable to locate 'perl5mg.swg' in SWIG library.\n");
304 SWIG_exit(1);
305 }
306
307}
308
309// --------------------------------------------------------------------
310// PERL5::initialize()
311//
312// Output initialization code that registers functions with the
313// interface.
314// ---------------------------------------------------------------------
315
316void PERL5::initialize()
317{
318
319 char filen[256];
320
321 if (!module){
322 module = "swig";
323 fprintf(stderr,"SWIG : *** Warning. No module name specified.\n");
324 }
325
326 if (!package) {
327 package = new char[strlen(module)+1];
328 strcpy(package,module);
329 }
330
331 // If we're in blessed mode, change the package name to "packagec"
332
333 if (blessed) {
334 char *newpackage = new char[strlen(package)+2];
335 sprintf(newpackage,"%sc",package);
336 realpackage = package;
337 package = newpackage;
338 } else {
339 realpackage = package;
340 }
341
342 // Create a .pm file
343 // Need to strip off any prefixes that might be found in
344 // the module name
345
346 {
347 char *m = module + strlen(module);
348 while (m != module) {
349 if (*m == ':') {
350 m++;
351 break;
352 }
353 m--;
354 }
355 sprintf(filen,"%s%s.pm", output_dir,m);
356 if ((f_pm = fopen(filen,"w")) == 0) {
357 fprintf(stderr,"Unable to open %s\n", filen);
358 SWIG_exit(0);
359 }
360 }
361 if (!blessed) {
362 smodule = module;
363 } else if (is_static) {
364 smodule = new char[strlen(module)+2];
365 strcpy(smodule,module);
366 strcat(smodule,"c");
367 cmodule << "c";
368 } else {
369 smodule = module;
370 }
371
372 fprintf(f_header,"#define SWIG_init boot_%s\n\n", cmodule.get());
373 fprintf(f_header,"#define SWIG_name \"%s::boot_%s\"\n", package, cmodule.get());
374 fprintf(f_header,"#define SWIG_varinit \"%s::var_%s_init();\"\n", package, cmodule.get());
375 fprintf(f_header,"#ifdef __cplusplus\n");
376 fprintf(f_header,"extern \"C\"\n");
377 fprintf(f_header,"#endif\n");
378 fprintf(f_header,"#ifndef PERL_OBJECT\n");
379 fprintf(f_header,"SWIGEXPORT(void) boot_%s(CV* cv);\n", cmodule.get());
380 fprintf(f_header,"#else\n");
381 fprintf(f_header,"SWIGEXPORT(void) boot_%s(CV *cv, CPerlObj *);\n",cmodule.get());
382 fprintf(f_header,"#endif\n");
383 fprintf(f_init,"#ifdef __cplusplus\n");
384 fprintf(f_init,"extern \"C\"\n");
385 fprintf(f_init,"#endif\n");
386 fprintf(f_init,"XS(boot_%s) {\n", cmodule.get());
387 fprintf(f_init,"\t dXSARGS;\n");
388 fprintf(f_init,"\t char *file = __FILE__;\n");
389 fprintf(f_init,"\t cv = cv; items = items;\n");
390 fprintf(f_init,"\t newXS(\"%s::var_%s_init\", _wrap_perl5_%s_var_init, file);\n",package,cmodule.get(), cmodule.get());
391 vinit << "XS(_wrap_perl5_" << cmodule << "_var_init) {\n"
392 << tab4 << "dXSARGS;\n"
393 << tab4 << "SV *sv;\n"
394 << tab4 << "cv = cv; items = items;\n";
395
396 fprintf(f_pm,"# This file was automatically generated by SWIG\n");
397 fprintf(f_pm,"package %s;\n",module);
398 fprintf(f_pm,"require Exporter;\n");
399 if (!is_static) {
400 fprintf(f_pm,"require DynaLoader;\n");
401 fprintf(f_pm,"@ISA = qw(Exporter DynaLoader);\n");
402 } else {
403 fprintf(f_pm,"@ISA = qw(Exporter);\n");
404 }
405
406 // Start creating magic code
407
408
409 magic << "#ifdef PERL_OBJECT\n"
410 << "#define MAGIC_CLASS _wrap_" << module << "_var::\n"
411 << "class _wrap_" << module << "_var : public CPerlObj {\n"
412 << "public:\n"
413 << "#else\n"
414 << "#define MAGIC_CLASS\n"
415 << "#endif\n"
416 << "SWIGCLASS_STATIC int swig_magic_readonly(SV *sv, MAGIC *mg) {\n"
417 << tab4 << "MAGIC_PPERL\n"
418 << tab4 << "sv = sv; mg = mg;\n"
419 << tab4 << "croak(\"Value is read-only.\");\n"
420 << tab4 << "return 0;\n"
421 << "}\n"; // Dump out external module declarations
422
423 /* Process additional initialization files here */
424
425 if (strlen(modinit.get()) > 0) {
426 fprintf(f_header,"%s\n",modinit.get());
427 }
428 if (strlen(modextern.get()) > 0) {
429 fprintf(f_header,"%s\n",modextern.get());
430 }
431}
432
433// ---------------------------------------------------------------------
434// PERL5::import(char *filename)
435//
436// Import directive
437// ---------------------------------------------------------------------
438
439void PERL5::import(char *filename) {
440 if (import_file) delete [] import_file;
441 import_file = copy_string(filename);
442}
443
444
445// ---------------------------------------------------------------------
446// PERL5::close(void)
447//
448// Wrap things up. Close initialization function.
449// ---------------------------------------------------------------------
450
451void PERL5::close(void)
452{
453 String base;
454
455 // Dump out variable wrappers
456
457 magic << "\n\n#ifdef PERL_OBJECT\n"
458 << "};\n"
459 << "#endif\n";
460
461 fprintf(f_header,"%s\n", magic.get());
462
463 emit_ptr_equivalence(f_init);
464
465 fprintf(f_init,"\t ST(0) = &PL_sv_yes;\n");
466 fprintf(f_init,"\t XSRETURN(1);\n");
467 fprintf(f_init,"}\n");
468
469 vinit << tab4 << "XSRETURN(1);\n"
470 << "}\n";
471
472 fprintf(f_pm,"package %s;\n", package);
473
474 if (!is_static) {
475 fprintf(f_pm,"bootstrap %s;\n", smodule);
476 } else {
477 fprintf(f_pm,"boot_%s();\n", smodule);
478 }
479 fprintf(f_pm,"var_%s_init();\n", cmodule.get());
480 fprintf(f_pm,"%s",pragma_include.get());
481 fprintf(f_pm,"package %s;\n", realpackage);
482 fprintf(f_pm,"@EXPORT = qw(%s );\n",exported.get());
483
484 if (blessed) {
485
486 base << "\n# ---------- BASE METHODS -------------\n\n"
487 << "package " << realpackage << ";\n\n";
488
489 // Write out the TIE method
490
491 base << "sub TIEHASH {\n"
492 << tab4 << "my ($classname,$obj) = @_;\n"
493 << tab4 << "return bless $obj, $classname;\n"
494 << "}\n\n";
495
496 // Output a CLEAR method. This is just a place-holder, but by providing it we
497 // can make declarations such as
498 // %$u = ( x => 2, y=>3, z =>4 );
499 //
500 // Where x,y,z are the members of some C/C++ object.
501
502 base << "sub CLEAR { }\n\n";
503
504 // Output default firstkey/nextkey methods
505
506 base << "sub FIRSTKEY { }\n\n";
507 base << "sub NEXTKEY { }\n\n";
508
509 // Output a 'this' method
510
511 base << "sub this {\n"
512 << tab4 << "my $ptr = shift;\n"
513 << tab4 << "return tied(%$ptr);\n"
514 << "}\n\n";
515
516 fprintf(f_pm,"%s",base.get());
517
518 // Emit function stubs for stand-alone functions
519
520 fprintf(f_pm,"\n# ------- FUNCTION WRAPPERS --------\n\n");
521 fprintf(f_pm,"package %s;\n\n",realpackage);
522 fprintf(f_pm,"%s",func_stubs.get());
523
524
525 // Emit package code for different classes
526
527 fprintf(f_pm,"%s",pm.get());
528
529 // Emit variable stubs
530
531 fprintf(f_pm,"\n# ------- VARIABLE STUBS --------\n\n");
532 fprintf(f_pm,"package %s;\n\n",realpackage);
533 fprintf(f_pm,"%s",var_stubs.get());
534
535 }
536
537 fprintf(f_pm,"1;\n");
538 fclose(f_pm);
539
540 // Patch up documentation title
541
542 if ((doc_entry) && (module)) {
543 doc_entry->cinfo << "Module : " << module << ", "
544 << "Package : " << realpackage;
545 }
546
547}
548
549// ----------------------------------------------------------------------
550// char *PERL5::type_mangle(DataType *t)
551//
552// Mangles a datatype into a Perl5 name compatible with xsubpp type
553// T_PTROBJ.
554// ----------------------------------------------------------------------
555
556char *
557PERL5::type_mangle(DataType *t) {
558 static char result[128];
559 int i;
560 char *r, *c;
561
562 if (blessed) {
563
564 // Check to see if we've blessed this datatype
565
566 if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
567
568 // This is a blessed class. Return just the type-name
569 strcpy(result,(char *) classes.lookup(t->name));
570 return result;
571 }
572 }
573
574 r = result;
575 c = t->name;
576
577 for ( c = t->name; *c; c++,r++) {
578 *r = *c;
579 }
580 for (i = 0; i < (t->is_pointer-t->implicit_ptr); i++, r++) {
581 strcpy(r,"Ptr");
582 r+=2;
583 }
584 *r = 0;
585 return result;
586}
587
588// ----------------------------------------------------------------------
589// PERL5::get_pointer(char *iname, char *srcname, char *src, char *target,
590// DataType *t, String &f, char *ret)
591//
592// Emits code to get a pointer from a parameter and do type checking.
593// ----------------------------------------------------------------------
594
595void PERL5::get_pointer(char *iname, char *srcname, char *src, char *dest,
596 DataType *t, String &f, char *ret) {
597
598 // Now get the pointer value from the string and save in dest
599
600 f << tab4 << "if (SWIG_GetPtr(" << src << ",(void **) &" << dest << ",";
601
602 // If we're passing a void pointer, we give the pointer conversion a NULL
603 // pointer, otherwise pass in the expected type.
604
605 if (t->type == T_VOID) f << "(char *) 0 )) {\n";
606 else
607 f << "\"" << t->print_mangle() << "\")) {\n";
608
609 // This part handles the type checking according to three different
610 // levels. 0 = no checking, 1 = warning message, 2 = strict.
611
612 switch(TypeStrict) {
613 case 0: // No type checking
614 f << tab4 << "}\n";
615 break;
616
617 case 1: // Warning message only
618
619 // Change this part to how you want to handle a type-mismatch warning.
620 // By default, it will just print to stderr.
621
622 f << tab8 << "fprintf(stderr,\"Warning : type mismatch in " << srcname
623 << " of " << iname << ". Expected " << t->print_mangle()
624 << ", received %s\\n\"," << src << ");\n"
625 << tab4 << "}\n";
626
627 break;
628 case 2: // Super strict mode.
629
630 // Change this part to return an error.
631
632 f << tab8 << "croak(\"Type error in " << srcname
633 << " of " << iname << ". Expected " << t->print_mangle() << ".\");\n"
634 << tab8 << ret << ";\n"
635 << tab4 << "}\n";
636
637 break;
638
639 default :
640 fprintf(stderr,"SWIG Error. Unknown strictness level\n");
641 break;
642 }
643}
644
645// ----------------------------------------------------------------------
646// PERL5::create_command(char *cname, char *iname)
647//
648// Create a command and register it with the interpreter
649// ----------------------------------------------------------------------
650
651void PERL5::create_command(char *cname, char *iname) {
652 fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, name_wrapper(cname,""));
653 if (export_all) {
654 exported << iname << " ";
655 }
656}
657
658// ----------------------------------------------------------------------
659// PERL5::create_function(char *name, char *iname, DataType *d,
660// ParmList *l)
661//
662// Create a function declaration and register it with the interpreter.
663// ----------------------------------------------------------------------
664
665void PERL5::create_function(char *name, char *iname, DataType *d, ParmList *l)
666{
667 Parm *p;
668 int pcount,i,j;
669 char *wname;
670 char *usage = 0;
671 WrapperFunction f;
672 char source[256],target[256],temp[256], argnum[32];
673 char *tm;
674 String cleanup,outarg,build;
675 int numopt = 0;
676 int need_save, num_saved = 0; // Number of saved arguments.
677 int have_build = 0;
678
679 // Make a wrapper name for this
680
681 wname = name_wrapper(iname,"");
682
683 // Now write the wrapper function itself....this is pretty ugly
684
685 f.def << "XS(" << wname << ") {\n";
686 f.code << tab4 << "cv = cv;\n";
687
688 pcount = emit_args(d, l, f);
689 numopt = l->numopt();
690
691 f.add_local("int","argvi = 0");
692
693 // Check the number of arguments
694
695 usage = usage_func(iname,d,l);
696 f.code << tab4 << "if ((items < " << (pcount-numopt) << ") || (items > " << l->numarg() << ")) \n"
697 << tab8 << "croak(\"Usage: " << usage << "\");\n";
698
699 // Write code to extract parameters.
700 // This section should be able to extract virtually any kind
701 // parameter, represented as a string
702
703 i = 0;
704 j = 0;
705 p = l->get_first();
706 while (p != 0) {
707 // Produce string representation of source and target arguments
708 sprintf(source,"ST(%d)",j);
709 sprintf(target,"_arg%d",i);
710 sprintf(argnum,"%d",j+1);
711
712 // Check to see if this argument is being ignored
713
714 if (!p->ignore) {
715
716 // If there are optional arguments, check for this
717
718 if (j>= (pcount-numopt))
719 f.code << tab4 << "if (items > " << j << ") {\n";
720
721 // See if there is a type-map
722 if ((tm = typemap_lookup("in","perl5",p->t,p->name,source,target,&f))) {
723 f.code << tm << "\n";
724 f.code.replace("$argnum",argnum);
725 f.code.replace("$arg",source);
726 } else {
727
728 if (!p->t->is_pointer) {
729
730 // Extract a parameter by "value"
731
732 switch(p->t->type) {
733
734 // Integers
735
736 case T_BOOL:
737 case T_INT :
738 case T_SHORT :
739 case T_LONG :
740 case T_SINT :
741 case T_SSHORT:
742 case T_SLONG:
743 case T_SCHAR:
744 case T_UINT:
745 case T_USHORT:
746 case T_ULONG:
747 case T_UCHAR:
748 f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
749 << "SvIV(ST(" << j << "));\n";
750 break;
751 case T_CHAR :
752
753
754
755 f.code << tab4 << "_arg" << i << " = (char) *SvPV(ST(" << j << "),PL_na);\n";
756 break;
757
758 // Doubles
759
760 case T_DOUBLE :
761 case T_FLOAT :
762 f.code << tab4 << "_arg" << i << " = " << p->t->print_cast()
763 << " SvNV(ST(" << j << "));\n";
764 break;
765
766 // Void.. Do nothing.
767
768 case T_VOID :
769 break;
770
771 // User defined. This is invalid here. Note, user-defined types by
772 // value are handled in the parser.
773
774 case T_USER:
775
776 // Unsupported data type
777
778 default :
779 fprintf(stderr,"%s : Line %d. Unable to use type %s as a function argument.\n",input_file, line_number, p->t->print_type());
780 break;
781 }
782 } else {
783
784 // Argument is a pointer type. Special case is for char *
785 // since that is usually a string.
786
787 if ((p->t->type == T_CHAR) && (p->t->is_pointer == 1)) {
788 f.code << tab4 << "if (! SvOK((SV*) ST(" << j << "))) { "
789 << "_arg" << i << " = 0; }\n";
790 f.code << tab4 << "else { _arg"
791 << i << " = (char *) SvPV(ST(" << j << "),PL_na); }\n";
792 } else {
793
794 // Have a generic pointer type here. Read it in as a swig
795 // typed pointer.
796
797 sprintf(temp,"argument %d", i+1);
798 get_pointer(iname,temp,source,target, p->t, f.code, "XSRETURN(1)");
799 }
800 }
801 }
802 // The source is going to be an array of saved values.
803
804 sprintf(temp,"_saved[%d]",num_saved);
805 if (j>= (pcount-numopt))
806 f.code << tab4 << "} \n";
807 j++;
808 } else {
809 temp[0] = 0;
810 }
811 // Check to see if there is any sort of "build" typemap (highly complicated)
812
813 if ((tm = typemap_lookup("build","perl5",p->t,p->name,source,target))) {
814 build << tm << "\n";
815 have_build = 1;
816 }
817
818 // Check if there is any constraint code
819 if ((tm = typemap_lookup("check","perl5",p->t,p->name,source,target))) {
820 f.code << tm << "\n";
821 f.code.replace("$argnum",argnum);
822 }
823 need_save = 0;
824
825 if ((tm = typemap_lookup("freearg","perl5",p->t,p->name,target,temp))) {
826 cleanup << tm << "\n";
827 cleanup.replace("$argnum",argnum);
828 cleanup.replace("$arg",temp);
829 need_save = 1;
830 }
831 if ((tm = typemap_lookup("argout","perl5",p->t,p->name,target,"ST(argvi)"))) {
832 String tempstr;
833 tempstr = tm;
834 tempstr.replace("$argnum",argnum);
835 tempstr.replace("$arg",temp);
836 outarg << tempstr << "\n";
837 need_save = 1;
838 }
839 // If we needed a saved variable, we need to emit to emit some code for that
840 // This only applies if the argument actually existed (not ignore)
841 if ((need_save) && (!p->ignore)) {
842 f.code << tab4 << temp << " = " << source << ";\n";
843 num_saved++;
844 }
845 p = l->get_next();
846 i++;
847 }
848
849 // If there were any saved arguments, emit a local variable for them
850
851 if (num_saved) {
852 sprintf(temp,"_saved[%d]",num_saved);
853 f.add_local("SV *",temp);
854 }
855
856 // If there was a "build" typemap, we need to go in and perform a serious hack
857
858 if (have_build) {
859 char temp1[32];
860 char temp2[256];
861 l->sub_parmnames(build); // Replace all parameter names
862 j = 1;
863 for (i = 0; i < l->nparms; i++) {
864 p = l->get(i);
865 if (strlen(p->name) > 0) {
866 sprintf(temp1,"_in_%s", p->name);
867 } else {
868 sprintf(temp1,"_in_arg%d", i);
869 }
870 sprintf(temp2,"argv[%d]",j);
871 build.replaceid(temp1,temp2);
872 if (!p->ignore)
873 j++;
874 }
875 f.code << build;
876 }
877
878 // Now write code to make the function call
879
880 emit_func_call(name,d,l,f);
881
882 // See if there was a typemap
883
884 if ((tm = typemap_lookup("out","perl5",d,iname,"_result","ST(argvi)"))) {
885 // Yep. Use it instead of the default
886 f.code << tm << "\n";
887 } else if ((d->type != T_VOID) || (d->is_pointer)) {
888 if (!d->is_pointer) {
889
890 // Function returns a "value"
891 f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
892 switch(d->type) {
893 case T_INT: case T_BOOL: case T_SINT: case T_UINT:
894 case T_SHORT: case T_SSHORT: case T_USHORT:
895 case T_LONG : case T_SLONG : case T_ULONG:
896 case T_SCHAR: case T_UCHAR :
897 f.code << tab4 << "sv_setiv(ST(argvi++),(IV) _result);\n";
898 break;
899 case T_DOUBLE :
900 case T_FLOAT :
901 f.code << tab4 << "sv_setnv(ST(argvi++), (double) _result);\n";
902 break;
903 case T_CHAR :
904 f.add_local("char", "_ctemp[2]");
905 f.code << tab4 << "_ctemp[0] = _result;\n"
906 << tab4 << "_ctemp[1] = 0;\n"
907 << tab4 << "sv_setpv((SV*)ST(argvi++),_ctemp);\n";
908 break;
909
910 // Return a complex type by value
911
912 case T_USER:
913 d->is_pointer++;
914 f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
915 << "\", (void *) _result);\n";
916 d->is_pointer--;
917 break;
918
919 default :
920 fprintf(stderr,"%s: Line %d. Unable to use return type %s in function %s.\n", input_file, line_number, d->print_type(), name);
921 break;
922 }
923 } else {
924
925 // Is a pointer return type
926 f.code << tab4 << "ST(argvi) = sv_newmortal();\n";
927 if ((d->type == T_CHAR) && (d->is_pointer == 1)) {
928
929 // Return a character string
930 f.code << tab4 << "sv_setpv((SV*)ST(argvi++),(char *) _result);\n";
931
932 } else {
933 // Is an ordinary pointer type.
934 f.code << tab4 << "sv_setref_pv(ST(argvi++),\"" << d->print_mangle()
935 << "\", (void *) _result);\n";
936 }
937 }
938 }
939
940 // If there were any output args, take care of them.
941
942 f.code << outarg;
943
944 // If there was any cleanup, do that.
945
946 f.code << cleanup;
947
948 if (NewObject) {
949 if ((tm = typemap_lookup("newfree","perl5",d,iname,"_result",""))) {
950 f.code << tm << "\n";
951 }
952 }
953
954 if ((tm = typemap_lookup("ret","perl5",d,iname,"_result",""))) {
955 // Yep. Use it instead of the default
956 f.code << tm << "\n";
957 }
958
959 // Wrap things up (in a manner of speaking)
960
961 f.code << tab4 << "XSRETURN(argvi);\n}\n";
962
963 // Add the dXSARGS last
964
965 f.add_local("dXSARGS","");
966
967 // Substitute the cleanup code
968 f.code.replace("$cleanup",cleanup);
969 f.code.replace("$name",iname);
970
971 // Dump this function out
972
973 f.print(f_wrappers);
974
975 // Create a first crack at a documentation entry
976
977 if (doc_entry) {
978 static DocEntry *last_doc_entry = 0;
979 doc_entry->usage << usage;
980 if (last_doc_entry != doc_entry) {
981 doc_entry->cinfo << "returns " << d->print_type();
982 last_doc_entry = doc_entry;
983 }
984 }
985
986 // Now register the function
987
988 fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package, iname, wname);
989
990 if (export_all) {
991 exported << iname << " ";
992 }
993
994
995 // --------------------------------------------------------------------
996 // Create a stub for this function, provided it's not a member function
997 //
998 // Really we only need to create a stub if this function involves
999 // complex datatypes. If it does, we'll make a small wrapper to
1000 // process the arguments. If it doesn't, we'll just make a symbol
1001 // table entry.
1002 // --------------------------------------------------------------------
1003
1004 if ((blessed) && (!member_func)) {
1005 int need_stub = 0;
1006 String func;
1007
1008 // We'll make a stub since we may need it anyways
1009
1010 func << "sub " << iname << " {\n"
1011 << tab4 << "my @args = @_;\n";
1012
1013
1014 // Now we have to go through and patch up the argument list. If any
1015 // arguments to our function correspond to other Perl objects, we
1016 // need to extract them from a tied-hash table object.
1017
1018 Parm *p = l->get_first();
1019 int i = 0;
1020 while(p) {
1021
1022 if (!p->ignore) {
1023 // Look up the datatype name here
1024
1025 if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
1026 if (i >= (pcount - numopt))
1027 func << tab4 << "if (scalar(@args) >= " << i << ") {\n" << tab4;
1028
1029 func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
1030
1031 if (i >= (pcount - numopt))
1032 func << tab4 << "}\n";
1033
1034 need_stub = 1;
1035 }
1036 i++;
1037 }
1038 p = l->get_next();
1039 }
1040
1041 func << tab4 << "my $result = " << package << "::" << iname << "(@args);\n";
1042
1043 // Now check to see what kind of return result was found.
1044 // If this function is returning a result by 'value', SWIG did an
1045 // implicit malloc/new. We'll mark the object like it was created
1046 // in Perl so we can garbage collect it.
1047
1048 if ((classes.lookup(d->name)) && (d->is_pointer <=1)) {
1049
1050 func << tab4 << "return undef if (!defined($result));\n";
1051
1052 // If we're returning an object by value, put it's reference
1053 // into our local hash table
1054
1055 if ((d->is_pointer == 0) || ((d->is_pointer == 1) && NewObject)) {
1056 func << tab4 << "$" << (char *) classes.lookup(d->name) << "::OWNER{$result} = 1;\n";
1057 }
1058
1059 // We're returning a Perl "object" of some kind. Turn it into
1060 // a tied hash
1061
1062 func << tab4 << "my %resulthash;\n"
1063 /* << tab4 << "tie %resulthash, \"" << (char *) classes.lookup(d->name) << "\", $result;\n"
1064 << tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(d->name) << "\";\n"
1065 */
1066 << tab4 << "tie %resulthash, ref($result), $result;\n"
1067 << tab4 << "return bless \\%resulthash, ref($result);\n"
1068 << "}\n";
1069
1070 need_stub = 1;
1071 } else {
1072
1073 // Hmmm. This doesn't appear to be anything I know about so just
1074 // return it unmolested.
1075
1076 func << tab4 <<"return $result;\n"
1077 << "}\n";
1078
1079 }
1080
1081 // Now check if we needed the stub. If so, emit it, otherwise
1082 // Emit code to hack Perl's symbol table instead
1083
1084 if (need_stub) {
1085 func_stubs << func;
1086 } else {
1087 func_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
1088 }
1089 }
1090}
1091
1092// -----------------------------------------------------------------------
1093// PERL5::link_variable(char *name, char *iname, DataType *d)
1094//
1095// Create a link to a C variable.
1096// -----------------------------------------------------------------------
1097
1098void PERL5::link_variable(char *name, char *iname, DataType *t)
1099{
1100 char set_name[256];
1101 char val_name[256];
1102 WrapperFunction getf, setf;
1103 char *tm;
1104 sprintf(set_name,"_wrap_set_%s",iname);
1105 sprintf(val_name,"_wrap_val_%s",iname);
1106
1107 // Create a new scalar that we will attach magic to
1108
1109 vinit << tab4 << "sv = perl_get_sv(\"" << package << "::" << iname << "\",TRUE | 0x2);\n";
1110
1111 // Create a Perl function for setting the variable value
1112
1113 if (!(Status & STAT_READONLY)) {
1114 setf.def << "SWIGCLASS_STATIC int " << set_name << "(SV* sv, MAGIC *mg) {\n";
1115
1116 setf.code << tab4 << "MAGIC_PPERL\n";
1117 setf.code << tab4 << "mg = mg;\n";
1118
1119 /* Check for a few typemaps */
1120 if ((tm = typemap_lookup("varin","perl5",t,"","sv",name))) {
1121 setf.code << tm << "\n";
1122 } else if ((tm = typemap_lookup("in","perl5",t,"","sv",name))) {
1123 setf.code << tm << "\n";
1124 } else {
1125 if (!t->is_pointer) {
1126
1127 // Set the value to something
1128
1129 switch(t->type) {
1130 case T_INT : case T_BOOL: case T_SINT : case T_UINT:
1131 case T_SHORT : case T_SSHORT : case T_USHORT:
1132 case T_LONG : case T_SLONG : case T_ULONG:
1133 case T_UCHAR: case T_SCHAR:
1134 setf.code << tab4 << name << " = " << t->print_cast() << " SvIV(sv);\n";
1135 break;
1136 case T_DOUBLE :
1137 case T_FLOAT :
1138 setf.code << tab4 << name << " = " << t->print_cast() << " SvNV(sv);\n";
1139 break;
1140 case T_CHAR :
1141 setf.code << tab4 << name << " = (char) *SvPV(sv,PL_na);\n";
1142 break;
1143
1144 case T_USER:
1145
1146 // Add support for User defined type here
1147 // Get as a pointer value
1148
1149 t->is_pointer++;
1150 setf.add_local("void","*_temp");
1151 get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
1152 setf.code << tab4 << name << " = *(" << t->print_cast() << " _temp);\n";
1153 t->is_pointer--;
1154 break;
1155
1156 default :
1157 fprintf(stderr,"%s : Line %d. Unable to link with datatype %s (ignored).\n", input_file, line_number, t->print_type());
1158 return;
1159 }
1160 } else {
1161 // Have some sort of pointer type here, Process it differently
1162 if ((t->type == T_CHAR) && (t->is_pointer == 1)) {
1163 setf.add_local("char","*_a");
1164 setf.code << tab4 << "_a = (char *) SvPV(sv,PL_na);\n";
1165
1166 if (CPlusPlus)
1167 setf.code << tab4 << "if (" << name << ") delete [] " << name << ";\n"
1168 << tab4 << name << " = new char[strlen(_a)+1];\n";
1169 else
1170 setf.code << tab4 << "if (" << name << ") free(" << name << ");\n"
1171 << tab4 << name << " = (char *) malloc(strlen(_a)+1);\n";
1172 setf.code << "strcpy(" << name << ",_a);\n";
1173 } else {
1174 // Set the value of a pointer
1175
1176 setf.add_local("void","*_temp");
1177 get_pointer(iname,"value","sv","_temp", t, setf.code, "return(1)");
1178 setf.code << tab4 << name << " = " << t->print_cast() << " _temp;\n";
1179 }
1180 }
1181 }
1182 setf.code << tab4 << "return 1;\n"
1183 << "}\n";
1184
1185 setf.code.replace("$name",iname);
1186 setf.print(magic);
1187
1188 }
1189
1190 // Now write a function to evaluate the variable
1191
1192 getf.def << "SWIGCLASS_STATIC int " << val_name << "(SV *sv, MAGIC *mg) {\n";
1193 getf.code << tab4 << "MAGIC_PPERL\n";
1194 getf.code << tab4 << "mg = mg;\n";
1195
1196 // Check for a typemap
1197
1198 if ((tm = typemap_lookup("varout","perl5",t,"",name, "sv"))) {
1199 getf.code << tm << "\n";
1200 } else if ((tm = typemap_lookup("out","perl5",t,"",name,"sv"))) {
1201 setf.code << tm << "\n";
1202 } else {
1203 if (!t->is_pointer) {
1204 switch(t->type) {
1205 case T_INT : case T_BOOL: case T_SINT: case T_UINT:
1206 case T_SHORT : case T_SSHORT: case T_USHORT:
1207 case T_LONG : case T_SLONG : case T_ULONG:
1208 case T_UCHAR: case T_SCHAR:
1209 getf.code << tab4 << "sv_setiv(sv, (IV) " << name << ");\n";
1210 vinit << tab4 << "sv_setiv(sv,(IV)" << name << ");\n";
1211 break;
1212 case T_DOUBLE :
1213 case T_FLOAT :
1214 getf.code << tab4 << "sv_setnv(sv, (double) " << name << ");\n";
1215 vinit << tab4 << "sv_setnv(sv,(double)" << name << ");\n";
1216 break;
1217 case T_CHAR :
1218 getf.add_local("char","_ptemp[2]");
1219 getf.code << tab4 << "_ptemp[0] = " << name << ";\n"
1220 << tab4 << "_ptemp[1] = 0;\n"
1221 << tab4 << "sv_setpv((SV*) sv, _ptemp);\n";
1222 break;
1223 case T_USER:
1224 t->is_pointer++;
1225 getf.code << tab4 << "rsv = SvRV(sv);\n"
1226 << tab4 << "sv_setiv(rsv,(IV) &" << name << ");\n";
1227
1228 // getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
1229 // << "\", (void *) &" << name << ");\n";
1230
1231 getf.add_local("SV","*rsv");
1232 vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) &" << name << ");\n";
1233 t->is_pointer--;
1234
1235 break;
1236 default :
1237 break;
1238 }
1239 } else {
1240
1241 // Have some sort of arbitrary pointer type. Return it as a string
1242
1243 if ((t->type == T_CHAR) && (t->is_pointer == 1))
1244 getf.code << tab4 << "sv_setpv((SV*) sv, " << name << ");\n";
1245 else {
1246 getf.code << tab4 << "rsv = SvRV(sv);\n"
1247 << tab4 << "sv_setiv(rsv,(IV) " << name << ");\n";
1248 getf.add_local("SV","*rsv");
1249 vinit << tab4 << "sv_setref_pv(sv,\"" << t->print_mangle() << "\",(void *) 1);\n";
1250
1251 //getf.code << tab4 << "sv_setref_pv((SV*) sv,\"" << t->print_mangle()
1252 // << "\", (void *) " << name << ");\n";
1253 }
1254 }
1255 }
1256 getf.code << tab4 << "return 1;\n"
1257 << "}\n";
1258
1259 getf.code.replace("$name",iname);
1260 getf.print(magic);
1261
1262 // Now add symbol to the PERL interpreter
1263 if (Status & STAT_READONLY) {
1264 vinit << tab4 << "swig_create_magic(sv,\"" << package << "::" << iname << "\",MAGIC_CAST MAGIC_CLASS swig_magic_readonly, MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
1265 } else {
1266 vinit << tab4 << "swig_create_magic(sv,\"" << package << "::" << iname << "\", MAGIC_CAST MAGIC_CLASS " << set_name << ", MAGIC_CAST MAGIC_CLASS " << val_name << ");\n";
1267 }
1268 // Add a documentation entry
1269
1270 if (doc_entry) {
1271 doc_entry->usage << usage_var(iname,t);
1272 doc_entry->cinfo << "Global : " << t->print_type() << " " << name;
1273 }
1274
1275 // If we're blessed, try to figure out what to do with the variable
1276 // 1. If it's a Perl object of some sort, create a tied-hash
1277 // around it.
1278 // 2. Otherwise, just hack Perl's symbol table
1279
1280 if (blessed) {
1281 if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
1282 var_stubs << "\nmy %__" << iname << "_hash;\n"
1283 << "tie %__" << iname << "_hash,\"" << (char *) classes.lookup(t->name) << "\", $"
1284 << package << "::" << iname << ";\n"
1285 << "$" << iname << "= \\%__" << iname << "_hash;\n"
1286 << "bless $" << iname << ", " << (char *) classes.lookup(t->name) << ";\n";
1287 } else {
1288 var_stubs << "*" << iname << " = *" << package << "::" << iname << ";\n";
1289 }
1290 if (export_all)
1291 exported << "$" << name << " ";
1292 }
1293}
1294
1295// -----------------------------------------------------------------------
1296// PERL5::declare_const(char *name, char *iname, DataType *type, char *value)
1297//
1298// Makes a constant. Really just creates a variable and creates a read-only
1299// link to it.
1300// ------------------------------------------------------------------------
1301
1302// Functions used to create constants
1303
1304static const char *setiv = "#ifndef PERL_OBJECT\
1305\n#define swig_setiv(a,b) _swig_setiv(a,b)\
1306\nstatic void _swig_setiv(char *name, long value) { \
1307\n#else\
1308\n#define swig_setiv(a,b) _swig_setiv(pPerl,a,b)\
1309\nstatic void _swig_setiv(CPerlObj *pPerl, char *name, long value) { \
1310\n#endif\
1311\n SV *sv; \
1312\n sv = perl_get_sv(name,TRUE | 0x2);\
1313\n sv_setiv(sv, (IV) value);\
1314\n SvREADONLY_on(sv);\
1315\n}\n";
1316
1317static const char *setnv = "#ifndef PERL_OBJECT\
1318\n#define swig_setnv(a,b) _swig_setnv(a,b)\
1319\nstatic void _swig_setnv(char *name, double value) { \
1320\n#else\
1321\n#define swig_setnv(a,b) _swig_setnv(pPerl,a,b)\
1322\nstatic void _swig_setnv(CPerlObj *pPerl, char *name, double value) { \
1323\n#endif\
1324\n SV *sv; \
1325\n sv = perl_get_sv(name,TRUE | 0x2);\
1326\n sv_setnv(sv, value);\
1327\n SvREADONLY_on(sv);\
1328\n}\n";
1329
1330static const char *setpv = "#ifndef PERL_OBJECT\
1331\n#define swig_setpv(a,b) _swig_setpv(a,b)\
1332\nstatic void _swig_setpv(char *name, char *value) { \
1333\n#else\
1334\n#define swig_setpv(a,b) _swig_setpv(pPerl,a,b)\
1335\nstatic void _swig_setpv(CPerlObj *pPerl, char *name, char *value) { \
1336\n#endif\
1337\n SV *sv; \
1338\n sv = perl_get_sv(name,TRUE | 0x2);\
1339\n sv_setpv(sv, value);\
1340\n SvREADONLY_on(sv);\
1341\n}\n";
1342
1343static const char *setrv = "#ifndef PERL_OBJECT\
1344\n#define swig_setrv(a,b,c) _swig_setrv(a,b,c)\
1345\nstatic void _swig_setrv(char *name, void *value, char *type) { \
1346\n#else\
1347\n#define swig_setrv(a,b,c) _swig_setrv(pPerl,a,b,c)\
1348\nstatic void _swig_setrv(CPerlObj *pPerl, char *name, void *value, char *type) { \
1349\n#endif\
1350\n SV *sv; \
1351\n sv = perl_get_sv(name,TRUE | 0x2);\
1352\n sv_setref_pv(sv, type, value);\
1353\n SvREADONLY_on(sv);\
1354\n}\n";
1355
1356void
1357PERL5::declare_const(char *name, char *, DataType *type, char *value)
1358 {
1359
1360 char *tm;
1361 static int have_int_func = 0;
1362 static int have_double_func = 0;
1363 static int have_char_func = 0;
1364 static int have_ref_func = 0;
1365
1366 if ((tm = typemap_lookup("const","perl5",type,name,value,name))) {
1367 fprintf(f_init,"%s\n",tm);
1368 } else {
1369 if ((type->type == T_USER) && (!type->is_pointer)) {
1370 fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
1371 return;
1372 }
1373 // Generate a constant
1374 // vinit << tab4 << "sv = perl_get_sv(\"" << package << "::" << name << "\",TRUE);\n";
1375 if (type->is_pointer == 0) {
1376 switch(type->type) {
1377 case T_INT:case T_SINT: case T_UINT: case T_BOOL:
1378 case T_SHORT: case T_SSHORT: case T_USHORT:
1379 case T_LONG: case T_SLONG: case T_ULONG:
1380 case T_SCHAR: case T_UCHAR:
1381 if (!have_int_func) {
1382 fprintf(f_header,"%s\n",setiv);
1383 have_int_func = 1;
1384 }
1385 vinit << tab4 << "swig_setiv(\"" << package << "::" << name << "\", (long) " << value << ");\n";
1386 break;
1387 case T_DOUBLE:
1388 case T_FLOAT:
1389 if (!have_double_func) {
1390 fprintf(f_header,"%s\n",setnv);
1391 have_double_func = 1;
1392 }
1393 vinit << tab4 << "swig_setnv(\"" << package << "::" << name << "\", (double) (" << value << "));\n";
1394 break;
1395 case T_CHAR :
1396 if (!have_char_func) {
1397 fprintf(f_header,"%s\n",setpv);
1398 have_char_func = 1;
1399 }
1400 vinit << tab4 << "swig_setpv(\"" << package << "::" << name << "\", \"" << value << "\");\n";
1401 break;
1402 default:
1403 fprintf(stderr,"%s : Line %d. Unsupported constant value.\n", input_file, line_number);
1404 break;
1405 }
1406 } else {
1407 if ((type->type == T_CHAR) && (type->is_pointer == 1)) {
1408 if (!have_char_func) {
1409 fprintf(f_header,"%s\n",setpv);
1410 have_char_func = 1;
1411 }
1412 vinit << tab4 << "swig_setpv(\"" << package << "::" << name << "\", \"" << value << "\");\n";
1413 } else {
1414 // A user-defined type. We're going to munge it into a string pointer value
1415 if (!have_ref_func) {
1416 fprintf(f_header,"%s\n",setrv);
1417 have_ref_func = 1;
1418 }
1419 vinit << tab4 << "swig_setrv(\"" << package << "::" << name << "\", (void *) " << value << ", \""
1420 << type->print_mangle() << "\");\n";
1421 }
1422 }
1423 }
1424
1425 // Patch up the documentation entry
1426
1427 if (doc_entry) {
1428 doc_entry->usage = "";
1429 doc_entry->usage << usage_const(name,type,value);
1430 doc_entry->cinfo = "";
1431 doc_entry->cinfo << "Constant: " << type->print_type();
1432 }
1433
1434 if (blessed) {
1435 if ((classes.lookup(type->name)) && (type->is_pointer <= 1)) {
1436 var_stubs << "\nmy %__" << name << "_hash;\n"
1437 << "tie %__" << name << "_hash,\"" << (char *) classes.lookup(type->name) << "\", $"
1438 << package << "::" << name << ";\n"
1439 << "$" << name << "= \\%__" << name << "_hash;\n"
1440 << "bless $" << name << ", " << (char *) classes.lookup(type->name) << ";\n";
1441 } else {
1442 var_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
1443 }
1444 }
1445 if (export_all)
1446 exported << "$" << name << " ";
1447}
1448
1449// ----------------------------------------------------------------------
1450// PERL5::usage_var(char *iname, DataType *t)
1451//
1452// Produces a usage string for a Perl 5 variable.
1453// ----------------------------------------------------------------------
1454
1455char *PERL5::usage_var(char *iname, DataType *) {
1456
1457 static char temp[1024];
1458 char *c;
1459
1460 sprintf(temp,"$%s", iname);
1461 c = temp + strlen(temp);
1462 return temp;
1463}
1464
1465// ---------------------------------------------------------------------------
1466// char *PERL5::usage_func(pkg, char *iname, DataType *t, ParmList *l)
1467//
1468// Produces a usage string for a function in Perl
1469// ---------------------------------------------------------------------------
1470
1471char *PERL5::usage_func(char *iname, DataType *, ParmList *l) {
1472
1473 static String temp;
1474 Parm *p;
1475 int i;
1476
1477 temp = "";
1478 temp << iname << "(";
1479
1480 /* Now go through and print parameters */
1481
1482 p = l->get_first();
1483 i = 0;
1484 while (p != 0) {
1485 if (!p->ignore) {
1486 /* If parameter has been named, use that. Otherwise, just print a type */
1487
1488 if ((p->t->type != T_VOID) || (p->t->is_pointer)) {
1489 if (strlen(p->name) > 0) {
1490 temp << p->name;
1491 } else {
1492 temp << p->t->print_type();
1493 }
1494 }
1495 i++;
1496 p = l->get_next();
1497 if (p)
1498 if (!p->ignore)
1499 temp << ",";
1500 } else {
1501 p = l->get_next();
1502 if (p)
1503 if ((i>0) && (!p->ignore))
1504 temp << ",";
1505 }
1506 }
1507 temp << ");";
1508 return temp.get();
1509}
1510
1511// ----------------------------------------------------------------------
1512// PERL5::usage_const(char *iname, DataType *type, char *value)
1513//
1514// Produces a usage string for a Perl 5 constant
1515// ----------------------------------------------------------------------
1516
1517char *PERL5::usage_const(char *iname, DataType *, char *value) {
1518
1519 static char temp[1024];
1520 if (value) {
1521 sprintf(temp,"$%s = %s", iname, value);
1522 } else {
1523 sprintf(temp,"$%s", iname);
1524 }
1525 return temp;
1526}
1527
1528// -----------------------------------------------------------------------
1529// PERL5::add_native(char *name, char *funcname)
1530//
1531// Add a native module name to Perl5.
1532// -----------------------------------------------------------------------
1533
1534void PERL5::add_native(char *name, char *funcname) {
1535 fprintf(f_init,"\t newXS(\"%s::%s\", %s, file);\n", package,name, funcname);
1536 if (export_all)
1537 exported << name << " ";
1538 if (blessed) {
1539 func_stubs << "*" << name << " = *" << package << "::" << name << ";\n";
1540 }
1541}
1542
1543/****************************************************************************
1544 *** OBJECT-ORIENTED FEATURES
1545 ****************************************************************************
1546 *** These extensions provide a more object-oriented interface to C++
1547 *** classes and structures. The code here is based on extensions
1548 *** provided by David Fletcher and Gary Holt.
1549 ***
1550 *** I have generalized these extensions to make them more general purpose
1551 *** and to resolve object-ownership problems.
1552 ***
1553 *** The approach here is very similar to the Python module :
1554 *** 1. All of the original methods are placed into a single
1555 *** package like before except that a 'c' is appended to the
1556 *** package name.
1557 ***
1558 *** 2. All methods and function calls are wrapped with a new
1559 *** perl function. While possibly inefficient this allows
1560 *** us to catch complex function arguments (which are hard to
1561 *** track otherwise).
1562 ***
1563 *** 3. Classes are represented as tied-hashes in a manner similar
1564 *** to Gary Holt's extension. This allows us to access
1565 *** member data.
1566 ***
1567 *** 4. Stand-alone (global) C functions are modified to take
1568 *** tied hashes as arguments for complex datatypes (if
1569 *** appropriate).
1570 ***
1571 *** 5. Global variables involving a class/struct is encapsulated
1572 *** in a tied hash.
1573 ***
1574 *** 6. Object ownership is maintained by having a hash table
1575 *** within in each package called "this". It is unlikely
1576 *** that C++ program will use this so it's a somewhat
1577 *** safe variable name.
1578 ***
1579 ****************************************************************************/
1580
1581static int class_renamed = 0;
1582static String fullclassname;
1583
1584// --------------------------------------------------------------------------
1585// PERL5::cpp_open_class(char *classname, char *rname, int strip)
1586//
1587// Opens a new C++ class or structure. Basically, this just records
1588// the class name and clears a few variables.
1589// --------------------------------------------------------------------------
1590
1591void PERL5::cpp_open_class(char *classname, char *rname, char *ctype, int strip) {
1592
1593 char temp[256];
1594 extern void typeeq_addtypedef(char *, char *);
1595
1596 // Register this with the default class handler
1597
1598 this->Language::cpp_open_class(classname, rname, ctype, strip);
1599
1600 if (blessed) {
1601 have_constructor = 0;
1602 have_destructor = 0;
1603 have_data_members = 0;
1604
1605 // If the class is being renamed to something else, use the renaming
1606
1607 if (rname) {
1608 class_name = copy_string(rname);
1609 class_renamed = 1;
1610 // Now things get even more hideous. Need to register an equivalence
1611 // between the renamed name and the new name. Yuck!
1612 // printf("%s %s\n", classname, rname);
1613 typeeq_addtypedef(classname,rname);
1614 typeeq_addtypedef(rname,classname);
1615 /*
1616 fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",classname,rname);
1617 fprintf(f_init,"\t SWIG_RegisterMapping(\"%s\",\"%s\",0);\n",rname,classname);
1618 */
1619 } else {
1620 class_name = copy_string(classname);
1621 class_renamed = 0;
1622 }
1623
1624 // A highly experimental feature. This is the fully qualified
1625 // name of the Perl class
1626
1627 if (!compat) {
1628 fullclassname = realpackage;
1629 fullclassname << "::" << class_name;
1630 } else {
1631 fullclassname = class_name;
1632 }
1633
1634 fullclassname = class_name;
1635
1636 real_classname = copy_string(classname);
1637 if (base_class) delete base_class;
1638 base_class = 0;
1639 class_type = copy_string(ctype);
1640 pcode = new String();
1641 blessedmembers = new String();
1642 member_keys = new String();
1643
1644 // Add some symbols to the hash tables
1645
1646 // classes.add(real_classname,copy_string(class_name)); /* Map original classname to class */
1647 classes.add(real_classname,copy_string(fullclassname)); /* Map original classname to class */
1648
1649 // Add full name of datatype to the hash table just in case the user uses it
1650
1651 sprintf(temp,"%s %s", class_type, fullclassname.get());
1652 // classes.add(temp,copy_string(class_name)); /* Map full classname to classs */
1653 }
1654}
1655
1656// -------------------------------------------------------------------------------
1657// PERL5::cpp_close_class()
1658//
1659// These functions close a class definition.
1660//
1661// This also sets up the hash table of classes we've seen go by.
1662// -------------------------------------------------------------------------------
1663
1664void PERL5::cpp_close_class() {
1665
1666 // We need to check to make sure we got constructors, and other
1667 // stuff here.
1668
1669 if (blessed) {
1670 pm << "\n############# Class : " << fullclassname << " ##############\n";
1671 pm << "\npackage " << fullclassname << ";\n";
1672
1673 // If we are inheriting from a base class, set that up
1674
1675 if (strcmp(class_name,realpackage))
1676 pm << "@ISA = qw( " << realpackage;
1677 else
1678 pm << "@ISA = qw( ";
1679
1680 if (base_class) {
1681 pm << " " << *base_class;
1682 }
1683 pm << " );\n";
1684
1685 // Dump out a hash table containing the pointers that we own
1686
1687 pm << "%OWNER = ();\n";
1688 if (have_data_members) {
1689 pm << "%BLESSEDMEMBERS = (\n"
1690 << blessedmembers->get()
1691 << ");\n\n";
1692 }
1693 if (have_data_members || have_destructor)
1694 pm << "%ITERATORS = ();\n";
1695
1696
1697 // Dump out the package methods
1698
1699 pm << *pcode;
1700 delete pcode;
1701
1702 // Output methods for managing ownership
1703
1704 pm << "sub DISOWN {\n"
1705 << tab4 << "my $self = shift;\n"
1706 << tab4 << "my $ptr = tied(%$self);\n"
1707 << tab4 << "delete $OWNER{$ptr};\n"
1708 << tab4 << "};\n\n"
1709 << "sub ACQUIRE {\n"
1710 << tab4 << "my $self = shift;\n"
1711 << tab4 << "my $ptr = tied(%$self);\n"
1712 << tab4 << "$OWNER{$ptr} = 1;\n"
1713 << tab4 << "};\n\n";
1714
1715 // Only output the following methods if a class has member data
1716
1717 if (have_data_members) {
1718
1719 // Output a FETCH method. This is actually common to all classes
1720 pm << "sub FETCH {\n"
1721 << tab4 << "my ($self,$field) = @_;\n"
1722 << tab4 << "my $member_func = \"" << package << "::" << name_get(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
1723 << tab4 << "my $val = &$member_func($self);\n"
1724 << tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
1725 << tab8 << "return undef if (!defined($val));\n"
1726 << tab8 << "my %retval;\n"
1727 << tab8 << "tie %retval,$BLESSEDMEMBERS{$field},$val;\n"
1728 << tab8 << "return bless \\%retval, $BLESSEDMEMBERS{$field};\n"
1729 << tab4 << "}\n"
1730 << tab4 << "return $val;\n"
1731 << "}\n\n";
1732
1733 // Output a STORE method. This is also common to all classes (might move to base class)
1734
1735 pm << "sub STORE {\n"
1736 << tab4 << "my ($self,$field,$newval) = @_;\n"
1737 << tab4 << "my $member_func = \"" << package << "::" << name_set(name_member("${field}",class_name,AS_IS),AS_IS) << "\";\n"
1738 << tab4 << "if (exists $BLESSEDMEMBERS{$field}) {\n"
1739 << tab8 << "&$member_func($self,tied(%{$newval}));\n"
1740 << tab4 << "} else {\n"
1741 << tab8 << "&$member_func($self,$newval);\n"
1742 << tab4 << "}\n"
1743 << "}\n\n";
1744
1745 // Output a FIRSTKEY method. This is to allow iteration over a structure's keys.
1746
1747 pm << "sub FIRSTKEY {\n"
1748 << tab4 << "my $self = shift;\n"
1749 << tab4 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
1750 << tab4 << "my $first = shift @{$ITERATORS{$self}};\n"
1751 << tab4 << "return $first;\n"
1752 << "}\n\n";
1753
1754 // Output a NEXTKEY method. This is the iterator so that each and keys works
1755
1756 pm << "sub NEXTKEY {\n"
1757 << tab4 << "my $self = shift;\n"
1758 << tab4 << "$nelem = scalar @{$ITERATORS{$self}};\n"
1759 << tab4 << "if ($nelem > 0) {\n"
1760 << tab8 << "my $member = shift @{$ITERATORS{$self}};\n"
1761 << tab8 << "return $member;\n"
1762 << tab4 << "} else {\n"
1763 << tab8 << "$ITERATORS{$self} = [" << member_keys->get() << "];\n"
1764 << tab8 << "return ();\n"
1765 << tab4 << "}\n"
1766 << "}\n\n";
1767 }
1768 }
1769}
1770
1771// --------------------------------------------------------------------------
1772// PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l)
1773//
1774// Handles a C++ member function. This basically does the same thing as
1775// the non-C++ version, but we set up a few status variables that affect
1776// the function generation function.
1777//
1778// --------------------------------------------------------------------------
1779
1780void PERL5::cpp_member_func(char *name, char *iname, DataType *t, ParmList *l) {
1781
1782 String func;
1783 char *realname;
1784 Parm *p;
1785 int i;
1786 String cname = "perl5:";
1787 int pcount, numopt;
1788
1789 // First emit normal member function
1790
1791 member_func = 1;
1792 this->Language::cpp_member_func(name,iname,t,l);
1793 member_func = 0;
1794
1795 if (!blessed) return;
1796
1797 // Now emit a Perl wrapper function around our member function, we might need
1798 // to patch up some arguments along the way
1799
1800 if (!iname)
1801 realname = name;
1802 else
1803 realname = iname;
1804
1805 cname << class_name << "::" << realname;
1806 if (add_symbol(cname.get(),0,0)) {
1807 return; // Forget it, we saw this function already
1808 }
1809
1810 func << "sub " << realname << " {\n"
1811 << tab4 << "my @args = @_;\n"
1812 << tab4 << "$args[0] = tied(%{$args[0]});\n";
1813
1814 // Now we have to go through and patch up the argument list. If any
1815 // arguments to our function correspond to other Perl objects, we
1816 // need to extract them from a tied-hash table object.
1817
1818 p = l->get_first();
1819 pcount = l->nparms;
1820 numopt = l->numopt();
1821 i = 1;
1822 while(p) {
1823 if (!p->ignore) {
1824
1825 // Look up the datatype name here
1826 if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
1827 // Yep. This smells alot like an object, patch up the arguments
1828
1829 if (i >= (pcount - numopt))
1830 func << tab4 << "if (scalar(@args) >= " << i << ") {\n";
1831
1832 func << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
1833
1834 if (i >= (pcount - numopt))
1835 func << tab4 << "}\n";
1836 }
1837 i++;
1838 }
1839 p = l->get_next();
1840 }
1841
1842 // Okay. We've made argument adjustments, now call into the package
1843
1844 func << tab4 << "my $result = " << package << "::" << name_member(realname,class_name)
1845 << "(@args);\n";
1846
1847 // Now check to see what kind of return result was found.
1848 // If this function is returning a result by 'value', SWIG did an
1849 // implicit malloc/new. We'll mark the object like it was created
1850 // in Perl so we can garbage collect it.
1851
1852 if ((classes.lookup(t->name)) && (t->is_pointer <=1)) {
1853
1854 func << tab4 << "return undef if (!defined($result));\n";
1855
1856 // If we're returning an object by value, put it's reference
1857 // into our local hash table
1858
1859 if ((t->is_pointer == 0) || ((t->is_pointer == 1) && NewObject)) {
1860 func << tab4 << "$" << (char *) classes.lookup(t->name) << "::OWNER{$result} = 1;\n";
1861 }
1862
1863 // We're returning a Perl "object" of some kind. Turn it into
1864 // a tied hash
1865
1866 func << tab4 << "my %resulthash;\n"
1867 /* << tab4 << "tie %resulthash, \"" << (char *) classes.lookup(t->name) << "\", $result;\n"
1868 << tab4 << "return bless \\%resulthash, \"" << (char *) classes.lookup(t->name) << "\";\n" */
1869 << tab4 << "tie %resulthash, ref($result), $result;\n"
1870 << tab4 << "return bless \\%resulthash, ref($result);\n"
1871
1872 << "}\n";
1873
1874 } else {
1875
1876 // Hmmm. This doesn't appear to be anything I know about so just
1877 // return it unmolested.
1878
1879 func << tab4 <<"return $result;\n"
1880 << "}\n";
1881
1882 }
1883
1884 // Append our function to the pcode segment
1885
1886 *pcode << func;
1887
1888 // Create a new kind of documentation entry for the shadow class
1889
1890 if (doc_entry) {
1891 doc_entry->usage = ""; // Blow away whatever was there before
1892 doc_entry->usage << usage_func(realname,t,l);
1893 }
1894}
1895
1896// --------------------------------------------------------------------------------
1897// PERL5::cpp_variable(char *name, char *iname, DataType *t)
1898//
1899// Adds an instance member. This is a little hairy because data members are
1900// really added with a tied-hash table that is attached to the object.
1901//
1902// On the low level, we will emit a pair of get/set functions to retrieve
1903// values just like before. These will then be encapsulated in a FETCH/STORE
1904// method associated with the tied-hash.
1905//
1906// In the event that a member is an object that we have already wrapped, then
1907// we need to retrieve the data a tied-hash as opposed to what SWIG normally
1908// returns. To determine this, we build an internal hash called 'BLESSEDMEMBERS'
1909// that contains the names and types of tied data members. If a member name
1910// is in the list, we tie it, otherwise, we just return the normal SWIG value.
1911// --------------------------------------------------------------------------------
1912
1913void PERL5::cpp_variable(char *name, char *iname, DataType *t) {
1914
1915 char *realname;
1916 String cname = "perl5:";
1917
1918 // Emit a pair of get/set functions for the variable
1919
1920 member_func = 1;
1921 this->Language::cpp_variable(name, iname, t);
1922 member_func = 0;
1923
1924 if (iname) realname = iname;
1925 else realname = name;
1926
1927 if (blessed) {
1928 cname << class_name << "::" << realname;
1929 if (add_symbol(cname.get(),0,0)) {
1930 return; // Forget it, we saw this already
1931 }
1932
1933 // Store name of key for future reference
1934
1935 *member_keys << "'" << realname << "', ";
1936
1937 // Now we need to generate a little Perl code for this
1938
1939 if ((classes.lookup(t->name)) && (t->is_pointer <= 1)) {
1940
1941 // This is a Perl object that we have already seen. Add an
1942 // entry to the members list
1943
1944 *blessedmembers << tab4 << realname << " => '" << (char *) classes.lookup(t->name) << "',\n";
1945
1946 }
1947
1948 // Patch up the documentation entry
1949
1950 if (doc_entry) {
1951 doc_entry->usage = "";
1952 doc_entry->usage << "$this->{" << realname << "}";
1953 }
1954 }
1955 have_data_members++;
1956}
1957
1958
1959// -----------------------------------------------------------------------------
1960// void PERL5::cpp_constructor(char *name, char *iname, ParmList *l)
1961//
1962// Emits a blessed constructor for our class. In addition to our construct
1963// we manage a Perl hash table containing all of the pointers created by
1964// the constructor. This prevents us from accidentally trying to free
1965// something that wasn't necessarily allocated by malloc or new
1966// -----------------------------------------------------------------------------
1967
1968void PERL5::cpp_constructor(char *name, char *iname, ParmList *l) {
1969 Parm *p;
1970 int i;
1971 char *realname;
1972 String cname="perl5:constructor:";
1973
1974 // Emit an old-style constructor for this class
1975
1976 member_func = 1;
1977 this->Language::cpp_constructor(name, iname, l);
1978
1979 if (blessed) {
1980
1981 if (iname)
1982 realname = iname;
1983 else {
1984 if (class_renamed) realname = class_name;
1985 else realname = class_name;
1986 }
1987
1988 cname << class_name << "::" << realname;
1989 if (add_symbol(cname.get(),0,0)) {
1990 return; // Forget it, we saw this already
1991 }
1992 if ((strcmp(realname,class_name) == 0) || ((!iname) && (ObjCClass)) ){
1993
1994 // Emit a blessed constructor
1995
1996 *pcode << "sub new {\n";
1997
1998 } else {
1999
2000 // Constructor doesn't match classname so we'll just use the normal name
2001
2002 *pcode << "sub " << name_construct(realname) << " () {\n";
2003
2004 }
2005
2006 *pcode << tab4 << "my $self = shift;\n"
2007 << tab4 << "my @args = @_;\n";
2008
2009 // We are going to need to patch up arguments here if necessary
2010 // Now we have to go through and patch up the argument list. If any
2011 // arguments to our function correspond to other Perl objects, we
2012 // need to extract them from a tied-hash table object.
2013
2014 p = l->get_first();
2015 i = 0;
2016 while(p) {
2017
2018 // Look up the datatype name here
2019
2020 if ((classes.lookup(p->t->name)) && (p->t->is_pointer <= 1)) {
2021
2022 // Yep. This smells alot like an object, patch up the arguments
2023 *pcode << tab4 << "$args[" << i << "] = tied(%{$args[" << i << "]});\n";
2024 }
2025 p = l->get_next();
2026 i++;
2027 }
2028
2029 *pcode << tab4 << "$self = " << package << "::" << name_construct(realname) << "(@args);\n"
2030 << tab4 << "return undef if (!defined($self));\n"
2031 << tab4 << "bless $self, \"" << fullclassname << "\";\n"
2032 << tab4 << "$OWNER{$self} = 1;\n"
2033 << tab4 << "my %retval;\n"
2034 << tab4 << "tie %retval, \"" << fullclassname << "\", $self;\n"
2035 << tab4 << "return bless \\%retval,\"" << fullclassname << "\";\n"
2036 << "}\n\n";
2037 have_constructor = 1;
2038
2039 // Patch up the documentation entry
2040
2041 if (doc_entry) {
2042 doc_entry->usage = "";
2043 doc_entry->usage << usage_func("new",0,l);
2044 }
2045 }
2046 member_func = 0;
2047}
2048
2049
2050// ------------------------------------------------------------------------------
2051// void PERL5::cpp_destructor(char *name, char *newname)
2052//
2053// Creates a destructor for a blessed object
2054// ------------------------------------------------------------------------------
2055
2056void PERL5::cpp_destructor(char *name, char *newname) {
2057
2058 char *realname;
2059 member_func = 1;
2060 this->Language::cpp_destructor(name, newname);
2061
2062 if (blessed) {
2063 if (newname) realname = newname;
2064 else {
2065 if (class_renamed) realname = class_name;
2066 else realname = name;
2067 }
2068
2069 // Emit a destructor for this object
2070
2071 *pcode << "sub DESTROY {\n"
2072 << tab4 << "my $self = tied(%{$_[0]});\n"
2073 << tab4 << "delete $ITERATORS{$self};\n"
2074 << tab4 << "if (exists $OWNER{$self}) {\n"
2075 << tab8 << package << "::" << name_destroy(realname) << "($self);\n"
2076 << tab8 << "delete $OWNER{$self};\n"
2077 << tab4 << "}\n}\n\n";
2078
2079 have_destructor = 1;
2080
2081 if (doc_entry) {
2082 doc_entry->usage = "DESTROY";
2083 doc_entry->cinfo = "Destructor";
2084 }
2085 }
2086 member_func = 0;
2087}
2088// -----------------------------------------------------------------------------
2089// void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l)
2090//
2091// Emits a wrapper for a static class function. Basically, we just call the
2092// appropriate method in the module package.
2093// ------------------------------------------------------------------------------
2094void PERL5::cpp_static_func(char *name, char *iname, DataType *t, ParmList *l) {
2095 this->Language::cpp_static_func(name,iname,t,l);
2096 char *realname;
2097 if (iname) realname = name;
2098 else realname = iname;
2099
2100 if (blessed) {
2101 *pcode << "*" << realname << " = *" << realpackage << "::" << name_member(realname,class_name) << ";\n";
2102 }
2103}
2104
2105// ------------------------------------------------------------------------------
2106// void PERL5::cpp_inherit(char **baseclass, int mode)
2107//
2108// This sets the Perl5 baseclass (if possible).
2109// ------------------------------------------------------------------------------
2110
2111void PERL5::cpp_inherit(char **baseclass, int) {
2112
2113 char *bc;
2114 int i = 0, have_first = 0;
2115 if (!blessed) {
2116 this->Language::cpp_inherit(baseclass);
2117 return;
2118 }
2119
2120 // Inherit variables and constants from base classes, but not
2121 // functions (since Perl can handle that okay).
2122
2123 this->Language::cpp_inherit(baseclass, INHERIT_CONST | INHERIT_VAR);
2124
2125 // Now tell the Perl5 module that we're inheriting from base classes
2126
2127 base_class = new String;
2128 while (baseclass[i]) {
2129 // See if this is a class we know about
2130 bc = (char *) classes.lookup(baseclass[i]);
2131 if (bc) {
2132 if (have_first) *base_class << " ";
2133 *base_class << bc;
2134 have_first = 1;
2135 }
2136 i++;
2137 }
2138 if (!have_first) {
2139 delete base_class;
2140 base_class = 0;
2141 }
2142}
2143
2144// --------------------------------------------------------------------------------
2145// PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value)
2146//
2147// Add access to a C++ constant. We can really just do this by hacking
2148// the symbol table
2149// --------------------------------------------------------------------------------
2150
2151void PERL5::cpp_declare_const(char *name, char *iname, DataType *type, char *value) {
2152 char *realname;
2153 int oldblessed = blessed;
2154 String cname;
2155
2156 // Create a normal constant
2157 blessed = 0;
2158 this->Language::cpp_declare_const(name, iname, type, value);
2159 blessed = oldblessed;
2160
2161 if (blessed) {
2162 if (!iname)
2163 realname = name;
2164 else
2165 realname = iname;
2166
2167 cname << class_name << "::" << realname;
2168 if (add_symbol(cname.get(),0,0)) {
2169 return; // Forget it, we saw this already
2170 }
2171
2172 // Create a symbol table entry for it
2173 *pcode << "*" << realname << " = *" << package << "::" << name_member(realname,class_name) << ";\n";
2174
2175 // Fix up the documentation entry
2176
2177 if (doc_entry) {
2178 doc_entry->usage = "";
2179 doc_entry->usage << realname;
2180 if (value) {
2181 doc_entry->usage << " = " << value;
2182 }
2183 }
2184 }
2185}
2186
2187// -----------------------------------------------------------------------
2188// PERL5::cpp_class_decl(char *name, char *rename, char *type)
2189//
2190// Treatment of an empty class definition. Used to handle
2191// shadow classes across modules.
2192// -----------------------------------------------------------------------
2193
2194void PERL5::cpp_class_decl(char *name, char *rename, char *type) {
2195 char temp[256];
2196 if (blessed) {
2197 classes.add(name,copy_string(rename));
2198 // Add full name of datatype to the hash table
2199 if (strlen(type) > 0) {
2200 sprintf(temp,"%s %s", type, name);
2201 classes.add(temp,copy_string(rename));
2202 }
2203 }
2204}
2205
2206// --------------------------------------------------------------------------------
2207// PERL5::add_typedef(DataType *t, char *name)
2208//
2209// This is called whenever a typedef is encountered. When shadow classes are
2210// used, this function lets us discovered hidden uses of a class. For example :
2211//
2212// struct FooBar {
2213// ...
2214// }
2215//
2216// typedef FooBar *FooBarPtr;
2217//
2218// --------------------------------------------------------------------------------
2219
2220void PERL5::add_typedef(DataType *t, char *name) {
2221
2222 if (!blessed) return;
2223
2224 // First check to see if there aren't too many pointers
2225
2226 if (t->is_pointer > 1) return;
2227
2228 if (classes.lookup(name)) return; // Already added
2229
2230 // Now look up the datatype in our shadow class hash table
2231
2232 if (classes.lookup(t->name)) {
2233
2234 // Yep. This datatype is in the hash
2235
2236 // Put this types 'new' name into the hash
2237
2238 classes.add(name,copy_string((char *) classes.lookup(t->name)));
2239 }
2240}
2241
2242
2243// --------------------------------------------------------------------------------
2244// PERL5::pragma(char *, char *, char *)
2245//
2246// Pragma directive.
2247//
2248// %pragma(perl5) code="String" # Includes a string in the .pm file
2249// %pragma(perl5) include="file.pl" # Includes a file in the .pm file
2250//
2251// --------------------------------------------------------------------------------
2252
2253void PERL5::pragma(char *lang, char *code, char *value) {
2254 if (strcmp(lang,"perl5") == 0) {
2255 if (strcmp(code,"code") == 0) {
2256 // Dump the value string into the .pm file
2257 if (value) {
2258 pragma_include << value << "\n";
2259 }
2260 } else if (strcmp(code,"include") == 0) {
2261 // Include a file into the .pm file
2262 if (value) {
2263 if (get_file(value,pragma_include) == -1) {
2264 fprintf(stderr,"%s : Line %d. Unable to locate file %s\n", input_file, line_number,value);
2265 }
2266 }
2267 } else {
2268 fprintf(stderr,"%s : Line %d. Unrecognized pragma.\n", input_file,line_number);
2269 }
2270 }
2271}
wxWidgets (Impactor)