~ubuntu-branches/ubuntu/oneiric/swig1.3/oneiric

« back to all changes in this revision

Viewing changes to Source/Modules/perl5.cxx

  • Committer: Bazaar Package Importer
  • Author(s): Michael Vogt
  • Date: 2008-11-10 16:29:56 UTC
  • mfrom: (1.2.8 upstream) (2.1.3 lenny)
  • Revision ID: james.westby@ubuntu.com-20081110162956-xue6itkuqhbza87s
Tags: 1.3.36-1ubuntu1
* Merge from debian unstable, remaining changes:
  - Drop pike and libchicken-dev from the build-depends 
    (both are universe)
  - Use python2.5 instead of python2.4.
  - use php5
  - Clean Runtime/ as well.
  - debian/Rules (clean): Remove Lib/ocaml/swigp4.ml.
  - drop "--without-mzscheme", we don't have it in our build-depends

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
/* -*- mode: c++; c-basic-offset: 2; indent-tabs-mode: nil; -*-
 
2
 *  vim:expandtab:shiftwidth=2:tabstop=8:smarttab:
 
3
 */
 
4
 
1
5
/* ----------------------------------------------------------------------------
2
6
 * See the LICENSE file for information on copyright, usage and redistribution
3
7
 * of SWIG, and the README file for authors - http://www.swig.org/release.html.
7
11
 * Perl5 language module for SWIG.
8
12
 * ------------------------------------------------------------------------- */
9
13
 
10
 
char cvsroot_perl5_cxx[] = "$Id: perl5.cxx 10336 2008-04-03 11:31:41Z jason_e_stewart $";
 
14
char cvsroot_perl5_cxx[] = "$Id: perl5.cxx 10453 2008-05-15 21:18:44Z wsfulton $";
11
15
 
12
16
#include "swigmod.h"
13
17
#include "cparse.h"
41
45
/*
42
46
 * module
43
47
 *   set by the %module directive, e.g. "Xerces". It will determine
44
 
 *   the name of the .pm file, and the dynamic library.
 
48
 *   the name of the .pm file, and the dynamic library, and the name
 
49
 *   used by any module wanting to %import the module.
45
50
 */
46
51
static String *module = 0;
47
52
 
48
53
/*
49
 
 * fullmodule
50
 
 *   the fully namespace qualified name of the module, e.g. "XML::Xerces"
51
 
 *   it will be used to set the package namespace in the .pm file, as
52
 
 *   well as the name of the initialization methods in the glue library
 
54
 * namespace_module
 
55
 *   the fully namespace qualified name of the module. It will be used
 
56
 *   to set the package namespace in the .pm file, as well as the name
 
57
 *   of the initialization methods in the glue library. This will be
 
58
 *   the same as module, above, unless the %module directive is given
 
59
 *   the 'package' option, e.g. %module(package="Foo::Bar") "baz"
53
60
 */
54
 
static String *fullmodule = 0;
 
61
static String       *namespace_module = 0;
 
62
 
55
63
/*
56
64
 * cmodule
57
65
 *   the namespace of the internal glue code, set to the value of
59
67
 */
60
68
static String *cmodule = 0;
61
69
 
 
70
/*
 
71
 * dest_package
 
72
 *   an optional namespace to put all classes into. Specified by using
 
73
 *   the %module(package="Foo::Bar") "baz" syntax
 
74
 */
 
75
static String       *dest_package = 0;
 
76
 
62
77
static String *command_tab = 0;
63
78
static String *constant_tab = 0;
64
79
static String *variable_tab = 0;
71
86
static String *pm;              /* Package initialization code */
72
87
static String *magic;           /* Magic variable wrappers     */
73
88
 
74
 
static int is_static = 0;
 
89
static int staticoption = 0;
 
90
 
 
91
// controlling verbose output
 
92
static int          verbose = 0;
75
93
 
76
94
/* The following variables are used to manage Perl5 classes */
77
95
 
146
164
          export_all = 1;
147
165
          Swig_mark_arg(i);
148
166
        } else if (strcmp(argv[i], "-static") == 0) {
149
 
          is_static = 1;
 
167
          staticoption = 1;
150
168
          Swig_mark_arg(i);
151
169
        } else if ((strcmp(argv[i], "-shadow") == 0) || ((strcmp(argv[i], "-proxy") == 0))) {
152
170
          blessed = 1;
166
184
          i++;
167
185
          pmfile = NewString(argv[i]);
168
186
          Swig_mark_arg(i);
 
187
        } else if (strcmp(argv[i],"-v") == 0) {
 
188
            Swig_mark_arg(i);
 
189
            verbose++;
169
190
        } else if (strcmp(argv[i], "-cppcast") == 0) {
170
191
          cppcast = 1;
171
192
          Swig_mark_arg(i);
237
258
    Printf(f_runtime, "#define SWIG_CASTRANK_MODE\n");
238
259
 
239
260
 
240
 
    module = Copy(Getattr(n, "name"));
 
261
    // Is the imported module in another package?  (IOW, does it use the
 
262
    // %module(package="name") option and it's different than the package
 
263
    // of this module.)
 
264
    Node *mod = Getattr(n, "module");
 
265
    Node *options = Getattr(mod, "options");
 
266
    module = Copy(Getattr(n,"name"));
 
267
 
 
268
    if (verbose > 0) {
 
269
      fprintf(stdout, "top: using module: %s\n", Char(module));
 
270
    }
 
271
 
 
272
    dest_package = options ? Getattr(options, "package") : 0;
 
273
    if (dest_package) {
 
274
      namespace_module = Copy(dest_package);
 
275
      if (verbose > 0) {
 
276
        fprintf(stdout, "top: Found package: %s\n",Char(dest_package));
 
277
      }
 
278
    } else {
 
279
      namespace_module = Copy(module);
 
280
      if (verbose > 0) {
 
281
        fprintf(stdout, "top: No package found\n");
 
282
      }
 
283
    }
 
284
    String *underscore_module = Copy(module);
 
285
    Replaceall(underscore_module,":","_");
 
286
 
 
287
    if (verbose > 0) {
 
288
      fprintf(stdout, "top: using namespace_module: %s\n", Char(namespace_module));
 
289
    }
241
290
 
242
291
    /* If we're in blessed mode, change the package name to "packagec" */
243
292
 
244
293
    if (blessed) {
245
 
      cmodule = NewStringf("%sc", module);
 
294
      cmodule = NewStringf("%sc",namespace_module);
246
295
    } else {
247
 
      cmodule = NewString(module);
 
296
      cmodule = NewString(namespace_module);
248
297
    }
249
 
    fullmodule = NewString(module);
250
298
 
251
299
    /* Create a .pm file
252
300
     * Need to strip off any prefixes that might be found in
277
325
      Swig_register_filebyname("perl", f_pm);
278
326
    }
279
327
    {
280
 
      String *tmp = NewString(fullmodule);
281
 
      Replaceall(tmp, ":", "_");
282
 
      Printf(f_header, "#define SWIG_init    boot_%s\n\n", tmp);
283
 
      Printf(f_header, "#define SWIG_name   \"%s::boot_%s\"\n", cmodule, tmp);
284
 
      Printf(f_header, "#define SWIG_prefix \"%s::\"\n", cmodule);
285
 
      Delete(tmp);
 
328
      String *boot_name = NewStringf("boot_%s", underscore_module);
 
329
      Printf(f_header,"#define SWIG_init    %s\n\n", boot_name);
 
330
      Printf(f_header,"#define SWIG_name   \"%s::%s\"\n", cmodule, boot_name);
 
331
      Printf(f_header,"#define SWIG_prefix \"%s::\"\n", cmodule);
 
332
      Delete(boot_name);
286
333
    }
287
334
 
288
335
    Printf(f_pm, "# This file was automatically generated by SWIG (http://www.swig.org).\n");
291
338
    Printf(f_pm, "# Don't modify this file, modify the SWIG interface instead.\n");
292
339
    Printf(f_pm, "\n");
293
340
 
294
 
    Printf(f_pm, "package %s;\n", fullmodule);
 
341
    Printf(f_pm, "package %s;\n", module);
295
342
 
296
 
    Printf(f_pm, "require Exporter;\n");
297
 
    if (!is_static) {
298
 
      Printf(f_pm, "require DynaLoader;\n");
299
 
      Printf(f_pm, "@ISA = qw(Exporter DynaLoader);\n");
 
343
    /* 
 
344
     * If the package option has been given we are placing our
 
345
     *   symbols into some other packages namespace, so we do not
 
346
     *   mess with @ISA or require for that package
 
347
     */
 
348
    if (dest_package) {
 
349
      Printf(f_pm,"use base qw(DynaLoader);\n");
300
350
    } else {
301
 
      Printf(f_pm, "@ISA = qw(Exporter);\n");
 
351
      Printf(f_pm,"use base qw(Exporter);\n");
 
352
      if (!staticoption) {
 
353
        Printf(f_pm,"use base qw(DynaLoader);\n");
 
354
      }
302
355
    }
303
356
 
304
357
    /* Start creating magic code */
306
359
    Printv(magic,
307
360
           "#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n",
308
361
           "#ifdef PERL_OBJECT\n",
309
 
           "#define MAGIC_CLASS _wrap_", module, "_var::\n",
310
 
           "class _wrap_", module, "_var : public CPerlObj {\n",
 
362
           "#define MAGIC_CLASS _wrap_", underscore_module, "_var::\n",
 
363
           "class _wrap_", underscore_module, "_var : public CPerlObj {\n",
311
364
           "public:\n",
312
365
           "#else\n",
313
366
           "#define MAGIC_CLASS\n",
374
427
 
375
428
    Printf(f_pm, "package %s;\n", cmodule);
376
429
 
377
 
    if (!is_static) {
378
 
      Printf(f_pm, "bootstrap %s;\n", fullmodule);
 
430
    if (!staticoption) {
 
431
      Printf(f_pm,"bootstrap %s;\n", module);
379
432
    } else {
380
 
      String *tmp = NewString(fullmodule);
381
 
      Replaceall(tmp, ":", "_");
382
 
      Printf(f_pm, "boot_%s();\n", tmp);
383
 
      Delete(tmp);
384
 
    }
385
 
    Printf(f_pm, "package %s;\n", fullmodule);
386
 
    Printf(f_pm, "@EXPORT = qw( %s);\n", exported);
 
433
      Printf(f_pm,"package %s;\n", cmodule);
 
434
      Printf(f_pm,"boot_%s();\n", underscore_module);
 
435
    }
 
436
 
 
437
    Printf(f_pm, "package %s;\n", module);
 
438
    /* 
 
439
     * If the package option has been given we are placing our
 
440
     *   symbols into some other packages namespace, so we do not
 
441
     *   mess with @EXPORT
 
442
     */
 
443
    if (!dest_package) {
 
444
      Printf(f_pm,"@EXPORT = qw(%s);\n", exported);
 
445
    }
 
446
 
387
447
    Printf(f_pm, "%s", pragma_include);
388
448
 
389
449
    if (blessed) {
390
450
 
391
 
      Printv(base, "\n# ---------- BASE METHODS -------------\n\n", "package ", fullmodule, ";\n\n", NIL);
392
 
 
393
 
      /* Write out the TIE method */
394
 
 
395
 
      Printv(base, "sub TIEHASH {\n", tab4, "my ($classname,$obj) = @_;\n", tab4, "return bless $obj, $classname;\n", "}\n\n", NIL);
396
 
 
397
 
      /* Output a CLEAR method.   This is just a place-holder, but by providing it we
398
 
       * can make declarations such as
399
 
       *     %$u = ( x => 2, y=>3, z =>4 );
400
 
       *
401
 
       * Where x,y,z are the members of some C/C++ object. */
402
 
 
403
 
      Printf(base, "sub CLEAR { }\n\n");
404
 
 
405
 
      /* Output default firstkey/nextkey methods */
406
 
 
407
 
      Printf(base, "sub FIRSTKEY { }\n\n");
408
 
      Printf(base, "sub NEXTKEY { }\n\n");
409
 
 
410
 
      /* Output a FETCH method.  This is actually common to all classes */
411
 
      Printv(base,
412
 
             "sub FETCH {\n",
413
 
             tab4, "my ($self,$field) = @_;\n", tab4, "my $member_func = \"swig_${field}_get\";\n", tab4, "$self->$member_func();\n", "}\n\n", NIL);
414
 
 
415
 
      /* Output a STORE method.   This is also common to all classes (might move to base class) */
416
 
 
417
 
      Printv(base,
418
 
             "sub STORE {\n",
419
 
             tab4, "my ($self,$field,$newval) = @_;\n",
420
 
             tab4, "my $member_func = \"swig_${field}_set\";\n", tab4, "$self->$member_func($newval);\n", "}\n\n", NIL);
421
 
 
422
 
      /* Output a 'this' method */
423
 
 
424
 
      Printv(base, "sub this {\n", tab4, "my $ptr = shift;\n", tab4, "return tied(%$ptr);\n", "}\n\n", NIL);
425
 
 
426
 
      Printf(f_pm, "%s", base);
 
451
      /*
 
452
       * These methods will be duplicated if package 
 
453
       *   has been specified, so we do not output them
 
454
       */
 
455
      if (!dest_package) {
 
456
        Printv(base, "\n# ---------- BASE METHODS -------------\n\n", "package ", namespace_module, ";\n\n", NIL);
 
457
 
 
458
        /* Write out the TIE method */
 
459
 
 
460
        Printv(base, "sub TIEHASH {\n", tab4, "my ($classname,$obj) = @_;\n", tab4, "return bless $obj, $classname;\n", "}\n\n", NIL);
 
461
 
 
462
        /* Output a CLEAR method.   This is just a place-holder, but by providing it we
 
463
         * can make declarations such as
 
464
         *     %$u = ( x => 2, y=>3, z =>4 );
 
465
         *
 
466
         * Where x,y,z are the members of some C/C++ object. */
 
467
 
 
468
        Printf(base, "sub CLEAR { }\n\n");
 
469
 
 
470
        /* Output default firstkey/nextkey methods */
 
471
 
 
472
        Printf(base, "sub FIRSTKEY { }\n\n");
 
473
        Printf(base, "sub NEXTKEY { }\n\n");
 
474
 
 
475
        /* Output a FETCH method.  This is actually common to all classes */
 
476
        Printv(base,
 
477
               "sub FETCH {\n",
 
478
               tab4, "my ($self,$field) = @_;\n", tab4, "my $member_func = \"swig_${field}_get\";\n", tab4, "$self->$member_func();\n", "}\n\n", NIL);
 
479
 
 
480
        /* Output a STORE method.   This is also common to all classes (might move to base class) */
 
481
 
 
482
        Printv(base,
 
483
               "sub STORE {\n",
 
484
               tab4, "my ($self,$field,$newval) = @_;\n",
 
485
               tab4, "my $member_func = \"swig_${field}_set\";\n", tab4, "$self->$member_func($newval);\n", "}\n\n", NIL);
 
486
 
 
487
        /* Output a 'this' method */
 
488
 
 
489
        Printv(base, "sub this {\n", tab4, "my $ptr = shift;\n", tab4, "return tied(%$ptr);\n", "}\n\n", NIL);
 
490
 
 
491
        Printf(f_pm, "%s", base);
 
492
      }
427
493
 
428
494
      /* Emit function stubs for stand-alone functions */
429
 
 
430
495
      Printf(f_pm, "\n# ------- FUNCTION WRAPPERS --------\n\n");
431
 
      Printf(f_pm, "package %s;\n\n", fullmodule);
 
496
      Printf(f_pm, "package %s;\n\n", namespace_module);
432
497
      Printf(f_pm, "%s", func_stubs);
433
498
 
434
499
      /* Emit package code for different classes */
437
502
      if (num_consts > 0) {
438
503
        /* Emit constant stubs */
439
504
        Printf(f_pm, "\n# ------- CONSTANT STUBS -------\n\n");
440
 
        Printf(f_pm, "package %s;\n\n", fullmodule);
 
505
        Printf(f_pm, "package %s;\n\n", namespace_module);
441
506
        Printf(f_pm, "%s", const_stubs);
442
507
      }
443
508
 
444
509
      /* Emit variable stubs */
445
510
 
446
511
      Printf(f_pm, "\n# ------- VARIABLE STUBS --------\n\n");
447
 
      Printf(f_pm, "package %s;\n\n", fullmodule);
 
512
      Printf(f_pm, "package %s;\n\n", namespace_module);
448
513
      Printf(f_pm, "%s", var_stubs);
449
514
    }
450
515
 
455
520
    Close(f_pm);
456
521
    Delete(f_pm);
457
522
    Delete(base);
 
523
    Delete(dest_package);
 
524
    Delete(underscore_module);
458
525
 
459
526
    /* Close all of the files */
460
527
    Dump(f_header, f_runtime);
522
589
    Printv(f->def, "XS(", wname, ") {\n", "{\n",        /* scope to destroy C++ objects before croaking */
523
590
           NIL);
524
591
 
525
 
    emit_args(d, l, f);
 
592
    emit_parameter_variables(l, f);
526
593
    emit_attach_parmmaps(l, f);
527
594
    Setattr(n, "wrap:parms", l);
528
595
 
655
722
 
656
723
    /* Now write code to make the function call */
657
724
 
658
 
    emit_action(n, f);
 
725
    Swig_director_emit_dynamic_cast(n, f);
 
726
    String *actioncode = emit_action(n);
659
727
 
660
 
    if ((tm = Swig_typemap_lookup_new("out", n, "result", 0))) {
 
728
    if ((tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode))) {
661
729
      SwigType *t = Getattr(n, "type");
662
730
      Replaceall(tm, "$source", "result");
663
731
      Replaceall(tm, "$target", "ST(argvi)");
676
744
    } else {
677
745
      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);
678
746
    }
 
747
    emit_return_variable(n, d, f);
679
748
 
680
749
    /* If there were any output args, take care of them. */
681
750
 
686
755
    Printv(f->code, cleanup, NIL);
687
756
 
688
757
    if (GetFlag(n, "feature:new")) {
689
 
      if ((tm = Swig_typemap_lookup_new("newfree", n, "result", 0))) {
 
758
      if ((tm = Swig_typemap_lookup("newfree", n, "result", 0))) {
690
759
        Replaceall(tm, "$source", "result");
691
760
        Printf(f->code, "%s\n", tm);
692
761
      }
693
762
    }
694
763
 
695
 
    if ((tm = Swig_typemap_lookup_new("ret", n, "result", 0))) {
 
764
    if ((tm = Swig_typemap_lookup("ret", n, "result", 0))) {
696
765
      Replaceall(tm, "$source", "result");
697
766
      Printf(f->code, "%s\n", tm);
698
767
    }
787
856
      Printv(setf->code, tab4, "MAGIC_PPERL\n", NIL);
788
857
 
789
858
      /* Check for a few typemaps */
790
 
      tm = Swig_typemap_lookup_new("varin", n, name, 0);
 
859
      tm = Swig_typemap_lookup("varin", n, name, 0);
791
860
      if (tm) {
792
861
        Replaceall(tm, "$source", "sv");
793
862
        Replaceall(tm, "$target", name);
794
863
        Replaceall(tm, "$input", "sv");
795
864
        /* Printf(setf->code,"%s\n", tm); */
796
 
        emit_action_code(n, setf, tm);
 
865
        emit_action_code(n, setf->code, tm);
797
866
      } else {
798
867
        Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number, "Unable to set variable of type %s.\n", SwigType_str(t, 0));
799
868
        return SWIG_NOWRAP;
810
879
    Printf(getf->def, "SWIGCLASS_STATIC int %s(pTHX_ SV *sv, MAGIC *SWIGUNUSEDPARM(mg)) {\n", get_name);
811
880
    Printv(getf->code, tab4, "MAGIC_PPERL\n", NIL);
812
881
 
813
 
    if ((tm = Swig_typemap_lookup_new("varout", n, name, 0))) {
 
882
    if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
814
883
      Replaceall(tm, "$target", "sv");
815
884
      Replaceall(tm, "$result", "sv");
816
885
      Replaceall(tm, "$source", name);
820
889
        Replaceall(tm, "$shadow", "0");
821
890
      }
822
891
      /* Printf(getf->code,"%s\n", tm); */
823
 
      addfail = emit_action_code(n, getf, tm);
 
892
      addfail = emit_action_code(n, getf->code, tm);
824
893
    } else {
825
894
      Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number, "Unable to read variable of type %s\n", SwigType_str(t, 0));
826
895
      DelWrapper(setf);
913
982
      value = Char(wname);
914
983
    }
915
984
 
916
 
    if ((tm = Swig_typemap_lookup_new("consttab", n, name, 0))) {
 
985
    if ((tm = Swig_typemap_lookup("consttab", n, name, 0))) {
917
986
      Replaceall(tm, "$source", value);
918
987
      Replaceall(tm, "$target", name);
919
988
      Replaceall(tm, "$value", value);
923
992
        Replaceall(tm, "$shadow", "0");
924
993
      }
925
994
      Printf(constant_tab, "%s,\n", tm);
926
 
    } else if ((tm = Swig_typemap_lookup_new("constcode", n, name, 0))) {
 
995
    } else if ((tm = Swig_typemap_lookup("constcode", n, name, 0))) {
927
996
      Replaceall(tm, "$source", value);
928
997
      Replaceall(tm, "$target", name);
929
998
      Replaceall(tm, "$value", value);
1071
1140
    }
1072
1141
 
1073
1142
    /* Do some work on the class name */
1074
 
    actualpackage = Getattr(clsmodule, "name");
1075
 
    if ((!compat) && (!Strchr(symname, ':'))) {
1076
 
      fullname = NewStringf("%s::%s", actualpackage, symname);
 
1143
    if (verbose > 0) {
 
1144
      fprintf(stdout, "setclassname: Found sym:name: %s\n", Char(symname));
 
1145
      fprintf(stdout, "setclassname: Found module: %s\n", Char(clsmodule));
 
1146
      fprintf(stdout, "setclassname: No package found\n");
 
1147
    }
 
1148
 
 
1149
    if (dest_package) {
 
1150
      fullname = NewStringf("%s::%s", namespace_module, symname);
1077
1151
    } else {
1078
 
      fullname = NewString(symname);
 
1152
      actualpackage = Getattr(clsmodule,"name");
 
1153
 
 
1154
      if (verbose > 0) {
 
1155
        fprintf(stdout, "setclassname: Found actualpackage: %s\n", Char(actualpackage));
 
1156
      }
 
1157
      if ((!compat) && (!Strchr(symname,':'))) {
 
1158
        fullname = NewStringf("%s::%s",actualpackage,symname);
 
1159
      } else {
 
1160
        fullname = NewString(symname);
 
1161
      }
 
1162
    }
 
1163
    if (verbose > 0) {
 
1164
      fprintf(stdout, "setclassname: setting proxy: %s\n", Char(fullname));
1079
1165
    }
1080
1166
    Setattr(n, "perl5:proxy", fullname);
1081
1167
  }
1115
1201
 
1116
1202
      /* Use the fully qualified name of the Perl class */
1117
1203
      if (!compat) {
1118
 
        fullclassname = NewStringf("%s::%s", fullmodule, class_name);
 
1204
        fullclassname = NewStringf("%s::%s", namespace_module, class_name);
1119
1205
      } else {
1120
1206
        fullclassname = NewString(class_name);
1121
1207
      }
1200
1286
            fprintf(stderr,"Unknown operator: %s\n", name);
1201
1287
          }
1202
1288
        }
 
1289
        Printv(pm, tab4,
 
1290
               "\"=\" => sub { my $class = ref($_[0]); $class->new($_[0]) },\n", NIL);
1203
1291
        Printv(pm, tab4, "\"fallback\" => 1;\n", NIL);
1204
1292
      }
1205
1293
      // make use strict happy
1226
1314
      }
1227
1315
 
1228
1316
      /* Module comes last */
1229
 
      if (!compat || Cmp(fullmodule, fullclassname)) {
1230
 
        Printv(pm, " ", fullmodule, NIL);
 
1317
      if (!compat || Cmp(namespace_module, fullclassname)) {
 
1318
        Printv(pm, " ", namespace_module, NIL);
1231
1319
      }
1232
1320
 
1233
1321
      Printf(pm, " );\n");